haskell/serversession
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Separate into three different packages.

Browse Source 
serversession and serversession-backend-persistent build,
serversession-frontend-yesod is broken.
This commit is contained in:
Felipe Lessa 2015-05-23 01:42:13 -03:00
parent e5f2a4d87a
commit 71aff2dd94
19 changed files with 919 additions and 626 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

163
README.md Normal file
View File

@ -0,0 +1,163 @@
# serversession packages
Secure, modular server-side sessions.
This repo contains many packages that together 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
storage backend. All session data is saved on the storage backend.
The `serversession` package implements the core logic. It needs
to be paired up with two companion packages:
* /Backend (storage)/, in order to store the session data.
Currently we support:
* `serversession-backend-persistent`: Storage backend using
`persistent`'s SQL backend. Works with PostgreSQL, MySQL,
SQLite.
* /Frontend/, bindings for your web framework of choice.
Currently we support:
* `serversession-frontend-yesod`: Support the Yesod
framework. Replaces the default `clientsession`.
If your favorite storage backend or framework is not listed
above, please send us a pull request! The `serversession`
package should work for any session that may be represented as a
mapping of keys to values.
## Security notes
The session ID is generated via the `nonce` package, which in
turn uses a CPRNG created from AES on CTR mode. The CPRNG is
reseed automatically from `/dev/urandom` (or equivalent)
periodically. We use the base64url variant, thus providing 144
bits of entropy, which is more than enough to make guessing
session IDs impossible.
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`).
We support both idle timeouts and absolute timeouts. Idle
timeouts invalidate the session if a given amount of time has
passed since the last request was made for a session. Absolute
timeouts invalidate the session if a given amount of time has
passed since the session was created, no matter the activity.
## Authentication integration
We have special support for authentication plugins that save
information about the logged in user on a session variable:
* The session key used by authentication plugin (e.g., `_ID`
for `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 logged in user 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.
Any authentication mechanism is supported as long as it uses a
session variable.
## 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.
The `serversession` package is `clientsession`'s rival, each has
their own advantages and disadvantages. However, both of them
can be used on different ecosystems and take security from the
ground up.
## 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.

20
serversession-backend-persistent/LICENSE Normal file
View File

@ -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.

10
serversession-backend-persistent/README.md Normal file
View File

@ -0,0 +1,10 @@
# serversession-backend-persistent
This is the storage backend for `serversession` using
`persistent` and an RDBMS. Please
[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md)
for general information about the serversession packages.
Unfortunately it is not easy to support all `persistent` backends
on a single package, and this is why we currently support the SQL
backend only (which is more commonly used).

51
serversession-backend-persistent/serversession-backend-persistent.cabal Normal file
View File

@ -0,0 +1,51 @@
name: serversession-backend-persistent
version: 1.0
license: MIT
license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Storage backend for serversession using persistent and an RDBMS.
category: Web
stability: Stable
cabal-version: >= 1.8
build-type: Simple
homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-backend-persistent-sql>
extra-source-files: README.md
library
hs-source-dirs: src
build-depends:
base == 4.*
, aeson
, base64-bytestring == 1.0.*
, bytestring
, containers
, path-pieces
, persistent == 2.1.*
, persistent-template == 2.1.*
, resource-pool
, text
, time
, serversession == 1.0.*
exposed-modules:
Web.ServerSession.Backend.Persistent
Web.ServerSession.Backend.Persistent.Internal.Impl
Web.ServerSession.Backend.Persistent.Internal.Types
extensions:
DeriveDataTypeable
EmptyDataDecls
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
OverloadedStrings
QuasiQuotes
RecordWildCards
TemplateHaskell
TypeFamilies
ghc-options: -Wall
source-repository head
type: git
location: https://github.com/yesodweb/serversession

40
serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs Normal file
View File

@ -0,0 +1,40 @@
-- | Storage backend for @serversession@ using persistent.
--
-- In order to use this backend, you have to include
-- 'serverSessionDefs' on your migration code. For example,
-- the Yesod scaffold usually includes the following code:
--
-- @
-- -- On Model.hs
-- share [mkPersist sqlSettings, mkMigrate \"migrateAll\"]
--
-- -- On Application.hs
-- makeFoundation =
-- ...
-- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-- ...
-- @
--
-- You should changed those lines to:
--
-- @
-- -- On Model.hs
-- share [mkPersist sqlSettings, mkSave \"entityDefs\"]
--
-- -- On Application.hs
-- mkMigrate \"migrateAll\" (serverSessionDefs ++ entityDefs)
--
-- makeFoundation =
-- ...
-- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-- ...
-- @
--
-- If you forget to setup the migration above, this backend will
-- fail at runtime as the required table will not exist.
module Web.ServerSession.Backend.Persistent
( SqlStorage(..)
, serverSessionDefs
) where
import Web.ServerSession.Backend.Persistent.Internal.Impl

20
serversession/src/Yesod/Persist/Session/Internal/Sql.hs → serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs
View File

@ -1,8 +1,10 @@
module Yesod.Persist.Session.Internal.Sql
-- | Internal module exposing the guts of the package. Use at
-- your own risk. No API stability guarantees apply.
module Web.ServerSession.Backend.Persistent.Internal.Impl
( PersistentSession(..)
, PersistentSessionId
, EntityField(..)
, persistentSessionDefs
, serverSessionDefs
, psKey
, toPersistentSession
, fromPersistentSession
@ -13,17 +15,18 @@ import Control.Monad (void)
import Data.Pool (Pool)
import Data.Time (UTCTime)
import Data.Typeable (Typeable)
import Database.Persist (PersistEntity(..), toPersistValue)
import Database.Persist (PersistEntity(..))
import Database.Persist.TH (mkPersist, mkSave, persistLowerCase, share, sqlSettings)
import Web.ServerSession.Core
import qualified Database.Persist as P
import qualified Database.Persist.Sql as P
import Yesod.Persist.Session.Internal.Types
import Web.ServerSession.Backend.Persistent.Internal.Types
share
[mkPersist sqlSettings, mkSave "persistentSessionDefs"]
[mkPersist sqlSettings, mkSave "serverSessionDefs"]
[persistLowerCase|
PersistentSession json
key SessionId -- Session ID, primary key.
@ -37,12 +40,7 @@ share
-- | 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
psKey = PersistentSessionKey'
-- | Convert from 'Session' to 'PersistentSession'.

97
serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs Normal file
View File

@ -0,0 +1,97 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Internal module exposing the guts of the package. Use at
-- your own risk. No API stability guarantees apply.
--
-- Also exports orphan instances of @PersistField{,Sql} SessionId@.
module Web.ServerSession.Backend.Persistent.Internal.Types
( ByteStringJ(..)
, SessionMapJ(..)
) where
import Control.Monad ((>=>), mzero)
import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Typeable (Typeable)
import Database.Persist (PersistField(..))
import Database.Persist.Sql (PersistFieldSql(..))
import Web.ServerSession.Core
import Web.ServerSession.Core.Internal (SessionId(..))
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
----------------------------------------------------------------------
-- | 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)
----------------------------------------------------------------------
-- | 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

20
serversession-frontend-yesod/LICENSE Normal file
View File

@ -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.

6
serversession-frontend-yesod/README.md Normal file
View File

@ -0,0 +1,6 @@
# serversession-frontend-yesod
This package provide Yesod bindings for the `serversession`
package. Please
[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md)
for general information about the serversession packages.

58
serversession-frontend-yesod/serversession-frontend-yesod.cabal Normal file
View File

@ -0,0 +1,58 @@
name: serversession-frontend-yesod
version: 1.0
license: MIT
license-file: LICENSE
author: Felipe Lessa <felipe.lessa@gmail.com>
maintainer: Felipe Lessa <felipe.lessa@gmail.com>
synopsis: Yesod bindings for serversession.
category: Web
stability: Stable
cabal-version: >= 1.8
build-type: Simple
homepage: https://github.com/yesodweb/serversession
description: API docs and the README are available at <http://www.stackage.org/package/serversession-frontend-yesod>
extra-source-files: README.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/serversession

5
serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs Normal file
View File

@ -0,0 +1,5 @@
module Web.ServerSession.Frontend.Yesod
(
) where
import Web.ServerSession.Frontend.Yesod.Internal

77
serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs Normal file
View File

@ -0,0 +1,77 @@
module Web.ServerSession.Frontend.Yesod.Internal
(
) where
-- TODO: I'm in a bad shape :(.
import Data.Default (def)
import Web.Cookie (parseCookies, SetCookie(..))
import Yesod.Core (MonadHandler)
import Yesod.Core.Handler (setSessionBS)
import Yesod.Core.Types (Header(AddCookie), SaveSession, SessionBackend(..), SessionMap)
import qualified Network.Wai as W
-- | Construct the server-side session backend from the given state.
backend :: Storage s => State s -> SessionBackend
backend state =
SessionBackend {
sbLoadSession = loadSession state "JSESSIONID" -- LOL :)
}
-- | 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)
-- | The session key used by @yesod-auth@ without depending on it.
authKey :: Text
authKey = "_ID"
-- | Invalidate the current session ID (and possibly more, check
-- 'ForceInvalidate'). This is useful to avoid session fixation
-- attacks (cf. <http://www.acrossecurity.com/papers/session_fixation.pdf>).
--
-- 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

134
serversession/README.md
View File

@ -1,131 +1,5 @@
# yesod-persistent-session
# serversession
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.
This is the core package of the serversession family. Please
[read the main README file](https://github.com/yesodweb/serversession/blob/master/README.md)
for general information about the serversession packages.

19
serversession/serversession.cabal
View File

@ -21,35 +21,20 @@ library
, 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
Web.ServerSession.Core
Web.ServerSession.Core.Internal
extensions:
DeriveDataTypeable
EmptyDataDecls
FlexibleContexts
FlexibleInstances
GADTs
GeneralizedNewtypeDeriving
OverloadedStrings
QuasiQuotes
RecordWildCards
ScopedTypeVariables
TemplateHaskell
TypeFamilies
ghc-options: -Wall

21
serversession/src/Web/ServerSession/Core.hs Normal file
View File

@ -0,0 +1,21 @@
-- | Core server-side session support.
module Web.ServerSession.Core
( -- * For serversession storage backends
SessionId
, Session(..)
, Storage(..)
-- * For serversession frontends
, SessionMap
, State(..)
, createState
, setAuthKey
, loadSession
, saveSession
, SaveSessionToken
, forceInvalidateKey
-- ** To be re-exported by frontends
, ForceInvalidate(..)
) where
import Web.ServerSession.Core.Internal

336
serversession/src/Web/ServerSession/Core/Internal.hs Normal file
View File

@ -0,0 +1,336 @@
-- | Internal module exposing the guts of the package. Use at
-- your own risk. No API stability guarantees apply.
module Web.ServerSession.Core.Internal
( SessionId(..)
, checkSessionId
, generateSessionId
, SessionMap
, Session(..)
, Storage(..)
, State(..)
, createState
, setAuthKey
, loadSession
, saveSession
, SaveSessionToken(..)
, invalidateIfNeeded
, DecomposedSession
, decomposeSession
, saveSessionOnDb
, toSessionMap
, forceInvalidateKey
, ForceInvalidate(..)
) where
import Control.Monad (guard, when)
import Control.Monad.IO.Class (MonadIO(..))
import Data.ByteString (ByteString)
import Data.Maybe (isJust)
import Data.Text (Text)
import Data.Time (UTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..))
import qualified Crypto.Nonce as N
import qualified Data.Aeson as A
import qualified Data.ByteString.Base64.URL as B64URL
import qualified Data.ByteString.Char8 as B8
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
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 (B8.length decoded == 18)
return $ S $ T.toLower text
-- | Securely generate a new SessionId.
generateSessionId :: N.Generator -> IO SessionId
generateSessionId = fmap S . N.nonce128urlT
----------------------------------------------------------------------
-- | A session map.
--
-- This is the representation of a session used by the
-- @serversession@ family of packages, transferring data between
-- this core package and frontend packages. Serversession
-- storage backend packages should use 'Session'. End users
-- should use their web framework's support for sessions.
type SessionMap = M.Map Text ByteString
-- | Representation of a saved session.
--
-- This representation is used by the @serversession@ family of
-- packages, transferring data between this core package and
-- storage backend packages. Serversession frontend packages
-- should use 'SessionMap'. End users should use their web
-- framework's support for sessions.
data Session =
Session
{ sessionKey :: SessionId
-- ^ Session ID, primary key.
, sessionAuthId :: Maybe ByteString
-- ^ Value of 'authKey' 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 ()
----------------------------------------------------------------------
-- 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.
--
-- * A reference to the storage backend.
--
-- * Authentication session variable ('setAuthKey').
--
-- Create a new 'State' using 'createState'.
data State s =
State
{ generator :: !N.Generator
, storage :: !s
, authKey :: Text
} 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
<*> return "_ID"
-- | Set the name of the session variable that keeps track of the
-- logged user. Defaults to \"_ID\".
setAuthKey :: State s -> Text -> State s
setAuthKey state val = state { authKey = val }
-- | Load the session map from the storage backend. The value of
-- the session cookie should be given as argument if present.
--
-- Returns:
--
-- * The 'SessionMap' to be used by the frontend as the current
-- session's value.
--
-- * Information to be passed back to 'saveSession' on the end
-- of the request in order to save the session.
loadSession :: Storage s => State s -> Maybe ByteString -> IO (SessionMap, SaveSessionToken)
loadSession state mcookieVal = do
let maybeInputId = mcookieVal >>= fromPathPiece . TE.decodeUtf8
get = runTransactionM (storage state) . getSession (storage state)
maybeInput <- maybe (return Nothing) get maybeInputId
let inputSessionMap = maybe M.empty (toSessionMap state) maybeInput
return (inputSessionMap, SaveSessionToken maybeInput)
-- | Opaque token containing the necessary information for
-- 'saveSession' to save the session.
newtype SaveSessionToken = SaveSessionToken (Maybe Session)
-- | Save the session on the storage backend. A
-- 'SaveSessionToken' given by 'loadSession' is expected besides
-- the new contents of the session.
saveSession :: Storage s => State s -> SaveSessionToken -> SessionMap -> IO SessionId
saveSession state (SaveSessionToken maybeInput) wholeOutputSessionMap =
runTransactionM (storage state) $ do
let decomposedSessionMap = decomposeSession state wholeOutputSessionMap
newMaybeInput <- invalidateIfNeeded state maybeInput decomposedSessionMap
saveSessionOnDb state newMaybeInput decomposedSessionMap
-- | 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 special variables taken apart.
data DecomposedSession =
DecomposedSession
{ dsAuthId :: !(Maybe ByteString)
, dsForceInvalidate :: !ForceInvalidate
, dsSessionMap :: !SessionMap
} deriving (Show, Typeable)
-- | Decompose a session (see 'DecomposedSession').
decomposeSession :: State s -> SessionMap -> DecomposedSession
decomposeSession state sm1 =
let (authId, sm2) = M.updateLookupWithKey (\_ _ -> Nothing) (authKey state) 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 'SessionMap' from a 'Session'.
toSessionMap :: State s -> Session -> SessionMap
toSessionMap state Session {..} =
maybe id (M.insert $ authKey state) sessionAuthId sessionData
-- | 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)

18
serversession/src/Yesod/Persist/Session.hs
View File

@ -1,18 +0,0 @@
-- | 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

266
serversession/src/Yesod/Persist/Session/Internal/Backend.hs
View File

@ -1,266 +0,0 @@
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. <http://www.acrossecurity.com/papers/session_fixation.pdf>).
--
-- 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

184
serversession/src/Yesod/Persist/Session/Internal/Types.hs
View File

@ -1,184 +0,0 @@
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