Browse Source

Better docs

main
Gil Mizrahi 11 months ago
parent
commit
e41d1e2f97
9 changed files with 219 additions and 70 deletions
  1. +46
    -14
      app/Main.hs
  2. +0
    -3
      my-scotty-users.cabal
  3. +33
    -4
      readme.md
  4. +35
    -7
      src/Web/Scotty/Sqlite/Users.hs
  5. +37
    -14
      src/Web/Scotty/Sqlite/Users/DbAccess.hs
  6. +7
    -0
      src/Web/Scotty/Sqlite/Users/Login.hs
  7. +18
    -0
      src/Web/Scotty/Sqlite/Users/Model.hs
  8. +6
    -1
      src/Web/Scotty/Sqlite/Users/NewUser.hs
  9. +37
    -27
      src/Web/Scotty/Sqlite/Users/Session.hs

+ 46
- 14
app/Main.hs View File

@@ -1,3 +1,22 @@
{- | Example app.

Demonstrates user registration, authentication and session functionality.

The app needs to do the following things:

1. At the beginning of the program:
- Create an sqlite database connection pool
- Initialize the sqlite database tables with @dbMigrations@ using the connection pool
- Initialize the session store with @initSessionStore@ and get back a SessionStore

2. Call @router@ from your routing so it will take care of the user registration, login and logout pages

3. Use @loginOrLogout@ to welcome the user and provide links for the registration, login or logout pages

4. Use @withLogin@ for @ActionM@s that require a logged-in user.

-}

{-# language OverloadedStrings #-}

module Main where
@@ -13,25 +32,38 @@ import qualified Web.Scotty.Sqlite.Users as Users

main :: IO ()
main = do
pool <- do
pool <- do -- (1.1)
Log.runStderrLoggingT $ PSqlite3.createSqlitePool "file:/tmp/my-scotty-users.db" 1
liftIO $ Users.dbMigrations pool
ses <- Users.initSessionStore
liftIO $ Users.dbMigrations pool -- (1.2)
ses <- Users.initSessionStore -- (1.3)
S.scotty 8080 (myApp pool ses)

myApp :: Users.Pool -> Users.SessionStore -> S.ScottyM ()
myApp pool ses = do
S.get "/" $ index pool ses
Users.router pool ses template

index :: Users.Pool -> Users.SessionStore -> S.ActionM ()
index pool sessionStore = do
io <- Users.loginOrLogout pool sessionStore
S.html $
H.renderText $
template
("Bulletin board")
io
Users.router pool ses template -- (2)

S.get "/" $ do
io <- Users.loginOrLogout pool ses -- (3)
S.html $
H.renderText $
template
("Bulletin board")
( do
io
H.p_ $ H.a_ [ H.href_ "/users" ] "Users zone"
)

S.get "/users" $ -- (4)
Users.withLogin pool ses $ \me -> do
users <- liftIO $ Users.getAllUsers pool
S.html $
H.renderText $
template "User zone" $ do
H.p_ $ H.toHtml $ "You are: " <> Users.loginDisplayName (Users.getLoginDesc me)
H.p_ $ "And these are everyone:"
H.ul_ $
mapM_ (H.li_ . H.toHtml . Users.loginDisplayName . Users.getLoginDesc) users

type Html = H.Html ()



+ 0
- 3
my-scotty-users.cabal View File

@@ -34,8 +34,6 @@ library
-- web
, lucid
, scotty
, wai
, wai-extra
, http-types
, persistent
, persistent-template
@@ -61,5 +59,4 @@ executable my-scotty-users-example
-- web
, lucid
, scotty
, wai
, persistent-sqlite

+ 33
- 4
readme.md View File

@@ -2,11 +2,40 @@

User registration, authentication, sessions and boilerplate.

check the [example](/app/Main.hs).
It uses:

## Build with
- scotty for routing and actions
- lucid for html
- persistent and sqlite for the users database
- stm for the in memory session store
- cookie and clientsession for the cookies
- password (bcrypt) for storing password hashes

```sh
stack build
## How to use

Check the [example](/app/Main.hs).

This library provides user registration, authentication and session functionality.

To do this do the following things:

1. At the beginning of the program:
1. Create an sqlite database connection pool. (Check out the example)
2. Initialize the sqlite database tables with `dbMigrations` using the connection pool
3. Initialize the session store with `initSessionStore` and get back a SessionStore

2. Call `router` from your routing so it will take care of the user registration, login and logout pages

3. Use `loginOrLogout` to welcome the user and provide links for the registration, login or logout pages

4. Use `withLogin` for `ActionM`s that require a logged-in user.

### Run the example

run:

```hs
stack run
```

and go to [http://localhost:8080](http://localhost:8080)

+ 35
- 7
src/Web/Scotty/Sqlite/Users.hs View File

@@ -1,21 +1,45 @@
{- | My scotty users boilerplate.

This library provides user registration, authentication and session functionality.

To do this do the following things:

1. At the beginning of the program:
- Create an sqlite database connection pool
- Initialize the sqlite database tables with @dbMigrations@ using the connection pool
- Initialize the session store with @initSessionStore@ and get back a SessionStore

2. Call @router@ from your routing so it will take care of the user registration, login and logout pages

3. Use @loginOrLogout@ to welcome the user and provide links for the registration, login or logout pages

4. Use @withLogin@ for @ActionM@s that require a logged-in user.

-}

{-# language OverloadedStrings #-}
{-# language MultiWayIf #-}

module Web.Scotty.Sqlite.Users
( router
, initSessionStore
, dbMigrations
, Login.loginOrLogout
, Pool
, HtmlTemplate
, SessionStore
, withLogin
, getSession
, HtmlTemplate
, Login.loginOrLogout
, getAllUsers
, getLogin
, getLoginByUsername
, module Web.Scotty.Sqlite.Users.Model
)
where

import qualified Web.Scotty as S
import Control.Monad.IO.Class (liftIO)
import Control.Monad (join)
import qualified Database.Persist.Sql as P

import Web.Scotty.Sqlite.Users.Model
import Web.Scotty.Sqlite.Users.DbAccess
@@ -29,12 +53,16 @@ import qualified Web.Scotty.Sqlite.Users.NewUser as NewUser
-- Routing --
-------------

-- | A scotty router for login, logout and user registration
router :: Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
Login.router pool sessionStore template
NewUser.router pool sessionStore template


withLogin :: SessionStore -> (LoginId -> S.ActionM ()) -> S.ActionM ()
withLogin sessionStore exec =
maybe (S.redirect "/login") exec =<< getSession sessionStore
-- | Call with a function that expects a logged-in user.
-- Will redirect to the login page if the user is not logged-in.
withLogin :: Pool -> SessionStore -> (P.Entity Login -> S.ActionM ()) -> S.ActionM ()
withLogin pool sessionStore exec =
getSession sessionStore
>>= liftIO . fmap join . traverse (\uid -> fmap (P.Entity uid) <$> getLogin pool uid)
>>= maybe (S.redirect "/login") exec

+ 37
- 14
src/Web/Scotty/Sqlite/Users/DbAccess.hs View File

@@ -1,3 +1,10 @@
{- | Database Access.

The only relevant function here is @dbMigrations@ that should
be run in the beginning of the program.

-}

{-# LANGUAGE OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.DbAccess where
@@ -12,22 +19,48 @@ import Data.Password.Bcrypt (PasswordHash(..), Password, Bcrypt, PasswordCheck(.
import Web.Scotty.Sqlite.Users.Model


-- ** General

type Pool = PSqlite3.ConnectionPool

-- | Run this at the start of the program to initialize the tables.
dbMigrations :: Pool -> IO ()
dbMigrations pool = runDB pool $ PSqlite3.runMigration migrateAll

-- | Use to run a db action in IO.
runDB :: Pool -> P.SqlPersistT IO a -> IO a
runDB pool dbop = P.runSqlPool dbop pool

dbMigrations :: Pool -> IO ()
dbMigrations pool = runDB pool $ PSqlite3.runMigration migrateAll
-----------------
-- ** Users

-- | Get all users.
getAllUsers :: Pool -> IO Logins
getAllUsers pool = do
runDB pool $ P.selectList [] []

-- | Get a user by their Id.
getLogin :: Pool -> LoginId -> IO (Maybe Login)
getLogin pool = runDB pool . P.get

-- | Get a user by their username.
getLoginByUsername :: Pool -> TL.Text -> IO (Maybe (P.Entity Login))
getLoginByUsername pool username = do
runDB pool $ P.getBy (Username username)

-----------------
{- ** Login

Avoid calling these functions, they are already handled automatically via the routing actions.

-}

-- | Insert a new user into the database.
insertUser :: Pool -> Username -> PasswordHash Bcrypt -> Displayname -> IO (P.Key Login)
insertUser pool username passhash displayname = do
runDB pool $ P.insert (Login username (Bcrypt.unPasswordHash passhash) displayname)

-- | Check a user credentials against the database.
checkUser :: Pool -> Username -> Password -> IO (Maybe (P.Key Login))
checkUser pool user pass = do
list <- runDB pool $ do
@@ -41,16 +74,3 @@ checkUser pool user pass = do
Nothing
_ -> Nothing


getAllUsers :: Pool -> IO Logins
getAllUsers pool = do
runDB pool $ P.selectList [] []

getLogin :: Pool -> LoginId -> IO (Maybe Login)
getLogin pool = runDB pool . P.get

getLoginByUsername :: Pool -> TL.Text -> IO (Maybe (P.Entity Login))
getLoginByUsername pool username = do
runDB pool $ P.getBy (Username username)



+ 7
- 0
src/Web/Scotty/Sqlite/Users/Login.hs View File

@@ -1,3 +1,9 @@
{- | Login/Logout users

Internal API for the library to handle the http, forms and actions.

-}

{-# language OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.Login where
@@ -51,6 +57,7 @@ router pool sessionStore template = do
-- Login Actions --
-------------------

-- | Returns html to welcome the user, providing links to register/login or logout.
loginOrLogout :: DB.Pool -> SessionStore -> S.ActionM Html
loginOrLogout pool sessionStore = do
muser <- liftIO . fmap join . traverse (DB.getLogin pool) =<< getSession sessionStore


+ 18
- 0
src/Web/Scotty/Sqlite/Users/Model.hs View File

@@ -1,3 +1,7 @@
{- | Users model

-}

{-# language TemplateHaskell #-}
{-# language QuasiQuotes #-}
{-# language TypeFamilies #-}
@@ -11,6 +15,7 @@

module Web.Scotty.Sqlite.Users.Model where

import Data.Int (Int64)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Persist as P
@@ -30,3 +35,16 @@ Login
type Logins = [P.Entity Login]
type Username = TL.Text
type Displayname = TL.Text

-- | Extract LoginId from a LoginIn/Login pair.
getLoginId :: P.Entity Login -> LoginId
getLoginId = P.entityKey

-- | Extract Login from a LoginIn/Login pair.
getLoginDesc :: P.Entity Login -> Login
getLoginDesc = P.entityVal

-- | Convert an integer id to a LoginId.
-- Useful for routing.
paramToLoginId :: Int64 -> LoginId
paramToLoginId = P.toSqlKey

+ 6
- 1
src/Web/Scotty/Sqlite/Users/NewUser.hs View File

@@ -1,3 +1,9 @@
{- | Create new user actions.

Internal API for the library to handle the http, forms and actions.

-}

{-# language OverloadedStrings #-}
{-# language MultiWayIf #-}

@@ -23,14 +29,6 @@ import Web.Scotty.Sqlite.Users.Common

router :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do

-- A page for creating a new post
S.get "/register" $ do
mses <- getSession sessionStore


+ 37
- 27
src/Web/Scotty/Sqlite/Users/Session.hs View File

@@ -1,3 +1,10 @@
{- | Session management.

The one useful function here is @initSessionStore@
which is already exported from @Web.Scotty.Sqlite.Users@.

-}

{-# language OverloadedStrings #-}

module Web.Scotty.Sqlite.Users.Session
@@ -27,6 +34,35 @@ import qualified Data.Binary.Builder as Binary

import Web.Scotty.Sqlite.Users.Model

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

-- | Run this at the beginning of the program
-- To create a session store.
-- The session store is only alive for the duration of the program.
initSessionStore :: IO SessionStore
initSessionStore = do
SessionStore
<$> STM.newTVarIO mempty
<*> CS.getDefaultKey

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

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

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

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

--------------
-- Sessions --
@@ -40,6 +76,7 @@ newSession sessionStore uid = do
S.setHeader "Set-Cookie" (TL.decodeUtf8 cookie)
liftIO $ insertLoginId uid sessionStore

-- | Try to get the currently logged-in user
getSession :: SessionStore -> S.ActionM (Maybe LoginId)
getSession sessionStore = do
bytes <- fmap TL.encodeUtf8 <$> S.header "Cookie"
@@ -59,34 +96,6 @@ deleteSession :: SessionStore -> LoginId -> S.ActionM ()
deleteSession sessionStoreVar uid =
liftIO $ deleteLoginId uid sessionStoreVar

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

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

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

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

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

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


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


Loading…
Cancel
Save