module Web.Scotty.Login.Session ( initializeCookieDb
, addSession
, authCheck
, SessionConfig(..)
, Session
, defaultSessionConfig
)
where
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (when)
import Control.Monad.IO.Class
import Data.Maybe (isNothing)
import Data.Monoid
import qualified Data.Text as TS
import qualified Data.Text.Lazy as T
import Data.Time.Clock
import Database.Persist as D
import Database.Persist.Sqlite
import Network.HTTP.Types.Status (forbidden403)
import Web.Scotty.Cookie as SC
import Web.Scotty.Trans as S
import Crypto.Random (getRandomBytes)
import qualified Data.ByteString as B
import Numeric (showHex)
import Web.Scotty.Login.Internal.Cookies as C
import Web.Scotty.Login.Internal.Model
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Trans.Resource (ResourceT)
import Data.IORef
import Data.List (find)
import System.IO.Unsafe (unsafePerformIO)
data SessionConfig =
SessionConfig { dbPath :: String
, syncInterval :: NominalDiffTime
, expirationInterval :: NominalDiffTime
}
type SessionVault = [Session]
type SessionStore = IORef SessionVault
defaultSessionConfig :: SessionConfig
defaultSessionConfig = SessionConfig "sessions.sqlite3" 1200 120
vault :: SessionStore
vault = unsafePerformIO $ newIORef []
readVault :: IO SessionVault
readVault = readIORef vault
modifyVault :: (SessionVault -> SessionVault) -> IO ()
modifyVault f = atomicModifyIORef' vault (flip (,) () . f)
initializeCookieDb :: SessionConfig -> IO ()
initializeCookieDb c = do
t <- getCurrentTime
ses <- runDB c $ do runMigration migrateAll
selectList [SessionExpiration >=. t] []
let sessions = map entityVal ses :: SessionVault
modifyVault $ const sessions
forkIO $ dbSyncAndCleanupLoop c
return ()
dbSyncAndCleanupLoop :: SessionConfig -> IO ()
dbSyncAndCleanupLoop c = do
threadDelay $ (floor $ syncInterval c) * 1000000
t <- getCurrentTime
vaultContents <- readVault
mapM_ (runDB c . insert) vaultContents
runDB c $ deleteWhere [SessionExpiration <=. t]
modifyVault $ filter (\s -> sessionExpiration s >= t)
dbSyncAndCleanupLoop c
addSession :: SessionConfig -> ActionT T.Text IO (Maybe Session)
addSession c = do
existingCookie <- SC.getCookie "SessionId"
whenMaybe (isNothing existingCookie) $ do
(bh :: B.ByteString) <- liftIO $ getRandomBytes 128
t <- liftIO getCurrentTime
let val = TS.pack $ mconcat $ map (`showHex` "") $ B.unpack bh
t' = addUTCTime (expirationInterval c) t
C.setSimpleCookieExpr "SessionId" val t'
liftIO $ insertSession (T.fromStrict val) t'
return $ Just $ Session (T.fromStrict val) t'
where whenMaybe p s = if p then s else return Nothing
authCheck :: (MonadIO m, ScottyError e)
=> ActionT e m ()
-> ActionT e m ()
-> ActionT e m ()
authCheck d a = do
vaultContents <- liftIO readVault
c <- SC.getCookie "SessionId"
case c of
Nothing -> d
Just v -> do
let session = find (\s -> sessionSid s == T.fromStrict v) vaultContents
case session of
Nothing -> d >> status forbidden403
Just s -> do let
t = sessionExpiration s
curTime <- liftIO getCurrentTime
if diffUTCTime t curTime > 0
then a
else d >> status forbidden403
insertSession :: T.Text
-> UTCTime
-> IO ()
insertSession sid t = modifyVault (Session sid t :)
runDB :: SessionConfig
-> SqlPersistT (NoLoggingT (ResourceT IO)) a
-> IO a
runDB c = runSqlite $ TS.pack $ dbPath c