221 lines
7.0 KiB
Haskell
221 lines
7.0 KiB
Haskell
-- | Internal module exposing the guts of the package. Use at
|
|
-- your own risk. No API stability guarantees apply.
|
|
module Web.ServerSession.Backend.Redis.Internal
|
|
( RedisStorage(..)
|
|
, RedisStorageException(..)
|
|
|
|
, transaction
|
|
, unwrap
|
|
, rSessionKey
|
|
, rAuthKey
|
|
|
|
, parseSession
|
|
, printSession
|
|
, parseUTCTime
|
|
, printUTCTime
|
|
, timeFormat
|
|
|
|
, getSessionImpl
|
|
, deleteSessionImpl
|
|
, removeSessionFromAuthId
|
|
, deleteAllSessionsOfAuthIdImpl
|
|
, insertSessionImpl
|
|
, replaceSessionImpl
|
|
) where
|
|
|
|
import Control.Applicative ((<$))
|
|
import Control.Arrow (first)
|
|
import Control.Monad (void, when)
|
|
import Control.Monad.IO.Class (liftIO)
|
|
import Data.ByteString (ByteString)
|
|
import Data.List (partition)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Typeable (Typeable)
|
|
import Web.PathPieces (toPathPiece)
|
|
import Web.ServerSession.Core
|
|
|
|
import qualified Control.Exception as E
|
|
import qualified Database.Redis as R
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.Map.Strict as M
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Time.Clock as TI
|
|
import qualified Data.Time.Format as TI
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
-- | Session storage backend using Redis via the @hedis@ package.
|
|
newtype RedisStorage =
|
|
RedisStorage
|
|
{ connPool :: R.Connection
|
|
-- ^ Connection pool to the Redis server.
|
|
} deriving (Typeable)
|
|
|
|
|
|
-- | We do not provide any ACID guarantees for different actions
|
|
-- running inside the same @TransactionM RedisStorage@.
|
|
instance Storage RedisStorage where
|
|
type TransactionM RedisStorage = R.Redis
|
|
runTransactionM = R.runRedis . connPool
|
|
getSession _ = getSessionImpl
|
|
deleteSession _ = deleteSessionImpl
|
|
deleteAllSessionsOfAuthId _ = deleteAllSessionsOfAuthIdImpl
|
|
insertSession _ = insertSessionImpl
|
|
replaceSession _ = replaceSessionImpl
|
|
|
|
|
|
-- | An exception thrown by the @serversession-backend-redis@
|
|
-- package.
|
|
data RedisStorageException =
|
|
ExpectedTxSuccess (R.TxResult ())
|
|
-- ^ We expected 'TxSuccess' but got something else.
|
|
| ExpectedRight R.Reply
|
|
-- ^ We expected 'Right' from an @Either 'R.Reply' a@ but got
|
|
-- 'Left'.
|
|
deriving (Show, Typeable)
|
|
|
|
instance E.Exception RedisStorageException
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
-- | Run the given Redis transaction and force its result.
|
|
-- Throws a 'RedisStorageException' if the result is not
|
|
-- 'TxSuccess'.
|
|
transaction :: R.RedisTx (R.Queued ()) -> R.Redis ()
|
|
transaction tx = do
|
|
ret <- R.multiExec tx
|
|
case ret of
|
|
R.TxSuccess () -> return ()
|
|
_ -> liftIO $ E.throwIO $ ExpectedTxSuccess ret
|
|
|
|
|
|
-- | Unwraps an @Either 'R.Reply' a@ by throwing an exception if
|
|
-- not @Right@.
|
|
unwrap :: R.Redis (Either R.Reply a) -> R.Redis a
|
|
unwrap act = act >>= either (liftIO . E.throwIO . ExpectedRight) return
|
|
|
|
|
|
-- | Redis key for the given session ID.
|
|
rSessionKey :: SessionId -> ByteString
|
|
rSessionKey = B.append "ssr:session:" . TE.encodeUtf8 . toPathPiece
|
|
|
|
|
|
-- | Redis key for the given auth ID.
|
|
rAuthKey :: AuthId -> ByteString
|
|
rAuthKey = B.append "ssr:authid:"
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
-- | Parse a 'Session' from a Redis hash.
|
|
parseSession :: SessionId -> [(ByteString, ByteString)] -> Maybe Session
|
|
parseSession _ [] = Nothing
|
|
parseSession sid bss =
|
|
let (externalList, internalList) = partition (B8.isPrefixOf "data:" . fst) bss
|
|
authId = lookup "internal:authId" internalList
|
|
createdAt = parseUTCTime $ lookup' "internal:createdAt"
|
|
accessedAt = parseUTCTime $ lookup' "internal:accessedAt"
|
|
lookup' k = fromMaybe (error err) $ lookup k internalList
|
|
where err = "serversession-backend-redis/parseSession: missing key " ++ show k
|
|
sessionMap = M.fromList $ map (first $ TE.decodeUtf8 . removePrefix) externalList
|
|
where removePrefix bs = let ("data:", key) = B8.splitAt 5 bs in key
|
|
in Just Session
|
|
{ sessionKey = sid
|
|
, sessionAuthId = authId
|
|
, sessionData = sessionMap
|
|
, sessionCreatedAt = createdAt
|
|
, sessionAccessedAt = accessedAt
|
|
}
|
|
|
|
|
|
-- | Convert a 'Session' into a Redis hash.
|
|
printSession :: Session -> [(ByteString, ByteString)]
|
|
printSession Session {..} =
|
|
maybe id ((:) . (,) "internal:authId") sessionAuthId $
|
|
(:) ("internal:createdAt", printUTCTime sessionCreatedAt) $
|
|
(:) ("internal:accessedAt", printUTCTime sessionAccessedAt) $
|
|
map (first $ B8.append "data:" . TE.encodeUtf8) $
|
|
M.toList sessionData
|
|
|
|
|
|
-- | Parse 'UTCTime' from a 'ByteString' stored on Redis. Uses
|
|
-- 'error' on parse error.
|
|
parseUTCTime :: ByteString -> TI.UTCTime
|
|
parseUTCTime = TI.parseTimeOrError True TI.defaultTimeLocale timeFormat . B8.unpack
|
|
|
|
|
|
-- | Convert a 'UTCTime' into a 'ByteString' to be stored on
|
|
-- Redis.
|
|
printUTCTime :: TI.UTCTime -> ByteString
|
|
printUTCTime = B8.pack . TI.formatTime TI.defaultTimeLocale timeFormat
|
|
|
|
|
|
-- | Time format used when storing 'UTCTime'.
|
|
timeFormat :: String
|
|
timeFormat = "%Y-%m-%dT%H:%M:%S.%q"
|
|
|
|
|
|
----------------------------------------------------------------------
|
|
|
|
|
|
-- | Get the session for the given session ID.
|
|
getSessionImpl :: SessionId -> R.Redis (Maybe Session)
|
|
getSessionImpl sid = parseSession sid <$> unwrap (R.hgetall $ rSessionKey sid)
|
|
|
|
|
|
-- | Delete the session with given session ID.
|
|
deleteSessionImpl :: SessionId -> R.Redis ()
|
|
deleteSessionImpl sid = do
|
|
msession <- getSessionImpl sid
|
|
case msession of
|
|
Nothing -> return ()
|
|
Just session ->
|
|
transaction $ do
|
|
r <- R.del [rSessionKey sid]
|
|
removeSessionFromAuthId sid (sessionAuthId session)
|
|
return (() <$ r)
|
|
|
|
|
|
-- | Remove the given 'SessionId' from the set of sessions of the
|
|
-- given 'AuthId'. Does not do anything if @Nothing@.
|
|
removeSessionFromAuthId :: R.RedisCtx m f => SessionId -> Maybe AuthId -> m ()
|
|
removeSessionFromAuthId _ Nothing = return ()
|
|
removeSessionFromAuthId sid (Just authId) =
|
|
void $ R.srem (rAuthKey authId) [rSessionKey sid]
|
|
|
|
|
|
-- | Delete all sessions of the given auth ID.
|
|
deleteAllSessionsOfAuthIdImpl :: AuthId -> R.Redis ()
|
|
deleteAllSessionsOfAuthIdImpl authId = do
|
|
sessionRefs <- unwrap $ R.smembers (rAuthKey authId)
|
|
void $ unwrap $ R.del $ rAuthKey authId : sessionRefs
|
|
|
|
|
|
-- | Insert a new session.
|
|
insertSessionImpl :: Session -> R.Redis ()
|
|
insertSessionImpl session = do
|
|
transaction $ do
|
|
let sk = rSessionKey $ sessionKey session
|
|
r <- R.hmset sk (printSession session)
|
|
-- TODO: R.expireat
|
|
maybe (return ()) (\authId -> void $ R.sadd (rAuthKey authId) [sk]) $ sessionAuthId session
|
|
return (() <$ r)
|
|
|
|
|
|
-- | Replace the contents of a session.
|
|
replaceSessionImpl :: Session -> R.Redis ()
|
|
replaceSessionImpl session = do
|
|
-- Remove the old auth ID from the map if it has changed.
|
|
oldSession <- getSessionImpl (sessionKey session)
|
|
let oldAuthId = sessionAuthId =<< oldSession
|
|
when (oldAuthId /= sessionAuthId session) $
|
|
removeSessionFromAuthId (sessionKey session) oldAuthId
|
|
-- Otherwise the operation is the same as inserting.
|
|
insertSessionImpl session
|