diff --git a/README.md b/README.md index 9d774b2..2fa9472 100644 --- a/README.md +++ b/README.md @@ -28,6 +28,11 @@ to be paired up with two companion packages: * `serversession-frontend-yesod`: Support the Yesod framework. Replaces the default `clientsession`. + * `serversession-frontend-snap`: Support the Snap framework. + Replaces the default + `Snap.Snaplet.Session.Backends.CookieSession` based on + `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 diff --git a/serversession-frontend-snap/LICENSE b/serversession-frontend-snap/LICENSE new file mode 100644 index 0000000..cdf4661 --- /dev/null +++ b/serversession-frontend-snap/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-snap/README.md b/serversession-frontend-snap/README.md new file mode 100644 index 0000000..42bdaec --- /dev/null +++ b/serversession-frontend-snap/README.md @@ -0,0 +1,6 @@ +# serversession-frontend-snap + +This package provide Snap 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-snap/serversession-frontend-snap.cabal b/serversession-frontend-snap/serversession-frontend-snap.cabal new file mode 100644 index 0000000..22431ce --- /dev/null +++ b/serversession-frontend-snap/serversession-frontend-snap.cabal @@ -0,0 +1,40 @@ +name: serversession-frontend-snap +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +synopsis: Snap 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.* + , bytestring + , containers + , nonce + , path-pieces + , snap == 0.14.* + , snap-core == 0.9.* + , text + , time + , transformers + + , serversession == 1.0.* + exposed-modules: + Web.ServerSession.Frontend.Snap + Web.ServerSession.Frontend.Snap.Internal + extensions: + OverloadedStrings + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/yesodweb/serversession diff --git a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs new file mode 100644 index 0000000..392da5e --- /dev/null +++ b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap.hs @@ -0,0 +1,21 @@ +-- | Snap server-side session support. +module Web.ServerSession.Frontend.Snap + ( -- * Using server-side sessions + initServerSessionManager + , simpleServerSessionManager + -- * Invalidating session IDs + , forceInvalidate + , ForceInvalidate(..) + -- * State configuration + , setCookieName + , setAuthKey + , setIdleTimeout + , setAbsoluteTimeout + , setPersistentCookies + , setHttpOnlyCookies + , setSecureCookies + , State + ) where + +import Web.ServerSession.Core +import Web.ServerSession.Frontend.Snap.Internal diff --git a/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs new file mode 100644 index 0000000..86e9d1d --- /dev/null +++ b/serversession-frontend-snap/src/Web/ServerSession/Frontend/Snap/Internal.hs @@ -0,0 +1,186 @@ +-- | Internal module exposing the guts of the package. Use at +-- your own risk. No API stability guarantees apply. +module Web.ServerSession.Frontend.Snap.Internal + ( initServerSessionManager + , simpleServerSessionManager + , ServerSessionManager(..) + , currentSessionMap + , modifyCurrentSession + , createCookie + , csrfKey + , forceInvalidate + ) where + +import Control.Arrow (first, second) +import Control.Monad.IO.Class (liftIO) +import Data.ByteString (ByteString) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Web.PathPieces (toPathPiece) +import Web.ServerSession.Core + +import qualified Crypto.Nonce as N +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Map as M +import qualified Snap.Core as S +import qualified Snap.Snaplet as S +import qualified Snap.Snaplet.Session as S +import qualified Snap.Snaplet.Session.SessionManager as S + + +-- | Create a new 'ServerSessionManager' using the given 'State'. +initServerSessionManager :: Storage s => IO (State s) -> S.SnapletInit b S.SessionManager +initServerSessionManager mkState = + S.makeSnaplet "ServerSession" + "Snaplet providing sessions via server-side storage." + Nothing $ liftIO $ do + gen <- N.new + st <- mkState + let ssm = ServerSessionManager + { currentSession = Nothing + , state = st + , cookieName = TE.encodeUtf8 $ getCookieName st + , nonceGen = gen + } + return $ S.SessionManager ssm + + +-- | Simplified version of 'initServerSessionManager', sufficient +-- for most needs. +simpleServerSessionManager :: Storage s => IO s -> (State s -> State s) -> S.SnapletInit b S.SessionManager +simpleServerSessionManager mkStorage opts = + initServerSessionManager (fmap opts . createState =<< mkStorage) + + +-- | A 'S.ISessionManager' using server-side sessions. +data ServerSessionManager s = + ServerSessionManager + { currentSession :: Maybe (SessionMap, SaveSessionToken) + -- ^ Field used for per-request caching of the session. + , state :: State s + -- ^ The core @serversession@ state. + , cookieName :: ByteString + -- ^ Cache of the cookie name as bytestring. + , nonceGen :: N.Generator + -- ^ Nonce generator for the CSRF token. + } deriving (Typeable) + + +instance Storage s => S.ISessionManager (ServerSessionManager s) where + load ssm = do + -- Get session ID from cookie. + mcookie <- S.getCookie (cookieName ssm) + -- Load session from storage backend. + (sessionMap, saveSessionToken) <- + liftIO $ loadSession (state ssm) (S.cookieValue <$> mcookie) + -- Add CSRF token if needed. + sessionMap' <- + maybe + (flip (M.insert csrfKey) sessionMap <$> N.nonce128url (nonceGen ssm)) + (const $ return sessionMap) + (M.lookup csrfKey sessionMap) + -- Good to go! + return ssm { currentSession = Just (sessionMap', saveSessionToken) } + + commit ssm = do + -- Save session data to storage backend and set the cookie. + let Just (sessionMap, saveSessionToken) = currentSession ssm + session <- liftIO $ saveSession (state ssm) saveSessionToken sessionMap + S.modifyResponse $ S.addResponseCookie $ createCookie (state ssm) (cookieName ssm) session + + reset ssm = do + -- Reset has no defined semantics. We invalidate the session + -- and clear its variables, which seems to be what the + -- current clientsession backend from the snap package does. + csrfToken <- N.nonce128url (nonceGen ssm) + let newSession = M.fromList [ (forceInvalidateKey, B8.pack $ show CurrentSessionId) + , (csrfKey, csrfToken) ] + return $ modifyCurrentSession (const newSession) ssm + + touch = + -- We always touch the session (if commit is called). + id + + insert key value = modifyCurrentSession (M.insert key (TE.encodeUtf8 value)) + + lookup key = + -- Decoding will always succeed if the session is used only + -- from snap. + fmap TE.decodeUtf8 . M.lookup key . currentSessionMap "lookup" + + delete key = modifyCurrentSession (M.delete key) + + csrf = + -- Guaranteed to succeed since both load and reset add a + -- csrfKey to the session map. + fromMaybe (error "serversession-frontend-snap/csrf: never here") . + S.lookup csrfKey + + toList = + -- Remove the CSRF key from the list as the current + -- clientsession backend doesn't return it. + fmap (second TE.decodeUtf8) . + M.toList . + M.delete csrfKey . + currentSessionMap "toList" + + +-- | Get the current 'SessionMap' from 'currentSession' and +-- unwrap its @Just@. If it's @Nothing@, @error@ is called. We +-- expect 'load' to be called before any other 'ISessionManager' +-- method. +currentSessionMap :: String -> ServerSessionManager s -> SessionMap +currentSessionMap fn ssm = maybe (error err) fst (currentSession ssm) + where err = "serversession-frontend-snap/" ++ fn ++ + ": currentSession is Nothing, did you call 'load'?" + + +-- | Modify the current session in any way. +modifyCurrentSession :: (SessionMap -> SessionMap) -> ServerSessionManager s -> ServerSessionManager s +modifyCurrentSession f ssm = ssm { currentSession = fmap (first f) (currentSession ssm) } + + +-- | Create a cookie for the given session. +-- +-- The cookie expiration is set via 'nextExpires'. Note that +-- this is just an optimization, as the expiration is checked on +-- the server-side as well. +createCookie :: State s -> ByteString -> Session -> S.Cookie +createCookie st cookieNameBS session = + -- Generate a cookie with the final session ID. + S.Cookie + { S.cookieName = cookieNameBS + , S.cookieValue = TE.encodeUtf8 $ toPathPiece $ sessionKey session + , S.cookiePath = Just "/" + , S.cookieExpires = cookieExpires st session + , S.cookieDomain = Nothing + , S.cookieHttpOnly = getHttpOnlyCookies st + , S.cookieSecure = getSecureCookies st + } + + +-- | The CSRF key is kept as a session variable like any other +-- under this key. +csrfKey :: Text +csrfKey = "_CSRF" + + +-- | 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 when +-- the session is 'commit'ed. This means that later calls to +-- 'forceInvalidate' on the same handler will override earlier +-- calls. +-- +-- This function works by setting a session variable that is +-- checked when saving the session. The session variable set by +-- this function is then discarded and is not persisted across +-- requests. +forceInvalidate :: ForceInvalidate -> S.Handler b S.SessionManager () +forceInvalidate = S.setInSession forceInvalidateKey . T.pack . show