Browse Source

Group all state in a new type StateInfo, add operation Mode

thus enabling insecure cookies on development mode
main
Gil Mizrahi 9 months ago
parent
commit
2d4be144e5
8 changed files with 143 additions and 104 deletions
  1. +8
    -7
      app/Main.hs
  2. +0
    -1
      my-scotty-users.cabal
  3. +13
    -11
      src/Web/Scotty/Sqlite/Users.hs
  4. +26
    -0
      src/Web/Scotty/Sqlite/Users/Common.hs
  5. +18
    -19
      src/Web/Scotty/Sqlite/Users/DbAccess.hs
  6. +22
    -22
      src/Web/Scotty/Sqlite/Users/Login.hs
  7. +19
    -19
      src/Web/Scotty/Sqlite/Users/NewUser.hs
  8. +37
    -25
      src/Web/Scotty/Sqlite/Users/Session.hs

+ 8
- 7
app/Main.hs View File

@@ -36,14 +36,15 @@ main = do
Log.runStderrLoggingT $ PSqlite3.createSqlitePool "file:/tmp/my-scotty-users.db" 1
liftIO $ Users.dbMigrations pool -- (1.2)
ses <- Users.initSessionStore -- (1.3)
S.scotty 8080 (myApp pool ses)
let sinfo = Users.StateInfo pool ses Users.Development -- Use Production for secure only cookies
S.scotty 8080 (myApp sinfo)

myApp :: Users.Pool -> Users.SessionStore -> S.ScottyM ()
myApp pool ses = do
Users.router pool ses template -- (2)
myApp :: Users.StateInfo -> S.ScottyM ()
myApp sinfo = do
Users.router sinfo template -- (2)

S.get "/" $ do
io <- Users.loginOrLogout pool ses -- (3)
io <- Users.loginOrLogout sinfo -- (3)
S.html $
H.renderText $
template
@@ -54,8 +55,8 @@ myApp pool ses = do
)

S.get "/users" $ -- (4)
Users.withLogin pool ses $ \me -> do
users <- liftIO $ Users.getAllUsers pool
Users.withLogin sinfo $ \me -> do
users <- liftIO $ Users.getAllUsers sinfo
S.html $
H.renderText $
template "User zone" $ do


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

@@ -23,7 +23,6 @@ library
Web.Scotty.Sqlite.Users.NewUser
Web.Scotty.Sqlite.Users.Session


ghc-options: -Wall -fno-warn-type-defaults
default-language: Haskell2010
build-depends: base >= 4.7 && < 5


+ 13
- 11
src/Web/Scotty/Sqlite/Users.hs View File

@@ -23,8 +23,10 @@ module Web.Scotty.Sqlite.Users
( router
, initSessionStore
, dbMigrations
, StateInfo(..)
, Pool
, SessionStore
, Mode(..)
, withLogin
, withMaybeLogin
, getSession
@@ -55,20 +57,20 @@ import qualified Web.Scotty.Sqlite.Users.NewUser as NewUser
-------------

-- | 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
router :: StateInfo -> HtmlTemplate -> S.ScottyM ()
router sinfo template = do
Login.router sinfo template
NewUser.router sinfo template

-- | 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 a) -> S.ActionM a
withLogin pool sessionStore exec =
withMaybeLogin pool sessionStore (maybe (S.redirect "/login") exec)
withLogin :: StateInfo -> (P.Entity Login -> S.ActionM a) -> S.ActionM a
withLogin sinfo exec =
withMaybeLogin sinfo (maybe (S.redirect "/login") exec)

-- | Call with a function that might need a logged-in user.
withMaybeLogin :: Pool -> SessionStore -> (Maybe (P.Entity Login) -> S.ActionM a) -> S.ActionM a
withMaybeLogin pool sessionStore exec = do
getSession sessionStore
>>= liftIO . fmap join . traverse (\uid -> fmap (P.Entity uid) <$> getLogin pool uid)
withMaybeLogin :: StateInfo -> (Maybe (P.Entity Login) -> S.ActionM a) -> S.ActionM a
withMaybeLogin sinfo exec = do
getSession sinfo
>>= liftIO . fmap join . traverse (\uid -> fmap (P.Entity uid) <$> getLogin sinfo uid)
>>= exec

+ 26
- 0
src/Web/Scotty/Sqlite/Users/Common.hs View File

@@ -2,6 +2,32 @@ module Web.Scotty.Sqlite.Users.Common where

import qualified Data.Text.Lazy as TL
import qualified Lucid as H
import qualified Control.Concurrent.STM as STM
import qualified Web.ClientSession as CS
import qualified Database.Persist.Sqlite as PSqlite3
import qualified Data.Set as Set

import Web.Scotty.Sqlite.Users.Model

data StateInfo
= StateInfo
{ siPool :: Pool
, siSessions :: SessionStore
, siMode :: Mode
}

data Mode
= Development
| Production
deriving (Show, Eq)

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

type Pool = PSqlite3.ConnectionPool

type Html = H.Html ()
type HtmlTemplate = TL.Text -> Html -> Html


+ 18
- 19
src/Web/Scotty/Sqlite/Users/DbAccess.hs View File

@@ -17,36 +17,35 @@ import qualified Data.Password.Bcrypt as Bcrypt
import Data.Password.Bcrypt (PasswordHash(..), Password, Bcrypt, PasswordCheck(..))

import Web.Scotty.Sqlite.Users.Model
import Web.Scotty.Sqlite.Users.Common


-- ** 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
dbMigrations pool = P.runSqlPool (PSqlite3.runMigration migrateAll) pool

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

-----------------
-- ** Users

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

-- | Get a user by their Id.
getLogin :: Pool -> LoginId -> IO (Maybe Login)
getLogin pool = runDB pool . P.get
getLogin :: StateInfo -> LoginId -> IO (Maybe Login)
getLogin sinfo = runDB sinfo . 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)
getLoginByUsername :: StateInfo -> TL.Text -> IO (Maybe (P.Entity Login))
getLoginByUsername sinfo username = do
runDB sinfo $ P.getBy (Username username)

-----------------
{- ** Login
@@ -56,14 +55,14 @@ Avoid calling these functions, they are already handled automatically via the ro
-}

-- | 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)
insertUser :: StateInfo -> Username -> PasswordHash Bcrypt -> Displayname -> IO (P.Key Login)
insertUser sinfo username passhash displayname = do
runDB sinfo $ 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
checkUser :: StateInfo -> Username -> Password -> IO (Maybe (P.Key Login))
checkUser sinfo user pass = do
list <- runDB sinfo $ do
P.selectList [ LoginUsername P.==. user ] []
pure $ case list of
[P.Entity uid u] ->


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

@@ -25,26 +25,26 @@ import Web.Scotty.Sqlite.Users.Common
-- Login Route --
-----------------

router :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
router :: StateInfo -> HtmlTemplate -> S.ScottyM ()
router sinfo template = do
-- A Log in page
S.get "/login" $
loginGetAction sessionStore template
loginGetAction sinfo template

-- A request to log in
S.post "/login" $
loginPostAction pool sessionStore template
loginPostAction sinfo template

-- Logout
S.post "/logout" $
logoutPostAction sessionStore
logoutPostAction sinfo

------

-- | A Log-in page
loginGetAction :: SessionStore -> HtmlTemplate -> S.ActionM ()
loginGetAction sessionStore template = do
mses <- getSession sessionStore
loginGetAction :: StateInfo -> HtmlTemplate -> S.ActionM ()
loginGetAction sinfo template = do
mses <- getSession sinfo
case mses of
Nothing ->
serveLoginForm template Nothing
@@ -52,21 +52,21 @@ loginGetAction sessionStore template = do
S.redirect "/"

-- | A request to log-in
loginPostAction :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ActionM ()
loginPostAction pool sessionStore template = do
mses <- getSession sessionStore
loginPostAction :: StateInfo -> HtmlTemplate -> S.ActionM ()
loginPostAction sinfo template = do
mses <- getSession sinfo
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
submitLoginForm pool sessionStore template username password
submitLoginForm sinfo template username password
_ ->
S.redirect "/"

-- | Logout request
logoutPostAction :: SessionStore -> S.ActionM ()
logoutPostAction sessionStore = do
mapM_ (deleteSession sessionStore) =<< getSession sessionStore
logoutPostAction :: StateInfo -> S.ActionM ()
logoutPostAction sinfo = do
mapM_ (deleteSession sinfo) =<< getSession sinfo
S.redirect "/"

-------------------
@@ -74,9 +74,9 @@ logoutPostAction sessionStore = do
-------------------

-- | 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
loginOrLogout :: StateInfo -> S.ActionM Html
loginOrLogout sinfo = do
muser <- liftIO . fmap join . traverse (DB.getLogin sinfo) =<< getSession sinfo
pure $
H.div_ [ H.class_ "welcome" ] $
case muser of
@@ -102,14 +102,14 @@ serveLoginForm template err = do
("Scotty.Sqlite board - register a new account")
(loginHtml err)

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

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


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

@@ -28,15 +28,15 @@ import Web.Scotty.Sqlite.Users.Common
-- Routing --
-------------

router :: DB.Pool -> SessionStore -> HtmlTemplate -> S.ScottyM ()
router pool sessionStore template = do
router :: StateInfo -> HtmlTemplate -> S.ScottyM ()
router sinfo template = do
-- A page for creating a new post
S.get "/register" $ do
runFinalAction =<< registerGetAction sessionStore template "/register"
runFinalAction =<< registerGetAction sinfo template "/register"

-- A request to create a new user
S.post "/register" $ do
runFinalAction =<< registerPostAction pool sessionStore template "/register"
runFinalAction =<< registerPostAction sinfo template "/register"

------

@@ -55,9 +55,9 @@ data Result' a
| RegistrationSuccess a

-- | A page for creating a new post
registerGetAction :: SessionStore -> HtmlTemplate -> T.Text -> S.ActionM Result
registerGetAction sessionStore template actionPath = do
mses <- getSession sessionStore
registerGetAction :: StateInfo -> HtmlTemplate -> T.Text -> S.ActionM Result
registerGetAction sinfo template actionPath = do
mses <- getSession sinfo
case mses of
Nothing ->
serveNewUserForm template actionPath noNewUserErrors "" "" ""
@@ -65,15 +65,15 @@ registerGetAction sessionStore template actionPath = do
pure $ AlreadyLoggedIn $ S.redirect "/"

-- | A request to create a new user
registerPostAction :: DB.Pool -> SessionStore -> HtmlTemplate -> T.Text -> S.ActionM Result
registerPostAction pool sessionStore template actionPath = do
mses <- getSession sessionStore
registerPostAction :: StateInfo -> HtmlTemplate -> T.Text -> S.ActionM Result
registerPostAction sinfo template actionPath = do
mses <- getSession sinfo
case mses of
Nothing -> do
username <- S.param "username"
password <- S.param "password"
confirm <- S.param "confirm"
submitNewUserForm pool sessionStore template actionPath username password confirm
submitNewUserForm sinfo template actionPath username password confirm
_ ->
pure $ AlreadyLoggedIn $ S.redirect "/"

@@ -89,16 +89,16 @@ serveNewUserForm template actionPath err username pass confirm = do
("Scotty.Sqlite board - register a new account")
(newUserHtml err actionPath username pass confirm)

submitNewUserForm :: DB.Pool -> SessionStore -> HtmlTemplate -> T.Text -> TL.Text -> TL.Text -> TL.Text -> S.ActionM Result
submitNewUserForm pool ses template actionPath username pass confirm = do
errs <- liftIO $ validateNewUser pool username pass confirm
submitNewUserForm :: StateInfo -> HtmlTemplate -> T.Text -> TL.Text -> TL.Text -> TL.Text -> S.ActionM Result
submitNewUserForm sinfo template actionPath username pass confirm = do
errs <- liftIO $ validateNewUser sinfo username pass confirm
if hasNewUserErrors errs
then
serveNewUserForm template actionPath errs username pass confirm
else do
hash <- liftIO $ Bcrypt.hashPassword $ Bcrypt.mkPassword (TL.toStrict pass)
ukey <- liftIO $ DB.insertUser pool username hash username
newSession ses ukey
ukey <- liftIO $ DB.insertUser sinfo username hash username
newSession sinfo ukey
pure $ RegistrationSuccess $ S.redirect "/"

----------
@@ -190,9 +190,9 @@ hasNewUserErrors :: NewUserErrors -> Bool
hasNewUserErrors errs =
errs /= noNewUserErrors

validateNewUser :: DB.Pool -> TL.Text -> TL.Text -> TL.Text -> IO NewUserErrors
validateNewUser pool username password confirm = do
login <- DB.getLoginByUsername pool username
validateNewUser :: StateInfo -> TL.Text -> TL.Text -> TL.Text -> IO NewUserErrors
validateNewUser sinfo username password confirm = do
login <- DB.getLoginByUsername sinfo username
pure $ NewUserErrors
{ nueUsername =
if


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

@@ -33,6 +33,7 @@ import qualified Web.Cookie as C
import qualified Data.Binary.Builder as Binary

import Web.Scotty.Sqlite.Users.Model
import Web.Scotty.Sqlite.Users.Common

-------------------
-- Session Store --
@@ -47,43 +48,46 @@ initSessionStore = do
<$> STM.newTVarIO mempty
<*> CS.getDefaultKey

data SessionStore
= SessionStore
{ sessionTVar :: STM.TVar (Set.Set LoginId)
, sessionKey :: CS.Key
}
insertLoginId :: LoginId -> StateInfo -> IO ()
insertLoginId uid sinfo = do
STM.atomically $ STM.modifyTVar' (sessionTVar (siSessions sinfo)) (Set.insert uid)

insertLoginId :: LoginId -> SessionStore -> IO ()
insertLoginId uid sessionStore = do
STM.atomically $ STM.modifyTVar' (sessionTVar sessionStore) (Set.insert uid)
deleteLoginId :: LoginId -> StateInfo -> IO ()
deleteLoginId uid sinfo = do
STM.atomically $ STM.modifyTVar' (sessionTVar (siSessions sinfo)) (Set.delete 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
getSessionStore :: StateInfo -> IO (Set.Set LoginId)
getSessionStore = STM.readTVarIO . sessionTVar . siSessions

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

newSession :: SessionStore -> LoginId -> S.ActionM ()
newSession sessionStore uid = do
newSession :: StateInfo -> LoginId -> S.ActionM ()
newSession sinfo uid = do
let
suid = T.encodeUtf8 $ T.pack $ show uid
cookie <- liftIO $ BSL.fromStrict <$> encryptCookieIO (sessionKey sessionStore) (mkCookie "logged_in" suid)
makeCookie =
case siMode sinfo of
Production -> mkCookie
Development -> mkInsecureCookie
cookie <-
liftIO $
BSL.fromStrict <$>
encryptCookieIO
(sessionKey (siSessions sinfo))
(makeCookie "logged_in" suid)
S.setHeader "Set-Cookie" (TL.decodeUtf8 cookie)
liftIO $ insertLoginId uid sessionStore
liftIO $ insertLoginId uid sinfo

-- | Try to get the currently logged-in user
getSession :: SessionStore -> S.ActionM (Maybe LoginId)
getSession sessionStore = do
getSession :: StateInfo -> S.ActionM (Maybe LoginId)
getSession sinfo = do
bytes <- fmap TL.encodeUtf8 <$> S.header "Cookie"
cookie <- fmap join . liftIO $ traverse (decryptCookieIO (sessionKey sessionStore)) bytes
cookie <- fmap join . liftIO $ traverse (decryptCookieIO (sessionKey (siSessions sinfo))) bytes
case cookie of
Just ("logged_in", suid) -> do
sessions <- liftIO $ getSessionStore sessionStore
sessions <- liftIO $ getSessionStore sinfo
let
uid = read (T.unpack $ T.decodeUtf8 suid)
if uid `Set.member` sessions
@@ -92,9 +96,9 @@ getSession sessionStore = do
_ ->
pure Nothing

deleteSession :: SessionStore -> LoginId -> S.ActionM ()
deleteSession sessionStoreVar uid =
liftIO $ deleteLoginId uid sessionStoreVar
deleteSession :: StateInfo -> LoginId -> S.ActionM ()
deleteSession sinfo uid =
liftIO $ deleteLoginId uid sinfo

----------------------------
-- Cookie Encrypt/Decrypt --
@@ -122,6 +126,7 @@ decryptCookieIO key bs =
-- Cookies --
-------------


mkCookie :: BS.ByteString -> BS.ByteString -> C.SetCookie
mkCookie name value =
C.defaultSetCookie
@@ -134,6 +139,13 @@ mkCookie name value =
, C.setCookieMaxAge = Just sixtyDays
}

mkInsecureCookie :: BS.ByteString -> BS.ByteString -> C.SetCookie
mkInsecureCookie name value =
(mkCookie name value)
{ C.setCookieSecure = False
}


-- utils --

sixtyDays :: Time.DiffTime


Loading…
Cancel
Save