From 71aff2dd94f82f69f42f758c67e2f7a32e41db04 Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Sat, 23 May 2015 01:42:13 -0300 Subject: [PATCH] Separate into three different packages. serversession and serversession-backend-persistent build, serversession-frontend-yesod is broken. --- README.md | 163 +++++++++ serversession-backend-persistent/LICENSE | 20 ++ serversession-backend-persistent/README.md | 10 + .../serversession-backend-persistent.cabal | 51 +++ .../Web/ServerSession/Backend/Persistent.hs | 40 +++ .../Backend/Persistent/Internal/Impl.hs | 20 +- .../Backend/Persistent/Internal/Types.hs | 97 +++++ serversession-frontend-yesod/LICENSE | 20 ++ serversession-frontend-yesod/README.md | 6 + .../serversession-frontend-yesod.cabal | 58 +++ .../src/Web/ServerSession/Frontend/Yesod.hs | 5 + .../ServerSession/Frontend/Yesod/Internal.hs | 77 ++++ serversession/README.md | 134 +------ serversession/serversession.cabal | 19 +- serversession/src/Web/ServerSession/Core.hs | 21 ++ .../src/Web/ServerSession/Core/Internal.hs | 336 ++++++++++++++++++ serversession/src/Yesod/Persist/Session.hs | 18 - .../Yesod/Persist/Session/Internal/Backend.hs | 266 -------------- .../Yesod/Persist/Session/Internal/Types.hs | 184 ---------- 19 files changed, 919 insertions(+), 626 deletions(-) create mode 100644 README.md create mode 100644 serversession-backend-persistent/LICENSE create mode 100644 serversession-backend-persistent/README.md create mode 100644 serversession-backend-persistent/serversession-backend-persistent.cabal create mode 100644 serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs rename serversession/src/Yesod/Persist/Session/Internal/Sql.hs => serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs (83%) create mode 100644 serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs create mode 100644 serversession-frontend-yesod/LICENSE create mode 100644 serversession-frontend-yesod/README.md create mode 100644 serversession-frontend-yesod/serversession-frontend-yesod.cabal create mode 100644 serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs create mode 100644 serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs create mode 100644 serversession/src/Web/ServerSession/Core.hs create mode 100644 serversession/src/Web/ServerSession/Core/Internal.hs delete mode 100644 serversession/src/Yesod/Persist/Session.hs delete mode 100644 serversession/src/Yesod/Persist/Session/Internal/Backend.hs delete mode 100644 serversession/src/Yesod/Persist/Session/Internal/Types.hs diff --git a/README.md b/README.md new file mode 100644 index 0000000..ff52d41 --- /dev/null +++ b/README.md @@ -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. diff --git a/serversession-backend-persistent/LICENSE b/serversession-backend-persistent/LICENSE new file mode 100644 index 0000000..cdf4661 --- /dev/null +++ b/serversession-backend-persistent/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/serversession-backend-persistent/README.md b/serversession-backend-persistent/README.md new file mode 100644 index 0000000..cb57b19 --- /dev/null +++ b/serversession-backend-persistent/README.md @@ -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). diff --git a/serversession-backend-persistent/serversession-backend-persistent.cabal b/serversession-backend-persistent/serversession-backend-persistent.cabal new file mode 100644 index 0000000..f42a012 --- /dev/null +++ b/serversession-backend-persistent/serversession-backend-persistent.cabal @@ -0,0 +1,51 @@ +name: serversession-backend-persistent +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +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 +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 diff --git a/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs new file mode 100644 index 0000000..e562041 --- /dev/null +++ b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent.hs @@ -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 diff --git a/serversession/src/Yesod/Persist/Session/Internal/Sql.hs b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs similarity index 83% rename from serversession/src/Yesod/Persist/Session/Internal/Sql.hs rename to serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs index 69a2720..3eaa9f1 100644 --- a/serversession/src/Yesod/Persist/Session/Internal/Sql.hs +++ b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Impl.hs @@ -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'. diff --git a/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs new file mode 100644 index 0000000..e5997eb --- /dev/null +++ b/serversession-backend-persistent/src/Web/ServerSession/Backend/Persistent/Internal/Types.hs @@ -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 diff --git a/serversession-frontend-yesod/LICENSE b/serversession-frontend-yesod/LICENSE new file mode 100644 index 0000000..cdf4661 --- /dev/null +++ b/serversession-frontend-yesod/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/serversession-frontend-yesod/README.md b/serversession-frontend-yesod/README.md new file mode 100644 index 0000000..d3ac566 --- /dev/null +++ b/serversession-frontend-yesod/README.md @@ -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. diff --git a/serversession-frontend-yesod/serversession-frontend-yesod.cabal b/serversession-frontend-yesod/serversession-frontend-yesod.cabal new file mode 100644 index 0000000..6687ced --- /dev/null +++ b/serversession-frontend-yesod/serversession-frontend-yesod.cabal @@ -0,0 +1,58 @@ +name: serversession-frontend-yesod +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +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 +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 diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs new file mode 100644 index 0000000..1b40a5a --- /dev/null +++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod.hs @@ -0,0 +1,5 @@ +module Web.ServerSession.Frontend.Yesod + ( + ) where + +import Web.ServerSession.Frontend.Yesod.Internal diff --git a/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs new file mode 100644 index 0000000..e4f7ca5 --- /dev/null +++ b/serversession-frontend-yesod/src/Web/ServerSession/Frontend/Yesod/Internal.hs @@ -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. ). +-- +-- 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/serversession/README.md b/serversession/README.md index b04b654..497b0ed 100644 --- a/serversession/README.md +++ b/serversession/README.md @@ -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. diff --git a/serversession/serversession.cabal b/serversession/serversession.cabal index 02703f5..ed9a460 100644 --- a/serversession/serversession.cabal +++ b/serversession/serversession.cabal @@ -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 diff --git a/serversession/src/Web/ServerSession/Core.hs b/serversession/src/Web/ServerSession/Core.hs new file mode 100644 index 0000000..4cbcae6 --- /dev/null +++ b/serversession/src/Web/ServerSession/Core.hs @@ -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 diff --git a/serversession/src/Web/ServerSession/Core/Internal.hs b/serversession/src/Web/ServerSession/Core/Internal.hs new file mode 100644 index 0000000..8c4d9c2 --- /dev/null +++ b/serversession/src/Web/ServerSession/Core/Internal.hs @@ -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) diff --git a/serversession/src/Yesod/Persist/Session.hs b/serversession/src/Yesod/Persist/Session.hs deleted file mode 100644 index 2796390..0000000 --- a/serversession/src/Yesod/Persist/Session.hs +++ /dev/null @@ -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 diff --git a/serversession/src/Yesod/Persist/Session/Internal/Backend.hs b/serversession/src/Yesod/Persist/Session/Internal/Backend.hs deleted file mode 100644 index 9b40578..0000000 --- a/serversession/src/Yesod/Persist/Session/Internal/Backend.hs +++ /dev/null @@ -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. ). --- --- 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/serversession/src/Yesod/Persist/Session/Internal/Types.hs b/serversession/src/Yesod/Persist/Session/Internal/Types.hs deleted file mode 100644 index c93ab57..0000000 --- a/serversession/src/Yesod/Persist/Session/Internal/Types.hs +++ /dev/null @@ -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