From 916de034ad23b980abba948a36d5e6c11584f8a0 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Fri, 22 May 2015 23:34:24 -0300 Subject: [PATCH] Code from branch that lived on yesod's repo. --- .gitignore | 13 + yesod-persistent-session/LICENSE | 20 ++ yesod-persistent-session/README.md | 131 +++++++++ .../src/Yesod/Persist/Session.hs | 18 ++ .../Yesod/Persist/Session/Internal/Backend.hs | 266 ++++++++++++++++++ .../src/Yesod/Persist/Session/Internal/Sql.hs | 86 ++++++ .../Yesod/Persist/Session/Internal/Types.hs | 184 ++++++++++++ .../yesod-persistent-session.cabal | 59 ++++ 8 files changed, 777 insertions(+) create mode 100644 .gitignore create mode 100644 yesod-persistent-session/LICENSE create mode 100644 yesod-persistent-session/README.md create mode 100644 yesod-persistent-session/src/Yesod/Persist/Session.hs create mode 100644 yesod-persistent-session/src/Yesod/Persist/Session/Internal/Backend.hs create mode 100644 yesod-persistent-session/src/Yesod/Persist/Session/Internal/Sql.hs create mode 100644 yesod-persistent-session/src/Yesod/Persist/Session/Internal/Types.hs create mode 100644 yesod-persistent-session/yesod-persistent-session.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..53c2ade --- /dev/null +++ b/.gitignore @@ -0,0 +1,13 @@ +*~ +*.o +*.o_p +*.hi +dist +*.swp +cabal-dev/ +.hsenv/ +.cabal-sandbox/ +cabal.sandbox.config +/vendor/ +.shelly/ +tarballs/ diff --git a/yesod-persistent-session/LICENSE b/yesod-persistent-session/LICENSE new file mode 100644 index 0000000..cdf4661 --- /dev/null +++ b/yesod-persistent-session/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2015 Felipe Lessa + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/yesod-persistent-session/README.md b/yesod-persistent-session/README.md new file mode 100644 index 0000000..b04b654 --- /dev/null +++ b/yesod-persistent-session/README.md @@ -0,0 +1,131 @@ +# yesod-persistent-session + +Server-side session backend using persistent. + +This package implement traditional server-side sessions. Users +who don't have a session yet are assigned a random 144-bit +session ID that is the key on a database table kept by +persistent. All session data is saved on the database. + +The session ID stays fixed most of the time. Anonymous users +receive session IDs unless their session remains empty (as an +optimization). The session ID can be invalidated in order to +prevent +[session fixation attacks](http://www.acrossecurity.com/papers/session_fixation.pdf), +either automatically (see below) or manually (via +`forceInvalidate`). + + +## Authentication integration + +We have special support for `yesod-auth`: + + * The `_ID` session key used by `yesod-auth` is recognized and + saved separately on the database. This allows you to quickly + identify all sessions of a given user. For example, you're + able to implement a "log out everywhere" button. + + * Whenever the `_ID` changes, the backend will also invalidate + the current session ID and migrate the session data to a new + ID. This prevents session fixation attacks while still + allowing you to maintain session state accross login/logout + boundaries. + +If you wish to use a different authentication mechanism and still +enjoy the advantages above, just use the same `_ID` session key. + + +## Current limitations + + * All sessions use persistent cookies. + + * We support SQL backends only, such as + `persistent-postgresql`. The code has to fix upfront which + persistent backend is used. + + +## Background + +Yesod has always support client-side sessions via the +[`clientsession`](http://hackage.haskell.org/package/clientsession) +package: the session data is encrypted, signed, encoded and sent +to the client inside a cookie. When receiving a request, the +cookie is decoded, verified and decrypted. The server does not +have to maintain any state, so the client-side session backend is +as fast as the cryptographic primitives. + +However, there are some disadvantages to client-side sessions: + + * _Replay attacks_. It's not possible to invalidate a session, + for example. When logging out, a new cookie is sent with + logged out session data. However, as the server doesn't + maintain state about sessions, it will still accept the old, + logged in cookie until it expires. One could set very small + expiration times to mitigate this, but this would force users + to relogin frequently. This server-side backend allows you + to maintain long expiration times while still having secure + logouts. + + * _Cookie size_. As the cookie contain the whole session data + plus some overhead, care must be taken not to create too much + session data. Yesod already saves the logged in user ID via + `yesod-auth` and a XSRF token via `yesod-form`. This + server-side backend uses a cookie of fixed size (24 bytes). + + * _No remote logout_. In many instances it is desirable to + invalidate sessions other than the current one. For example, + the user may have changed their password, or the the site + provides a button to cancel all logged in sessions besides + the current one. This server-side backend allows you to + invalidate sessions other than the current one via + `forceInvalidate`. + + * _Missing key rotation_. Ideally, `clientsession`'s keys + should be rotated periodically. In practice, support for key + rotation has never been implemented on `clientsession`. This + server-side backend does not need to do key rotations, and + the session ID CPRNG is automatically reseeded. + +If you're concerned about any of the points above, you've come to +the right package! + + +## Comparision to other packages + +At the time of writing (2015-05-22), these are the session +packages that do not use either `clientsession` or +`serversession`: + + * `mysnapsession` (via `Memory` module, also supports + `clientsession` mode): Server-side sessions. Works for + `snap`. Weak session ID generation. Vulnerable to session + fixation attacks. Cannot invalidate other sessions. + + * `salvia-sessions`: Server-side sessions. Works only for + `salvia`. No built-in support for DB-backed sessions, only + memory-backed ones. Weak session ID generation. Vulnerable + to session fixation attacks. Cannot invalidate other + sessions. + + * `simple-session`: Client-side sessions. Works for `simple` + framework. No encryption. Authentication vulnerable to + timing attacks. + + * `Spock` (formely `scotty-session`): Server-side sessions. + Works for `Spock` (code is not packaged separately). Only + supports memory-backed sessions persisted on a file. Weak + session ID generation. Vulnerable to session fixation + attacks. Cannot invalidate other sessions. + + * `wai-session`: Server-side sessions. Works for `wai` + applications. Weak session ID generation. Vulnerable to + session fixation. Cannot invalidate other sessions. + Out-of-the-box support for TokyoCabinet only. + + * `yesod-session-redis`: Server-side sessions. Works for + Yesod and Redis. Weak session ID generation via `random`. + Vulnerable to session fixation. Cannot invalidate other + sessions. + +We apologize in advance if any information above is incorrect. +Please contact us about any errors. diff --git a/yesod-persistent-session/src/Yesod/Persist/Session.hs b/yesod-persistent-session/src/Yesod/Persist/Session.hs new file mode 100644 index 0000000..2796390 --- /dev/null +++ b/yesod-persistent-session/src/Yesod/Persist/Session.hs @@ -0,0 +1,18 @@ +-- | Server-side session backend. +-- +-- This module is meant to be imported qualified: +-- +-- @ +-- import qualified Yesod.Persist.Session as Session +-- @ +-- +-- TODO: Usage +module Yesod.Persist.Session + ( backend + , createState + , State + , forceInvalidate + , ForceInvalidate(..) + ) where + +import Yesod.Persist.Session.Internal.Backend diff --git a/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Backend.hs b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Backend.hs new file mode 100644 index 0000000..9b40578 --- /dev/null +++ b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Backend.hs @@ -0,0 +1,266 @@ +module Yesod.Persist.Session.Internal.Backend + ( State(..) + , createState + , backend + , loadSession + , invalidateIfNeeded + , DecomposedSession + , decomposeSession + , saveSessionOnDb + , createCookie + , findSessionId + , toSessionMap + , authKey + , forceInvalidateKey + , ForceInvalidate(..) + , forceInvalidate + ) where + +import Control.Monad (guard, when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.ByteString (ByteString) +import Data.Default (def) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Time (getCurrentTime) +import Data.Typeable (Typeable) +import Web.Cookie (parseCookies, SetCookie(..)) +import Web.PathPieces (fromPathPiece) +import Yesod.Core (MonadHandler) +import Yesod.Core.Handler (setSessionBS) +import Yesod.Core.Types (Header(AddCookie), SaveSession, SessionBackend(..), SessionMap) + +import qualified Crypto.Nonce as N +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Map as M +import qualified Data.Text.Encoding as TE +import qualified Network.Wai as W + +import Yesod.Persist.Session.Internal.Types + +-- TODO: expiration + +-- TODO: do not create empty sessions + +-- | The server-side session backend needs to maintain some state +-- in order to work: +-- +-- * A nonce generator for the session IDs. +-- +-- * The storage backend. +-- +-- Create a new 'State' using 'createState'. +data State s = + State + { generator :: !N.Generator + , storage :: !s + } deriving (Typeable) + + +-- | Create a new 'State' for the server-side session backend +-- using the given storage backend. +createState :: MonadIO m => s -> m (State s) +createState storage = State <$> N.new <*> return storage + + +-- | Construct the server-side session backend from the given state. +backend :: Storage s => State s -> SessionBackend +backend state = + SessionBackend { + sbLoadSession = loadSession state "JSESSIONID" -- LOL :) + } + + +-- | Load the session map from the DB from the ID on the request. +-- Also provides a function to update the session when sending +-- the response. +loadSession :: forall s. Storage s => State s -> ByteString -> W.Request -> IO (SessionMap, SaveSession) +loadSession state cookieName = load + where + runDB :: TransactionM s a -> IO a + runDB = runTransactionM (storage state) + + load :: W.Request -> IO (SessionMap, SaveSession) + load req = do + -- Find 'SessionId' (if any) and load it from DB (if present). + let maybeInputId = findSessionId cookieName req + maybeInput <- maybe (return Nothing) (runDB . getSession (storage state)) maybeInputId + let inputSessionMap = maybe M.empty toSessionMap maybeInput + return (inputSessionMap, save maybeInput) + + save :: Maybe Session -> SaveSession + save maybeInput wholeOutputSessionMap = + runDB $ do + let decomposedSessionMap = decomposeSession wholeOutputSessionMap + newMaybeInput <- invalidateIfNeeded state maybeInput decomposedSessionMap + key <- saveSessionOnDb state newMaybeInput decomposedSessionMap + return [createCookie cookieName key] + + +-- | Invalidates an old session ID if needed. Returns the +-- 'Session' that should be replaced when saving the session, if any. +-- +-- Currently we invalidate whenever the auth ID has changed +-- (login, logout, different user) in order to prevent session +-- fixation attacks. We also invalidate when asked to via +-- 'forceInvalidate'. +invalidateIfNeeded + :: Storage s + => State s + -> Maybe Session + -> DecomposedSession + -> TransactionM s (Maybe Session) +invalidateIfNeeded state maybeInput DecomposedSession {..} = do + -- Decide which action to take. + -- "invalidateOthers implies invalidateCurrent" should be true below. + let inputAuthId = sessionAuthId =<< maybeInput + invalidateCurrent = dsForceInvalidate /= DoNotForceInvalidate || inputAuthId /= dsAuthId + invalidateOthers = dsForceInvalidate == AllSessionIdsOfLoggedUser && isJust dsAuthId + whenMaybe b m f = when b $ maybe (return ()) f m + -- Delete current and others, as requested. + whenMaybe invalidateCurrent maybeInput $ deleteSession (storage state) . sessionKey + whenMaybe invalidateOthers dsAuthId $ deleteAllSessionsOfAuthId (storage state) + -- Remember the input only if not invalidated. + return $ guard (not invalidateCurrent) >> maybeInput + + +-- | A 'SessionMap' with its 'authKey' taken apart. +data DecomposedSession = + DecomposedSession + { dsAuthId :: !(Maybe ByteString) + , dsForceInvalidate :: !ForceInvalidate + , dsSessionMap :: !SessionMap + } deriving (Show, Typeable) + + +-- | Decompose a session (see 'DecomposedSession'). +decomposeSession :: SessionMap -> DecomposedSession +decomposeSession sm1 = + let (authId, sm2) = M.updateLookupWithKey (\_ _ -> Nothing) authKey sm1 + (force, sm3) = M.updateLookupWithKey (\_ _ -> Nothing) forceInvalidateKey sm2 + in DecomposedSession + { dsAuthId = authId + , dsForceInvalidate = maybe DoNotForceInvalidate (read . B8.unpack) force + , dsSessionMap = sm3 } + + +-- | Save a session on the database. If an old session is +-- supplied, it is replaced, otherwise a new session is +-- generated. +saveSessionOnDb + :: Storage s + => State s + -> Maybe Session -- ^ The old session, if any. + -> DecomposedSession -- ^ The session data to be saved. + -> TransactionM s SessionId -- ^ The ID of the saved session. +saveSessionOnDb state maybeInput DecomposedSession {..} = do + -- Generate properties if needed or take them from previous + -- saved session. + (saveToDb, key, createdAt) <- + case maybeInput of + Nothing -> liftIO $ + (,,) <$> return (insertSession $ storage state) + <*> generateSessionId (generator state) + <*> getCurrentTime + Just Session {..} -> + return ( replaceSession (storage state) + , sessionKey + , sessionCreatedAt) + -- Save to the database. + saveToDb $ Session key dsAuthId dsSessionMap createdAt + return key + + +-- | Create a cookie for the given session ID. +createCookie :: ByteString -> SessionId -> Header +createCookie cookieName key = + -- Generate a cookie with the final session ID. + AddCookie def + { setCookieName = cookieName + , setCookieValue = TE.encodeUtf8 $ unS key + , setCookiePath = Just "/" + , setCookieExpires = Just undefined + , setCookieDomain = Nothing + , setCookieHttpOnly = True + } + + +-- | Fetch the 'SessionId' from the cookie with the given name. +-- Returns @Nothing@ if: +-- +-- * There are zero cookies with the given name. +-- +-- * There is more than one cookie with the given name. +-- +-- * The cookie's value isn't considered a 'SessionId'. We're +-- a bit strict here. +findSessionId :: ByteString -> W.Request -> Maybe SessionId +findSessionId cookieName req = do + let matching = do + ("Cookie", header) <- W.requestHeaders req + (k, v) <- parseCookies header + guard (k == cookieName) + return v + [raw] <- return matching + fromPathPiece (TE.decodeUtf8 raw) + + +-- | Create a 'SessionMap' from a 'Session'. +toSessionMap :: Session -> SessionMap +toSessionMap Session {..} = + maybe id (M.insert authKey) sessionAuthId sessionData + + +-- | The session key used by @yesod-auth@ without depending on it. +authKey :: Text +authKey = "_ID" + + +-- | The session key used to signal that the session ID should be +-- invalidated. +forceInvalidateKey :: Text +forceInvalidateKey = "yesod-persistent-session-force-invalidate" + + +-- | Which session IDs should be invalidated. +data ForceInvalidate = + CurrentSessionId + -- ^ Invalidate the current session ID. The current session + -- ID is automatically invalidated on @yesod-auth@ login and + -- logout. + | AllSessionIdsOfLoggedUser + -- ^ Invalidate all session IDs beloging to the currently + -- logged in user. Only the current session ID will be + -- renewed (the only one for which a cookie can be set). + -- + -- This is useful, for example, if the user asks to change + -- their password. It's also useful to provide a button to + -- clear all other sessions. + -- + -- If the user is not logged in, this option behaves exactly + -- as 'CurrentSessionId' (i.e., it /does not/ invalidate the + -- sessions of all logged out users). + -- + -- Note that, for the purposes of + -- 'AllSessionIdsOfLoggedUser', we consider \"logged user\" + -- the one that is logged in at the *end* of the handler + -- processing. For example, if the user was logged in but + -- the current handler logged him out, the session IDs of the + -- user who was logged in will not be invalidated. + | DoNotForceInvalidate + -- ^ Do not force invalidate. Invalidate only if + -- automatically. This is the default. + deriving (Eq, Ord, Show, Read, Enum, Typeable) + + +-- | Invalidate the current session ID (and possibly more, check +-- 'ForceInvalidate'). This is useful to avoid session fixation +-- attacks (cf. ). +-- +-- Note that the invalidate /does not/ occur when the call to +-- this action is made! The sessions will be invalidated on the +-- end of the handler processing. This means that later calls to +-- 'forceInvalidate' on the same handler will override earlier +-- calls. +forceInvalidate :: MonadHandler m => ForceInvalidate -> m () +forceInvalidate = setSessionBS forceInvalidateKey . B8.pack . show diff --git a/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Sql.hs b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Sql.hs new file mode 100644 index 0000000..69a2720 --- /dev/null +++ b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Sql.hs @@ -0,0 +1,86 @@ +module Yesod.Persist.Session.Internal.Sql + ( PersistentSession(..) + , PersistentSessionId + , EntityField(..) + , persistentSessionDefs + , psKey + , toPersistentSession + , fromPersistentSession + , SqlStorage(..) + ) where + +import Control.Monad (void) +import Data.Pool (Pool) +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import Database.Persist (PersistEntity(..), toPersistValue) +import Database.Persist.TH (mkPersist, mkSave, persistLowerCase, share, sqlSettings) + +import qualified Database.Persist as P +import qualified Database.Persist.Sql as P + +import Yesod.Persist.Session.Internal.Types + + +share + [mkPersist sqlSettings, mkSave "persistentSessionDefs"] + [persistLowerCase| + PersistentSession json + key SessionId -- Session ID, primary key. + authId ByteStringJ Maybe -- Value of "_ID" session key. + session SessionMapJ -- Rest of the session data. + createdAt UTCTime -- When this session was created. + Primary key + deriving Eq Ord Show Typeable + |] + + +-- | Generate a key to the entity from the session ID. +psKey :: SessionId -> Key PersistentSession +psKey = unwrap . keyFromValues . return . toPersistValue + where + unwrap (Left e) = error $ + "Yesod.Persist.Session.Internal.Entities.psKey: " ++ + "unexpected error from keyFromValues: " ++ show e + unwrap (Right k) = k + + +-- | Convert from 'Session' to 'PersistentSession'. +toPersistentSession :: Session -> PersistentSession +toPersistentSession Session {..} = + PersistentSession + { persistentSessionKey = sessionKey + , persistentSessionAuthId = fmap B sessionAuthId + , persistentSessionSession = M sessionData + , persistentSessionCreatedAt = sessionCreatedAt + } + + +-- | Convert from 'PersistentSession' to 'Session'. +fromPersistentSession :: PersistentSession -> Session +fromPersistentSession PersistentSession {..} = + Session + { sessionKey = persistentSessionKey + , sessionAuthId = fmap unB persistentSessionAuthId + , sessionData = unM persistentSessionSession + , sessionCreatedAt = persistentSessionCreatedAt + } + + +-- | SQL session storage backend using @persistent@. +newtype SqlStorage = + SqlStorage + { connPool :: Pool P.SqlBackend + -- ^ Pool of DB connections. You may use the same pool as + -- your application. + } deriving (Typeable) + + +instance Storage SqlStorage where + type TransactionM SqlStorage = P.SqlPersistT IO + runTransactionM = flip P.runSqlPool . connPool + getSession _ = fmap (fmap fromPersistentSession) . P.get . psKey + deleteSession _ = P.delete . psKey + deleteAllSessionsOfAuthId _ authId = P.deleteWhere [PersistentSessionAuthId P.==. Just (B authId)] + insertSession _ = void . P.insert . toPersistentSession + replaceSession _ = \session -> P.replace (psKey $ sessionKey session) $ toPersistentSession session diff --git a/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Types.hs b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Types.hs new file mode 100644 index 0000000..c93ab57 --- /dev/null +++ b/yesod-persistent-session/src/Yesod/Persist/Session/Internal/Types.hs @@ -0,0 +1,184 @@ +module Yesod.Persist.Session.Internal.Types + ( SessionId(..) + , generateSessionId + , Session(..) + , Storage(..) + , ByteStringJ(..) + , SessionMapJ(..) + ) where + +import Control.Monad ((>=>), guard, mzero) +import Control.Monad.IO.Class (MonadIO) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Time (UTCTime) +import Data.Typeable (Typeable) +import Database.Persist (PersistField(..)) +import Database.Persist.Sql (PersistFieldSql(..)) +import Web.PathPieces (PathPiece(..)) +import Yesod.Core (SessionMap) + +import qualified Crypto.Nonce as N +import qualified Data.Aeson as A +import qualified Data.ByteString as B +import qualified Data.ByteString.Base64.URL as B64URL +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as M +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + + +---------------------------------------------------------------------- + + +-- | The ID of a session. Always 18 bytes base64url-encoded as +-- 24 characters. +-- +-- Implementation notes: +-- +-- * Use 'fromPathPiece' for parsing untrusted input. +-- +-- * Use 'generateSessionId' for securely generating new +-- session IDs. +newtype SessionId = S { unS :: Text } + deriving (Eq, Ord, Show, Read, Typeable) + +-- | Sanity checks input on 'fromPathPiece' (untrusted input). +instance PathPiece SessionId where + toPathPiece = unS + fromPathPiece = checkSessionId + +-- | Does not do sanity checks (DB is trusted). +instance PersistField SessionId where + toPersistValue = toPersistValue . unS + fromPersistValue = fmap S . fromPersistValue + +instance PersistFieldSql SessionId where + sqlType p = sqlType (fmap unS p) + +instance A.FromJSON SessionId where + parseJSON = fmap S . A.parseJSON + +instance A.ToJSON SessionId where + toJSON = A.toJSON . unS + + +-- | (Internal) Check that the given text is a base64url-encoded +-- representation of 18 bytes. +checkSessionId :: Text -> Maybe SessionId +checkSessionId text = do + guard (T.length text == 24) + let bs = TE.encodeUtf8 text + decoded <- either (const Nothing) Just $ B64URL.decode bs + guard (B.length decoded == 18) + return $ S $ T.toLower text + + +-- | Securely generate a new SessionId. +generateSessionId :: N.Generator -> IO SessionId +generateSessionId = fmap S . N.nonce128urlT + + +---------------------------------------------------------------------- + + +-- | Representation of a saved session. +data Session = + Session + { sessionKey :: SessionId + -- ^ Session ID, primary key. + , sessionAuthId :: Maybe ByteString + -- ^ Value of "_ID" session key, separate from the rest. + , sessionData :: SessionMap + -- ^ Rest of the session data. + , sessionCreatedAt :: UTCTime + -- ^ When this session was created. + } deriving (Eq, Ord, Show, Typeable) + + +---------------------------------------------------------------------- + + +-- | A storage backend for server-side sessions. +class MonadIO (TransactionM s) => Storage s where + -- | Monad where transactions happen for this backend. + -- We do not require transactions to be ACID. + type TransactionM s :: * -> * + + -- | Run a transaction on the IO monad. + runTransactionM :: s -> TransactionM s a -> IO a + + -- | Get the session for the given session ID. + getSession :: s -> SessionId -> TransactionM s (Maybe Session) + + -- | Delete the session with given session ID. + deleteSession :: s -> SessionId -> TransactionM s () + + -- | Delete all sessions of the given auth ID. + deleteAllSessionsOfAuthId :: s -> ByteString -> TransactionM s () + + -- | Insert a new session. + insertSession :: s -> Session -> TransactionM s () + + -- | Replace the contents of a session. + replaceSession :: s -> Session -> TransactionM s () + + +---------------------------------------------------------------------- + + +-- | Newtype of a 'ByteString' with JSON support via base64url. +newtype ByteStringJ = B { unB :: ByteString } + deriving (Eq, Ord, Show, Read, Typeable) + +instance PersistField ByteStringJ where + toPersistValue = toPersistValue . unB + fromPersistValue = fmap B . fromPersistValue + +instance PersistFieldSql ByteStringJ where + sqlType p = sqlType (fmap unB p) + +instance A.FromJSON ByteStringJ where + parseJSON (A.String t) = + either (const mzero) (return . B) $ + B64URL.decode $ + TE.encodeUtf8 t + parseJSON _ = mzero + +instance A.ToJSON ByteStringJ where + toJSON = A.String . TE.decodeUtf8 . B64URL.encode . unB + + +---------------------------------------------------------------------- + + +-- | Newtype of a 'SessionMap' that serializes as a JSON on +-- the database. We use JSON because it's easy to inspect for a +-- human. +newtype SessionMapJ = M { unM :: SessionMap } + deriving (Eq, Ord, Show, Read, Typeable) + +encodeT :: A.ToJSON a => a -> Text +encodeT = TE.decodeUtf8 . L.toStrict . A.encode + +decodeT :: A.FromJSON a => Text -> Either Text a +decodeT = either (Left . T.pack) Right . A.eitherDecode . L.fromStrict . TE.encodeUtf8 + +instance PersistField SessionMapJ where + toPersistValue = toPersistValue . encodeT + fromPersistValue = fromPersistValue >=> decodeT + +instance PersistFieldSql SessionMapJ where + sqlType p = sqlType (fmap encodeT p) + +instance A.FromJSON SessionMapJ where + parseJSON = fmap fixup . A.parseJSON + where + fixup :: M.Map Text ByteStringJ -> SessionMapJ + fixup = M . fmap unB + +instance A.ToJSON SessionMapJ where + toJSON = A.toJSON . mangle + where + mangle :: SessionMapJ -> M.Map Text ByteStringJ + mangle = fmap B . unM diff --git a/yesod-persistent-session/yesod-persistent-session.cabal b/yesod-persistent-session/yesod-persistent-session.cabal new file mode 100644 index 0000000..3ca7319 --- /dev/null +++ b/yesod-persistent-session/yesod-persistent-session.cabal @@ -0,0 +1,59 @@ +name: yesod-persistent-session +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Server-side session backend using persistent. +category: Web, Yesod, Database +stability: Stable +cabal-version: >= 1.8 +build-type: Simple +homepage: http://www.yesodweb.com/ +description: API docs and the README are available at +extra-source-files: README.md ChangeLog.md + +library + hs-source-dirs: src + build-depends: + base == 4.* + , aeson + , base64-bytestring == 1.0.* + , bytestring + , containers + , cookie >= 0.4 + , data-default + , nonce == 1.0.* + , path-pieces + , persistent == 2.1.* + , persistent-template == 2.1.* + , resource-pool + , text + , time + , transformers + , wai + , yesod-core == 1.4.* + exposed-modules: + Yesod.Persist.Session + Yesod.Persist.Session.Internal.Backend + Yesod.Persist.Session.Internal.Sql + Yesod.Persist.Session.Internal.Types + extensions: + DeriveDataTypeable + EmptyDataDecls + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + OverloadedStrings + QuasiQuotes + RecordWildCards + ScopedTypeVariables + TemplateHaskell + TypeFamilies + ghc-options: -Wall + + +source-repository head + type: git + location: https://github.com/yesodweb/yesod