Browse Source

Using Sqlite and adding authentication

tags/v0.1.0
Gil Mizrahi 9 months ago
parent
commit
40468b296c
21 changed files with 1349 additions and 307 deletions
  1. +1
    -1
      .gitignore
  2. +2
    -2
      app/Main.hs
  3. +67
    -0
      bulletin-app.cabal
  4. +13
    -3
      readme.md
  5. +0
    -37
      scotty-bulletin-app.cabal
  6. +0
    -259
      src/Bulletin.hs
  7. +11
    -0
      src/Web/Bulletin.hs
  8. +124
    -0
      src/Web/Bulletin/Actions/Login.hs
  9. +174
    -0
      src/Web/Bulletin/Actions/NewUser.hs
  10. +184
    -0
      src/Web/Bulletin/Actions/Posts.hs
  11. +85
    -0
      src/Web/Bulletin/Config.hs
  12. +99
    -0
      src/Web/Bulletin/DbAccess.hs
  13. +44
    -0
      src/Web/Bulletin/Html.hs
  14. +59
    -0
      src/Web/Bulletin/Model.hs
  15. +47
    -0
      src/Web/Bulletin/Router.hs
  16. +60
    -0
      src/Web/Bulletin/Run.hs
  17. +138
    -0
      src/Web/Bulletin/Session.hs
  18. +227
    -0
      src/Web/Bulletin/Style.hs
  19. +9
    -0
      src/Web/Bulletin/Validation.hs
  20. +1
    -1
      stack.yaml
  21. +4
    -4
      stack.yaml.lock

+ 1
- 1
.gitignore View File

@@ -1,4 +1,4 @@
client_session_key.aes

# Created by https://www.gitignore.io/api/haskell,emacs



+ 2
- 2
app/Main.hs View File

@@ -1,4 +1,4 @@
import qualified Bulletin
import Web.Bulletin

main :: IO ()
main = Bulletin.main
main = run

+ 67
- 0
bulletin-app.cabal View File

@@ -0,0 +1,67 @@
name: bulletin-app
version: 0.1.0.0
synopsis: A simple bulletin board web app using scotty
description: Please see readme.md
homepage: https://gitlab.com/gilmi/bulletin-app
license-file: LICENSE
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: readme.md

library
hs-source-dirs: src
exposed-modules:
Web.Bulletin
Web.Bulletin.Run
Web.Bulletin.Router
Web.Bulletin.DbAccess
Web.Bulletin.Validation
Web.Bulletin.Config
Web.Bulletin.Model
Web.Bulletin.Html
Web.Bulletin.Style
Web.Bulletin.Session
Web.Bulletin.Actions.Login
Web.Bulletin.Actions.NewUser
Web.Bulletin.Actions.Posts

ghc-options: -Wall -fno-warn-type-defaults
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, text
, bytestring
, time
, containers
, raw-strings-qq
-- web
, lucid
, scotty
, wai
, wai-extra
, http-types
, monad-logger
, persistent
, persistent-template
, persistent-sqlite
-- auth
, stm
, binary
, cookie
, password
, clientsession
-- markdown
, cheapskate
, cheapskate-lucid

executable bulletin-app
hs-source-dirs: app
main-is: Main.hs
default-language: Haskell2010
ghc-options: -Wall -static -optl-static -optl-pthread -fPIC -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5
, bulletin-app


+ 13
- 3
readme.md View File

@@ -1,14 +1,24 @@
# Building a bulletin board using Haskell, scotty and friends

Check out the [blog post](https://gilmi.me/blog/post/2020/12/05/scotty-bulletin-board) for the tutorial.
This started out as a [blog post](https://gilmi.me/blog/post/2020/12/05/scotty-bulletin-board) for scotty and friends
but I've played with it more since and added a database (persistent-sqlite),
user registration and authentication (including cookies and sessions),
markdown support and a slightly nicer looking css.

## Run with
## Build with

```sh
stack build
```

## Run with

```sh
stack build && stack run
CONN_STRING='file:/tmp/bullet.db' bulletin-app
```

where `/tmp/bullet.db` is the path to the database file.

## Static executable

To compile a static executable using docker, uncomment the relevant lines in the `stack.yaml` file,


+ 0
- 37
scotty-bulletin-app.cabal View File

@@ -1,37 +0,0 @@
name: scotty-bulletin-app
version: 0.1.0.0
synopsis: A simple bulletin board web app using scotty
description: Please see readme.md
homepage: https://github.com/soupi/learn-scotty-bulletin-app
license-file: LICENSE
author: Gil Mizrahi
maintainer: gilmi@posteo.net
copyright: 2020 Gil Mizrahi
category: Web
build-type: Simple
cabal-version: >=1.10
extra-source-files: readme.md

library
hs-source-dirs: src
exposed-modules: Bulletin

ghc-options: -Wall -fno-warn-type-defaults
default-language: Haskell2010
build-depends: base >= 4.7 && < 5
, scotty
, text
, containers
, time
, http-types
, stm
, lucid

executable bulletin-app
hs-source-dirs: app
main-is: Main.hs
default-language: Haskell2010
ghc-options: -Wall -static -optl-static -optl-pthread -fPIC -threaded -rtsopts -with-rtsopts=-N
build-depends: base >= 4.7 && < 5
, scotty-bulletin-app


+ 0
- 259
src/Bulletin.hs View File

@@ -1,263 +0,0 @@
{-# language OverloadedStrings #-}

module Bulletin where

import qualified Web.Scotty as S
import qualified Data.Text.Lazy as TL
import qualified Data.Time.Clock as C
import qualified Data.Map as M
import qualified Network.HTTP.Types as HTTP
import qualified Control.Concurrent.STM as STM
import Control.Monad.IO.Class (liftIO)
import qualified Lucid as H

-----------
-----------

data Post
= Post
{ pTime :: C.UTCTime
, pAuthor :: TL.Text
, pTitle :: TL.Text
, pContent :: TL.Text
}

type Posts = M.Map Integer Post

data MyState
= MyState
{ msId :: Integer
, msPosts :: Posts
}

------------------------
------------------------

main :: IO ()
main = do
posts <- makeDummyPosts
mystateVar <- STM.newTVarIO MyState{msId = 1, msPosts = posts}
S.scotty 3000 (myApp mystateVar)

myApp :: STM.TVar MyState -> S.ScottyM ()
myApp mystateVar = do
-- Our main page, which will display all of the bulletins
S.get "/" $ do
posts <- liftIO $ msPosts <$> STM.readTVarIO mystateVar
S.html $
H.renderText $
template
"Bulletin board - posts"
(postsHtml posts)

-- A page for a specific post
S.get "/post/:id" $ do
pid <- S.param "id"
posts <- liftIO $ msPosts <$> STM.readTVarIO mystateVar
case M.lookup pid posts of
Just post ->
S.html $
H.renderText $
template
("Bulletin board - post " <> TL.pack (show pid))
(postHtml pid post)

Nothing -> do
S.status HTTP.notFound404
S.html $
H.renderText $
template
("Bulletin board - post " <> TL.pack (show pid) <> " not found.")
"404 Post not found."

-- A page for creating a new post
S.get "/new" $
S.html $
H.renderText $
template
("Bulletin board - add new post")
newPostHtml

-- A request to submit a new page
S.post "/new" $ do
title <- S.param "title"
author <- S.param "author"
content <- S.param "content"
time <- liftIO C.getCurrentTime
pid <- liftIO $ newPost
( Post
{ pTime = time
, pAuthor = author
, pTitle = title
, pContent = content
}
)
mystateVar
S.redirect ("/post/" <> TL.pack (show pid))

-- A request to submit a new page
S.post "/new" $ do
title <- S.param "title"
author <- S.param "author"
content <- S.param "content"
time <- liftIO C.getCurrentTime
pid <- liftIO $ newPost
( Post
{ pTime = time
, pAuthor = author
, pTitle = title
, pContent = content
}
)
mystateVar
S.redirect ("/post/" <> TL.pack (show pid))

-- A request to delete a specific post
S.post "/post/:id/delete" $ do
pid <- S.param "id"
exists <- liftIO $ STM.atomically $ do
mystate <- STM.readTVar mystateVar
case M.lookup pid (msPosts mystate) of
Just{} -> do
STM.writeTVar
mystateVar
( mystate
{ msPosts = M.delete pid (msPosts mystate)
}
)
pure True

Nothing ->
pure False
if exists
then
S.redirect "/"

else do
S.status HTTP.notFound404
S.text "404 Not Found."

-- css styling
S.get "/style.css" $ do
S.setHeader "Content-Type" "text/css; charset=utf-8"
S.raw ".main { width: 900px; margin: auto; }"

newPost :: Post -> STM.TVar MyState -> IO Integer
newPost post mystateVar = do
STM.atomically $ do
mystate <- STM.readTVar mystateVar
STM.writeTVar
mystateVar
( mystate
{ msId = msId mystate + 1
, msPosts = M.insert (msId mystate) post (msPosts mystate)
}
)
pure (msId mystate)

-----------
-----------

makeDummyPosts :: IO Posts
makeDummyPosts = do
time <- C.getCurrentTime
pure $
M.singleton
0
( Post
{ pTime = time
, pTitle = "Dummy title"
, pAuthor = "Dummy author"
, pContent = "bla bla bla..."
}
)

ppPost :: Post -> TL.Text
ppPost post =
let
header =
TL.unwords
[ "[" <> TL.pack (show (pTime post)) <> "]"
, pTitle post
, "by"
, pAuthor post
]
seperator =
TL.replicate (TL.length header) "-"
in
TL.unlines
[ seperator
, header
, seperator
, pContent post
, seperator
]

----------
----------

type Html = H.Html ()

template :: TL.Text -> Html -> Html
template title content =
H.doctypehtml_ $ do
H.head_ $ do
H.meta_ [ H.charset_ "utf-8" ]
H.title_ (H.toHtml title)
H.link_ [ H.rel_ "stylesheet", H.type_ "text/css", H.href_ "/style.css" ]
H.body_ $ do
H.div_ [ H.class_ "main" ] $ do
H.h1_ [ H.class_ "logo" ] $
H.a_ [H.href_ "/"] "Bulletin Board"
content

postsHtml :: Posts -> Html
postsHtml posts = do
H.p_ [ H.class_ "new-button" ] $
H.a_ [H.href_ "/new"] "New Post"
mapM_ (uncurry postHtml) $ reverse $ M.toList posts

postHtml :: Integer -> Post -> Html
postHtml pid post = do
H.div_ [ H.class_ "post" ] $ do
H.div_ [ H.class_ "post-header" ] $ do
H.h2_ [ H.class_ "post-title" ] $
H.a_
[H.href_ (TL.toStrict $ "/post/" <> TL.pack (show pid))]
(H.toHtml $ pTitle post)

H.span_ $ do
H.p_ [ H.class_ "post-time" ] $ H.toHtml (TL.pack (show (pTime post)))
H.p_ [ H.class_ "post-author" ] $ H.toHtml (pAuthor post)

H.div_ [H.class_ "post-content"] $ do
H.toHtml (pContent post)

H.form_
[ H.method_ "post"
, H.action_ (TL.toStrict $ "/post/" <> TL.pack (show pid) <> "/delete")
, H.onsubmit_ "return confirm('Are you sure?')"
, H.class_ "delete-post"
]
( do
H.input_ [H.type_ "submit", H.value_ "Delete", H.class_ "deletebtn"]
)

newPostHtml :: Html
newPostHtml = do
H.form_
[ H.method_ "post"
, H.action_ "/new"
, H.class_ "new-post"
]
( do
H.p_ $ H.input_ [H.type_ "text", H.name_ "title", H.placeholder_ "Title..."]
H.p_ $ H.input_ [H.type_ "text", H.name_ "author", H.placeholder_ "Author..."]
H.p_ $ H.textarea_ [H.name_ "content", H.placeholder_ "Content..."] ""
H.p_ $ H.input_ [H.type_ "submit", H.value_ "Submit", H.class_ "submit-button"]
)


+ 11
- 0
src/Web/Bulletin.hs View File

@@ -0,0 +1,11 @@
{-# language OverloadedStrings #-}

module Web.Bulletin
( module Export
)
where

import Web.Bulletin.Config as Export
import Web.Bulletin.Model as Export
import Web.Bulletin.Router as Export
import Web.Bulletin.Run as Export

+ 124
- 0
src/Web/Bulletin/Actions/Login.hs View File

@@ -0,0 +1,124 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Actions.Login where


import Control.Monad.IO.Class (liftIO)
import Control.Monad (join)
import qualified Data.Password.Bcrypt as Bcrypt
import qualified Data.Text.Lazy as TL
import qualified Lucid as H
import qualified Web.Scotty as S

import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Model
import Web.Bulletin.Config
import Web.Bulletin.Html
import Web.Bulletin.Session
import Web.Bulletin.Validation

-----------------
-- Login Route --
-----------------

router :: Config -> SessionStore -> S.ScottyM ()
router cfg sessionStore = do
-- A Log in page
S.get "/login" $ do
mses <- getSession sessionStore
case mses of
Nothing ->
serveLoginForm Nothing
_ ->
S.redirect "/"

-- A request to log in
S.post "/login" $ do
mses <- getSession sessionStore
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
submitLoginForm cfg sessionStore username password
_ ->
S.redirect "/"

-- Logout
S.post "/logout" $ do
mapM_ (deleteSession sessionStore) =<< getSession sessionStore
S.redirect "/"


-------------------
-- Login Actions --
-------------------

loginOrLogout :: Config -> SessionStore -> S.ActionM Html
loginOrLogout cfg sessionStore = do
muser <- liftIO . fmap join . traverse (DB.getUser cfg) =<< getSession sessionStore
pure $
H.div_ [ H.class_ "welcome" ] $
case muser of
Just user ->
mconcat
[ "Welcome " <> H.toHtml (userDisplayName user)
, " "
, H.form_ [H.method_ "post" , H.action_ "/logout", H.class_ "logout-form"] $
H.input_ [H.type_ "submit", H.value_ "Log out", H.class_ "logout"]
]
Nothing ->
mconcat
[ " " <> H.a_ [ H.href_ "/login" ] "Log in"
, " | " <> H.a_ [ H.href_ "/register" ] "Register"
]


serveLoginForm :: Maybe TL.Text -> S.ActionM ()
serveLoginForm err = do
S.html $
H.renderText $
template
("Bulletin board - register a new account")
""
(loginHtml err)

submitLoginForm :: Config -> SessionStore -> TL.Text -> TL.Text -> S.ActionM ()
submitLoginForm cfg ses username pass = do
mUserId <- liftIO $ DB.checkUser cfg username $ Bcrypt.mkPassword (TL.toStrict pass)
case mUserId of
Nothing ->
serveLoginForm $ Just "Bad username or password."
Just uid -> do
newSession ses uid
S.redirect "/"

----------------
-- Login Html --
----------------

loginHtml :: Maybe TL.Text -> Html
loginHtml err = do
H.form_
[ H.method_ "post"
, H.action_ "/login"
, H.class_ "login"
]
( do
applyMaybe err (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_
[ H.type_ "text"
, H.required_ "true"
, H.name_ "username"
, H.placeholder_ "Username..."
]
H.p_ $
H.input_
[ H.type_ "password"
, H.required_ "true"
, H.name_ "password"
, H.placeholder_ "Password..."
]

H.p_ $ H.input_ [H.type_ "submit", H.value_ "Log In", H.class_ "submit-button"]
)

+ 174
- 0
src/Web/Bulletin/Actions/NewUser.hs View File

@@ -0,0 +1,174 @@
{-# language OverloadedStrings #-}
{-# language MultiWayIf #-}

module Web.Bulletin.Actions.NewUser where

import Data.Char (isDigit, isLetter)
import qualified Data.Text.Lazy as TL

import Control.Monad.IO.Class (liftIO)
import qualified Data.Password.Bcrypt as Bcrypt
import qualified Lucid as H
import qualified Web.Scotty as S

import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Config
import Web.Bulletin.Html
import Web.Bulletin.Session
import Web.Bulletin.Validation


-------------
-- Routing --
-------------

router :: Config -> SessionStore -> S.ScottyM ()
router cfg sessionStore = do
-- S.get "/users" $ do
-- users <- liftIO $ DB.getAllUsers cfg
-- S.html $
-- H.renderText $
-- template
-- ("Bulletin board - register a new account")
-- (mapM_ (H.p_ . H.toHtml . show) users)

-- A page for creating a new post
S.get "/register" $ do
mses <- getSession sessionStore
case mses of
Nothing ->
serveNewUserForm noNewUserErrs
_ ->
S.redirect "/"

-- A request to create a new user
S.post "/register" $ do
mses <- getSession sessionStore
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
confirm <- S.param "confirm"
submitNewUserForm cfg sessionStore username password confirm
_ ->
S.redirect "/"

-------------
-- Actions --
-------------

serveNewUserForm :: NewUserErrors -> S.ActionM ()
serveNewUserForm err = do
S.html $
H.renderText $
template
("Bulletin board - register a new account")
""
(newUserHtml err)

submitNewUserForm :: Config -> SessionStore -> TL.Text -> TL.Text -> TL.Text -> S.ActionM ()
submitNewUserForm cfg ses username pass confirm = do
let
errs = validateNewUser username pass confirm
if hasNewUserErrors errs
then
serveNewUserForm errs
else do
hash <- liftIO $ Bcrypt.hashPassword $ Bcrypt.mkPassword (TL.toStrict pass)
ukey <- liftIO $ DB.insertUser cfg username hash
newSession ses ukey
S.redirect "/"

----------
-- Html --
----------


newUserHtml :: NewUserErrors -> Html
newUserHtml errs = do
H.form_
[ H.method_ "post"
, H.action_ "/register"
, H.class_ "new-user"
]
( do
applyMaybe (nueUsername errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_
[ H.type_ "text"
, H.required_ "true"
, H.name_ "username"
, H.placeholder_ "Username..."
]
applyMaybe (nuePassword errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_
[ H.type_ "password"
, H.required_ "true"
, H.name_ "password"
, H.placeholder_ "Password..."
]
applyMaybe (nueConfirm errs) (H.p_ [ H.class_ "error" ] . H.toHtml)
H.p_ $
H.input_
[ H.type_ "password"
, H.required_ "true"
, H.name_ "confirm"
, H.placeholder_ "Confirm password..."
]
H.p_ $
H.input_
[ H.type_ "submit"
, H.value_ "Submit"
, H.class_ "submit-button"
]
)

----------------
-- Validation --
----------------


noNewUserErrs :: NewUserErrors
noNewUserErrs = NewUserErrors Nothing Nothing Nothing

hasNewUserErrors :: NewUserErrors -> Bool
hasNewUserErrors errs =
case errs of
NewUserErrors Nothing Nothing Nothing ->
False
_ ->
True

data NewUserErrors
= NewUserErrors
{ nueUsername :: Maybe TL.Text
, nuePassword :: Maybe TL.Text
, nueConfirm :: Maybe TL.Text
}
deriving Show

validateNewUser :: TL.Text -> TL.Text -> TL.Text -> NewUserErrors
validateNewUser username password confirm =
NewUserErrors
{ nueUsername =
if
| TL.length username < 2 || TL.length username > 20 ->
Just "Username must be at least 2 characters long and at most 20 characters long"
| not $ all (\c -> isDigit c || isLetter c || c `elem` ['-','_']) (TL.unpack username) ->
Just "Usernames can only contain letters, digits, underscores or dashes"
| otherwise ->
Nothing
, nuePassword =
if TL.length password >= 8 && TL.length password <= 18
then
Nothing
else
Just "Passwords must be at least 8 character long and at most 18 characters long"
, nueConfirm =
if password /= confirm
then
Just "Password and confirmation does not match."
else
Nothing
}

+ 184
- 0
src/Web/Bulletin/Actions/Posts.hs View File

@@ -0,0 +1,184 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Actions.Posts where


import Data.Int (Int64)
import Data.Maybe (isJust)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import qualified Data.Text.Lazy as TL
import qualified Lucid as H
import qualified Web.Scotty as S
import qualified Database.Persist.Sql as P
import qualified Data.Time.Clock as C
import qualified Network.HTTP.Types as HTTP

import qualified Web.Bulletin.Actions.Login as Login
import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Config
import Web.Bulletin.Html
import Web.Bulletin.Model
import Web.Bulletin.Session

-------------
-- Routing --
-------------


router :: Config -> SessionStore -> S.ScottyM ()
router cfg sessionStore = do
-- A page for a specific post
S.get "/post/:id" $ do
pid <- S.param "id"
displayPost cfg sessionStore pid

-- A page for creating a new post
S.get "/new/post" $ do
mses <- getSession sessionStore
case mses of
Just{} -> serveNewPostForm cfg sessionStore
Nothing ->
S.redirect "/login"

-- A request to submit a new page
S.post "/new/post" $ do
mses <- getSession sessionStore
case mses of
Just uid -> do
title <- S.param "title"
content <- S.param "content"
submitNewPostForm cfg title content uid
Nothing ->
S.redirect "/login"

-- A request to delete a specific post
S.post "/post/:id/delete" $ do
mses <- getSession sessionStore
case mses of
Just uid -> do
pid <- P.toSqlKey <$> S.param "id"
deletePost cfg pid uid
Nothing ->
S.redirect "/login"



-------------
-- Actions --
-------------

displayAllPosts :: Config -> SessionStore -> S.ActionM Html
displayAllPosts cfg sessionStore = do
mses <- getSession sessionStore
posts <- liftIO $ DB.getAllPosts cfg
pure $ do
when (isJust mses) $ do
H.p_ [ H.class_ "new-button" ] $ H.a_ [H.href_ "/new/post"] "New Post"
H.div_ [ H.class_ "posts" ] $
mapM_ (postHtml mses) $ reverse posts


displayPost :: Config -> SessionStore -> Int64 -> S.ActionM ()
displayPost cfg sessionStore pid = do
mpost <- liftIO $ DB.getPost cfg (P.toSqlKey pid)
mses <- getSession sessionStore
io <- Login.loginOrLogout cfg sessionStore
case mpost of
Just post ->
S.html $
H.renderText $
template
("Bulletin board - post " <> TL.pack (show pid))
io
(postHtml mses post)

Nothing -> do
S.status HTTP.notFound404
S.html $
H.renderText $
template
("Bulletin board - post " <> TL.pack (show pid) <> " not found.")
""
"404 Post not found."

serveNewPostForm :: Config -> SessionStore -> S.ActionM ()
serveNewPostForm cfg sessionStore = do
io <- Login.loginOrLogout cfg sessionStore
S.html $
H.renderText $
template
("Bulletin board - add new post")
io
newPostHtml

submitNewPostForm :: Config -> TL.Text -> TL.Text -> UserId -> S.ActionM ()
submitNewPostForm cfg title content uid = do
time <- liftIO C.getCurrentTime
pid <- liftIO $ DB.insertPost cfg
( Post
{ postDate = time
, postAuthorId = uid
, postTitle = title
, postContent = content
}
)
S.redirect ("/post/" <> showPostKey pid)


deletePost :: Config -> P.Key Post -> UserId -> S.ActionM ()
deletePost cfg pid uid = do
exists <- liftIO $ DB.deletePost cfg pid uid
if exists
then
S.redirect "/"
else do
S.status HTTP.notFound404
S.text "404 Not Found."


----------
-- Html --
----------

postHtml :: Maybe UserId -> Post' -> Html
postHtml muid (P.Entity pidKey post, P.Entity _ user) = do
H.div_ [ H.class_ "post" ] $ do
when (muid == Just (postAuthorId post)) $
H.form_
[ H.method_ "post"
, H.action_ (TL.toStrict $ "/post/" <> showPostKey pidKey <> "/delete")
, H.onsubmit_ "return confirm('Are you sure?')"
, H.class_ "delete-post"
]
( do
H.input_ [H.type_ "submit", H.value_ "X", H.class_ "deletebtn"]
)

H.div_ [ H.class_ "post-header" ] $ do
H.h2_ [ H.class_ "post-title" ] $
H.a_
[H.href_ (TL.toStrict $ "/post/" <> showPostKey pidKey)]
(H.toHtml $ postTitle post)

H.span_ $ do
H.p_ [ H.class_ "post-time" ] $ H.toHtml (TL.pack (show (postDate post)))
H.p_ [ H.class_ "post-author" ] $ "by " <> H.toHtml (userDisplayName user)

H.div_ [H.class_ "post-content"] $ do
fromMarkdown $ postContent post

newPostHtml :: Html
newPostHtml = do
H.form_
[ H.method_ "post"
, H.action_ "/new/post"
, H.class_ "new-post"
]
( do
H.p_ $ H.input_ [H.type_ "text", H.name_ "title", H.placeholder_ "Title...", H.required_ "true"]
H.p_ $ H.textarea_ [H.name_ "content", H.placeholder_ "Content...", H.required_ "true"] ""
H.p_ $ H.input_ [H.type_ "submit", H.value_ "Submit", H.class_ "submit-button"]
)



+ 85
- 0
src/Web/Bulletin/Config.hs View File

@@ -0,0 +1,85 @@
{-# language TypeApplications #-}

module Web.Bulletin.Config where

import qualified Data.Text as T
import qualified Control.Monad.Logger as Log
import qualified Database.Persist.Sqlite as PSqlite3
import System.Environment (lookupEnv)
import GHC.Conc (numCapabilities)

data Config
= Config
{ cfgEnv :: Environment
, cfgDbPool :: PSqlite3.ConnectionPool
, cfgPort :: Port
}

getConfig :: IO Config
getConfig = do
env <- getEnv
pool <- getPool env
port <- getPort env
pure $ Config env pool port

data Environment
= Development
| Production
| Testing
deriving (Eq, Read, Show, Enum, Bounded)

getEnv :: IO Environment
getEnv =
maybe Development readEnv <$> lookupEnv "SCOTTY_ENV"

readEnv :: String -> Environment
readEnv str =
case reads str of
[(env, "")] -> env
_ -> error $ unlines $
[ "Could not parse: '" <> str <> "' as a valid environment options."
, "Expecting one of the following:"
] <>
map (("- " <>) . show @Environment) [ minBound .. maxBound ]

getPool :: Environment -> IO PSqlite3.ConnectionPool
getPool env = do
cs <- getConnectionString env
let
poolSize = ceiling (fromIntegral numCapabilities / 2)
case env of
Development -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Production -> Log.runStderrLoggingT
(PSqlite3.createSqlitePool cs poolSize)
Testing -> Log.runNoLoggingT
(PSqlite3.createSqlitePool cs poolSize)

type Port = Int

getPort :: Environment -> IO Int
getPort env = do
m <- lookupEnv "PORT"
case m of
Just mp ->
case reads mp of
[(port, [])] -> pure port
_ -> error "Failed to read PORT environment option"
Nothing ->
pure $ case env of
Development -> 8080
Production -> 80
Testing -> 8000

type ConnectionString = T.Text

getConnectionString :: Environment -> IO ConnectionString
getConnectionString e =
case e of
-- Development ->
-- pure $ T.pack ":memory:"
-- Test ->
-- pure $ T.pack ":memory:"
-- Production ->
_ ->
maybe (error "could not find parameter 'CONN_STRING'") T.pack <$> lookupEnv "CONN_STRING"

+ 99
- 0
src/Web/Bulletin/DbAccess.hs View File

@@ -0,0 +1,99 @@
{-# LANGUAGE OverloadedStrings #-}

module Web.Bulletin.DbAccess where

import qualified Database.Persist as P
import qualified Database.Persist.Sql as P
import qualified Database.Persist.Sqlite as PSqlite3
import qualified Data.Password.Bcrypt as Bcrypt
import Data.Password.Bcrypt (PasswordHash(..), Password, Bcrypt, PasswordCheck(..))

import Web.Bulletin.Config
import Web.Bulletin.Model


-- General --

runDB :: Config -> P.SqlPersistT IO a -> IO a
runDB cfg dbop = P.runSqlPool dbop (cfgDbPool cfg)

dbMigrations :: Config -> IO ()
dbMigrations cfg = runDB cfg $ PSqlite3.runMigration migrateAll

-- Login --

insertUser :: Config -> Username -> PasswordHash Bcrypt -> IO (P.Key User)
insertUser cfg username passhash = do
uid <- runDB cfg $ P.insert (User username)
_ <- runDB cfg $ P.insert (Login uid username (Bcrypt.unPasswordHash passhash))
pure uid

checkUser :: Config -> Username -> Password -> IO (Maybe (P.Key User))
checkUser cfg user pass = do
list <- runDB cfg $ do
P.selectList [ LoginUsername P.==. user ] []
pure $ case list of
[P.Entity _ u] ->
case Bcrypt.checkPassword pass (PasswordHash $ loginPasswordHash u) of
PasswordCheckSuccess ->
Just $ loginUserId u
PasswordCheckFail ->
Nothing
_ -> Nothing

-- Users --

getAllUsers :: Config -> IO Logins
getAllUsers cfg = do
runDB cfg $ P.selectList [] []

getUser :: Config -> UserId -> IO (Maybe User)
getUser cfg uid = do
runDB cfg $ P.get uid

-- Posts --

getAllPosts :: Config -> IO Posts
getAllPosts cfg = do
runDB cfg $ PSqlite3.rawSql
"select ??, ?? from user inner join post on user.id = post.author_id;"
[]

getPost :: Config -> PostId -> IO (Maybe Post')
getPost cfg pid = do
runDB cfg $ do
mpost <- P.get pid
maybe
(pure Nothing)
( \post ->
fmap ((,) (P.Entity pid post) . P.Entity (postAuthorId post))
<$> P.get (postAuthorId post)
)
mpost

getAuthorPosts :: Config -> UserId -> IO Posts
getAuthorPosts cfg uid = do
runDB cfg $ do
muser <- P.get uid
maybe
(pure [])
( \author ->
fmap (flip (,) (P.Entity uid author))
<$> P.selectList [ PostAuthorId P.==. uid ] []
)
muser

insertPost :: Config -> Post -> IO (P.Key Post)
insertPost cfg = runDB cfg . P.insert

deletePost :: Config -> PostId -> UserId -> IO Bool
deletePost cfg pid uid = do
mpost <- getPost cfg pid
case mpost of
Just (P.Entity _ Post{postAuthorId=aid}, _)
| uid == aid -> do
runDB cfg (P.delete pid)
pure True
_ ->
pure False


+ 44
- 0
src/Web/Bulletin/Html.hs View File

@@ -0,0 +1,44 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Html where

import qualified Data.Text.Lazy as TL
import qualified Lucid as H

import qualified Cheapskate.Lucid as MD
import qualified Cheapskate as MD (markdown, Options(..))


----------
-- HTML --
----------

type Html = H.Html ()

template :: TL.Text -> Html -> Html -> Html
template title header content =
H.doctypehtml_ $ do
H.head_ $ do
H.meta_ [ H.charset_ "utf-8" ]
H.title_ (H.toHtml title)
H.link_ [ H.rel_ "stylesheet", H.type_ "text/css", H.href_ "/style.css" ]
H.body_ $ do
H.div_ [ H.class_ "head" ] $ do
H.h1_ [ H.class_ "logo" ] $
H.a_ [H.href_ "/"] "Bulletin Board"
header
H.div_ [ H.class_ "main" ] $ do
content

fromMarkdown :: TL.Text -> Html
fromMarkdown =
MD.renderDoc . MD.markdown markdownOptions . TL.toStrict . TL.filter (/='\r')

markdownOptions :: MD.Options
markdownOptions =
MD.Options
{ MD.sanitize = True
, MD.allowRawHtml = False
, MD.preserveHardBreaks = True
, MD.debug = False
}

+ 59
- 0
src/Web/Bulletin/Model.hs View File

@@ -0,0 +1,59 @@
{-# language TemplateHaskell #-}
{-# language QuasiQuotes #-}
{-# language TypeFamilies #-}
{-# language GADTs #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}

module Web.Bulletin.Model where

import qualified Data.Time.Clock as C
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Persist as P
import qualified Database.Persist.Sql as P
import Database.Persist.TH

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
User
displayName TL.Text
deriving Show

Login
userId UserId
username TL.Text
passwordHash T.Text
Username username
deriving Show

Post
title TL.Text
content TL.Text
date C.UTCTime
authorId UserId
deriving Show

Comment
content TL.Text
date C.UTCTime
postId PostId
authorId UserId
deriving Show
|]

type Post' = (P.Entity Post, P.Entity User)
type Posts = [Post']
type Users = [P.Entity User]
type Logins = [P.Entity Login]
type Username = TL.Text
-- type Comments = [P.Entity Comment]


showPostKey :: P.Key Post -> TL.Text
showPostKey pk =
case head $ P.keyToValues pk of
P.PersistInt64 i -> TL.pack (show i)

+ 47
- 0
src/Web/Bulletin/Router.hs View File

@@ -0,0 +1,47 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Router where

import qualified Web.Scotty as S
import qualified Lucid as H

import Web.Bulletin.Config
import Web.Bulletin.Session
import Web.Bulletin.Style
import Web.Bulletin.Html

import qualified Web.Bulletin.Actions.Login as Login
import qualified Web.Bulletin.Actions.NewUser as NewUser
import qualified Web.Bulletin.Actions.Posts as Posts

-------------
-- Routing --
-------------

router :: Config -> SessionStore -> S.ScottyM ()
router cfg sessionStore = do
-- Our main page, which will display all of the bulletins
S.get "/" $ index cfg sessionStore

Posts.router cfg sessionStore

NewUser.router cfg sessionStore

Login.router cfg sessionStore

-- css styling
S.get "/style.css" $ do
S.setHeader "Content-Type" "text/css; charset=utf-8"
S.raw style


index :: Config -> SessionStore -> S.ActionM ()
index cfg sessionStore = do
posts <- Posts.displayAllPosts cfg sessionStore
io <- Login.loginOrLogout cfg sessionStore
S.html $
H.renderText $
template
("Bulletin board")
io
posts

+ 60
- 0
src/Web/Bulletin/Run.hs View File

@@ -0,0 +1,60 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Run where

import qualified Network.Wai as Wai
import qualified Network.Wai.Middleware.RequestLogger as WaiLog
import qualified Web.Scotty as S
import qualified Data.Text.Lazy as TL
import qualified Network.HTTP.Types as HTTP
import Control.Monad.IO.Class (liftIO)
import qualified Lucid as H

import qualified Web.Bulletin.DbAccess as DB
import Web.Bulletin.Config
import Web.Bulletin.Html
import Web.Bulletin.Router
import Web.Bulletin.Session

------------
-- Runner --
------------

run :: IO ()
run = do
cfg <- getConfig
liftIO $ DB.dbMigrations cfg
ses <- initSessionStore
S.scotty (cfgPort cfg) (myApp cfg ses)

myApp :: Config -> SessionStore -> S.ScottyM ()
myApp cfg ses = do
S.middleware (loggingM (cfgEnv cfg))
S.defaultHandler (defaultH (cfgEnv cfg))
router cfg ses

-----------------
-- Middlewares --
-----------------

loggingM :: Environment -> Wai.Middleware
loggingM e = case e of
Development -> WaiLog.logStdoutDev
Production -> WaiLog.logStdout
Testing -> id

defaultH :: Environment -> TL.Text -> S.ActionM ()
defaultH env err = do
S.status HTTP.internalServerError500
S.html $
H.renderText $
template
("Internal Server Error 500")
""
$ case env of
Development ->
H.toHtml err
Testing ->
H.toHtml err
Production ->
""

+ 138
- 0
src/Web/Bulletin/Session.hs View File

@@ -0,0 +1,138 @@
{-# language OverloadedStrings #-}

module Web.Bulletin.Session
( SessionStore
, initSessionStore
, newSession
, getSession
, deleteSession
)
where

import Control.Monad (join)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Time.Clock as Time

import Control.Monad.IO.Class (liftIO)
import qualified Control.Concurrent.STM as STM
import qualified Web.Scotty as S
import qualified Web.ClientSession as CS
import qualified Web.Cookie as C
import qualified Data.Binary.Builder as Binary

import Web.Bulletin.Model


--------------
-- Sessions --
--------------

newSession :: SessionStore -> UserId -> S.ActionM ()
newSession sessionStore uid = do
let
suid = T.encodeUtf8 $ T.pack $ show uid
cookie <- liftIO $ BSL.fromStrict <$> encryptCookieIO (sessionKey sessionStore) (mkCookie "logged_in" suid)
S.setHeader "Set-Cookie" (TL.decodeUtf8 cookie)
liftIO $ insertUserId uid sessionStore

getSession :: SessionStore -> S.ActionM (Maybe UserId)
getSession sessionStore = do
bytes <- fmap TL.encodeUtf8 <$> S.header "Cookie"
cookie <- fmap join . liftIO $ traverse (decryptCookieIO (sessionKey sessionStore)) bytes
case cookie of
Just ("logged_in", suid) -> do
sessions <- liftIO $ getSessionStore sessionStore
let
uid = read (T.unpack $ T.decodeUtf8 suid)
if uid `Set.member` sessions
then pure $ Just uid
else pure $ Nothing
_ ->
pure Nothing

deleteSession :: SessionStore -> UserId -> S.ActionM ()
deleteSession sessionStoreVar uid =
liftIO $ deleteUserId uid sessionStoreVar

-------------------
-- Session Store --
-------------------

initSessionStore :: IO SessionStore
initSessionStore = do
SessionStore
<$> STM.newTVarIO mempty
<*> CS.getDefaultKey

data SessionStore
= SessionStore
{ sessionTVar :: STM.TVar (Set.Set UserId)
, sessionKey :: CS.Key
}

insertUserId :: UserId -> SessionStore -> IO ()
insertUserId uid sessionStore = do
STM.atomically $ STM.modifyTVar' (sessionTVar sessionStore) (Set.insert uid)

deleteUserId :: UserId -> SessionStore -> IO ()
deleteUserId uid sessionStore = do
STM.atomically $ STM.modifyTVar' (sessionTVar sessionStore) (Set.delete uid)

getSessionStore :: SessionStore -> IO (Set.Set UserId)
getSessionStore = STM.readTVarIO . sessionTVar


----------------------------
-- Cookie Encrypt/Decrypt --
----------------------------

encryptCookieIO :: CS.Key -> C.SetCookie -> IO BS.ByteString
encryptCookieIO key cookie = do
v <- CS.encryptIO key $ C.setCookieValue cookie
pure . BSL.toStrict . Binary.toLazyByteString . C.renderSetCookie $ cookie
{ C.setCookieValue = v
}

decryptCookieIO :: CS.Key -> BSL.ByteString -> IO (Maybe (BS.ByteString, BS.ByteString))
decryptCookieIO key bs =
let
(name, value) = getCookieKV (BSL.toStrict bs)
in
case CS.decrypt key value of
Nothing ->
pure Nothing
Just value' ->
pure $ Just (name, value')

-------------
-- Cookies --
-------------

mkCookie :: BS.ByteString -> BS.ByteString -> C.SetCookie
mkCookie name value =
C.defaultSetCookie
{ C.setCookieName = name
, C.setCookieValue = value
, C.setCookieSecure = True
, C.setCookieHttpOnly = True
, C.setCookieSameSite = Just C.sameSiteStrict
, C.setCookieMaxAge = Just sixtyDays
}

-- utils --

sixtyDays :: Time.DiffTime
sixtyDays = Time.secondsToDiffTime (60 * 60 * 24 * 60)

getCookieKV :: BS.ByteString -> (BS.ByteString, BS.ByteString)
getCookieKV bytes =
let
cookie = C.parseSetCookie bytes
in
(C.setCookieName cookie, C.setCookieValue cookie)


+ 227
- 0
src/Web/Bulletin/Style.hs View File

@@ -0,0 +1,227 @@
{-# language QuasiQuotes #-}

-- | CSS style as a raw string

module Web.Bulletin.Style where

import Text.RawString.QQ
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.ByteString.Lazy as BSL


-- CSS --

style :: BSL.ByteString
style = TL.encodeUtf8 $ TL.pack [r|
html {
min-width: 500px;
}

body {
margin-top: 40px;
color: #333;
// color: #CCC;
// background-color: #333;
font-family: monospace;
font-size: 1.3em;
}

.main {
max-width: 900px;
min-width: 500px;
margin: auto;
box-sizing: border-box;
margin: auto;
}

a {
color: pink;
}

a:hover {
color: #fb7a91;
}

.head {
max-width: 900px;
min-width: 500px;
margin: auto;
box-sizing: border-box;
margin: auto;
}

ul {
padding-left: 0;
margin: 0;
}

li {
padding-bottom: 0.7em;
list-style-position:inside;
overflow: hidden;
text-overflow: "...";
}

.error {
color: #f44336;
font-size: 0.7em;
}

input[type=text], input[type=url] {
min-width: 300px;
}
input[type=password], input[type=url] {
min-width: 300px;
}
input[type=submit] {
}
input {
font-family: monospace;
}

input::placeholder, textarea::placeholder {
}

textarea {
overflow-y: scroll;
min-height: 200px;
width: 60%;
box-sizing: border-box;
}

.header-h1 {
display: inline-block;
margin: 20px 20px;
margin-right: 0;
}
.header- {
display: inline-block;
}
.header {
color: #86c6ff;
text-decoration: none;
}
.header:hover {
color: #4aaaff;
}

h4 {
color: #fdfd95;
margin: 0;
}

.delete-post {
float: right;
clear: both;
}

.deletebtn {
background-color: #f44336;
border: none;
color: white;
padding-left: 0.3em;
padding-right: 0.3em;
padding-top: 0.1em;
padding-bottom: 0.1em;
text-align: center;
font-weight: bold;
text-decoration: none;
display: inline-block;
font-family: monospace;
font-size: 1.1em;
width: 1.5em !important;
height: 1.5em;
}
.deletebtn:hover {
background-color: #b00;
}

.date {
font-size: 0.7em;
margin-right: 0.5em;
}

.tag {
color: #c0f3ff;
text-decoration: none;
font-size: 0.7em;
}

.tag:hover {
color: #73dff9;
text-decoration: underline;
font-size: 0.7em;
}

.comma {
margin-right: 0.5em;
font-size: 0.7em;
}

.tags {
max-width: 98%;
margin: 20px auto;
text-align: center;
}

h2 {
margin-top: 0px;
}

.posts {
min-width: 400px;
margin: 20px auto;
display: flex;
flex-wrap: wrap;
justify-content: center;
}

.post {
display: inline-block;
margin-right: 0.5em;
margin-bottom: 0.5em;
padding: 0.8em;
border: #666 1px dashed;
flex-grow: 1;
// max-width: 45%;
min-width: 20em;
}

.logo {
display: inline-block;
}
.welcome {
display: inline-block;
float: right;
clear: both;
font-size: 0.9em;
margin-top: 37px;
margin-bottom: 37px;
}
.welcome input {
font-size: 0.9em;
}

.logout-form {
display: inline-block;
}
.logout {
display: inline-block;
width: initial !important;
background-color: transparent;
text-decoration: underline;
border: none;
cursor: pointer;
color: pink;
}

.logout:hover {
color: #fb7a91;
}
.logout:focus {
outline: none;
color: #fb7a91;
}

|]

+ 9
- 0
src/Web/Bulletin/Validation.hs View File

@@ -0,0 +1,9 @@

module Web.Bulletin.Validation where

applyMaybe :: Applicative m => Maybe a -> (a -> m ()) -> m ()
applyMaybe m f =
case m of
Nothing -> pure ()
Just x -> f x


+ 1
- 1
stack.yaml View File

@@ -1,5 +1,5 @@
resolver:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml

# uncomment for static executables
# docker:


+ 4
- 4
stack.yaml.lock View File

@@ -6,8 +6,8 @@
packages: []
snapshots:
- completed:
size: 532380
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
sha256: d6b004b095fe2a0b8b14fbc30014ee97e58843b9c9362ddb9244273dda62649e
size: 533252
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml
sha256: cdbc5db9c1afe80a5998247939027a0c7db92fa0f20b5cd01596ec3da628b622
original:
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/16.yaml
url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/26.yaml

Loading…
Cancel
Save