New serversession-frontend-snap package.

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

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.

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.

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 <felipe.lessa@gmail.com>
+maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
+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 <http://www.stackage.org/package/serversession-frontend-snap>
+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

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

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