Initial stab at serversession-frontend-wai.

README.md

@@ -36,6 +36,10 @@ to be paired up with two companion packages:
       `Snap.Snaplet.Session.Backends.CookieSession` based on
       `clientsession`.
 
+    * `serversession-frontend-wai`: Generic support for WAI
+      applications via the `wai-session` package by using a
+      `vault`.
+
 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-wai/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-wai/README.md

@@ -0,0 +1,6 @@
+# serversession-frontend-wai
+
+This package provide WAI 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-wai/serversession-frontend-wai.cabal

@@ -0,0 +1,42 @@
+name:            serversession-frontend-wai
+version:         1.0
+license:         MIT
+license-file:    LICENSE
+author:          Felipe Lessa <felipe.lessa@gmail.com>
+maintainer:      Felipe Lessa <felipe.lessa@gmail.com>
+synopsis:        wai-session 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-wai>
+extra-source-files: README.md
+
+library
+  hs-source-dirs: src
+  build-depends:
+      base                      >= 4.6   && < 5
+    , bytestring
+    , containers
+    , cookie                    >= 0.4
+    , data-default
+    , path-pieces
+    , text
+    , time
+    , transformers
+    , vault
+    , wai
+    , wai-session               == 0.3.*
+
+    , serversession             == 1.0.*
+  exposed-modules:
+    Web.ServerSession.Frontend.Wai
+    Web.ServerSession.Frontend.Wai.Internal
+  extensions:
+    OverloadedStrings
+  ghc-options:     -Wall
+
+source-repository head
+  type:     git
+  location: https://github.com/yesodweb/serversession

serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai.hs

@@ -0,0 +1,32 @@
+-- | @wai-session@ server-side session support.
+--
+-- Please note that this frontend has some limitations:
+--
+--   * Cookies use the @Max-age@ field instead of @Expires@.  The
+--   @Max-age@ field is not supported by all browsers: some
+--   browsers will treat them as non-persistent cookies.
+--
+--   * Also, the @Max-age@ is fixed and does not take a given a
+--   session into consideration.
+module Web.ServerSession.Frontend.Wai
+  ( -- * Simple interface
+    withServerSession
+    -- * Invalidating session IDs
+  , forceInvalidate
+  , ForceInvalidate(..)
+    -- * Flexible interface
+  , sessionStore
+  , createCookieTemplate
+    -- * State configuration
+  , setCookieName
+  , setAuthKey
+  , setIdleTimeout
+  , setAbsoluteTimeout
+  , setPersistentCookies
+  , setHttpOnlyCookies
+  , setSecureCookies
+  , State
+  ) where
+
+import Web.ServerSession.Core
+import Web.ServerSession.Frontend.Wai.Internal

serversession-frontend-wai/src/Web/ServerSession/Frontend/Wai/Internal.hs

@@ -0,0 +1,122 @@
+-- | Internal module exposing the guts of the package.  Use at
+-- your own risk.  No API stability guarantees apply.
+module Web.ServerSession.Frontend.Wai.Internal
+  ( withServerSession
+  , sessionStore
+  , mkSession
+  , createCookieTemplate
+  , calculateMaxAge
+  , forceInvalidate
+  ) where
+
+import Control.Monad (guard)
+import Control.Monad.IO.Class (MonadIO(..))
+import Data.ByteString (ByteString)
+import Data.Default (def)
+import Data.Text (Text)
+import Web.PathPieces (toPathPiece)
+import Web.ServerSession.Core
+import Web.ServerSession.Core.Internal (absoluteTimeout, idleTimeout, persistentCookies)
+
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.IORef as I
+import qualified Data.Map as M
+import qualified Data.Text.Encoding as TE
+import qualified Data.Time as TI
+import qualified Data.Vault.Lazy as V
+import qualified Network.Wai as W
+import qualified Network.Wai.Session as WS
+import qualified Web.Cookie as C
+
+
+-- | Construct the @wai-session@ middleware using the given
+-- storage backend and options.  This is a convenient function
+-- that uses 'WS.withSession', 'createState', 'sessionStore',
+-- 'getCookieName' and 'createCookieTemplate'.
+withServerSession
+  :: (MonadIO m, MonadIO n, Storage s)
+  => V.Key (WS.Session m Text ByteString) -- ^ 'V.Vault' key to use when passing the session through.
+  -> (State s -> State s)                 -- ^ Set any options on the @serversession@ state.
+  -> s                                    -- ^ Storage backend.
+  -> n W.Middleware
+withServerSession key opts storage = liftIO $ do
+  st <- opts <$> createState storage
+  return $
+    WS.withSession
+      (sessionStore st)
+      (TE.encodeUtf8 $ getCookieName st)
+      (createCookieTemplate st)
+      key
+
+
+-- | Construct the @wai-session@ session store using the given
+-- state.  Note that keys and values types are fixed.
+sessionStore
+  :: (MonadIO m, Storage s)
+  => State s                           -- ^ @serversession@ state, incl. storage backend.
+  -> WS.SessionStore m Text ByteString -- ^ @wai-session@ session store.
+sessionStore state =
+  \mcookieVal -> do
+    (sessionMap, saveSessionToken) <- loadSession state mcookieVal
+    sessionRef <- I.newIORef sessionMap
+    let save = do
+          sessionMap' <- I.readIORef sessionRef
+          session <- saveSession state saveSessionToken sessionMap'
+          return $ TE.encodeUtf8 $ toPathPiece $ sessionKey session
+    return (mkSession sessionRef, save)
+
+
+-- | Build a 'WS.Session' from an 'I.IORef' containing the
+-- session data.
+mkSession :: MonadIO m => I.IORef SessionMap -> WS.Session m Text ByteString
+mkSession sessionRef =
+  ( \k   -> M.lookup k <$> liftIO (I.readIORef sessionRef)
+  , \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . M.insert k v)
+  )
+
+
+-- | Create a cookie template given a state.
+--
+-- Since we don't have access to the 'Session', we can't fill the
+-- @Expires@ field.  Besides, as the template is constant,
+-- eventually the @Expires@ field would become outdated.  This is
+-- a limitation of @wai-session@'s interface, not a
+-- @serversession@ limitation.  Other frontends support the
+-- @Expires@ field.
+--
+-- Instead, we fill only the @Max-age@ field.  It works fine for
+-- modern browsers, but many don't support it and will treat the
+-- cookie as non-persistent (notably IE 6, 7 and 8).
+createCookieTemplate :: State s -> C.SetCookie
+createCookieTemplate state =
+  -- Generate a cookie with the final session ID.
+  def
+    { C.setCookiePath     = Just "/"
+    , C.setCookieMaxAge   = calculateMaxAge state
+    , C.setCookieDomain   = Nothing
+    , C.setCookieHttpOnly = getHttpOnlyCookies state
+    , C.setCookieSecure   = getSecureCookies state
+    }
+
+
+-- | Calculate the @Max-age@ of a cookie template for the given
+-- state.
+--
+--   * If the state asks for non-persistent sessions, the result
+--   is @Nothing@.
+--
+--   * If no timeout is defined, the result is 10 years.
+--
+--   * Otherwise, the max age is set as the maximum timeout.
+calculateMaxAge :: State s -> Maybe TI.DiffTime
+calculateMaxAge st = do
+  guard (persistentCookies st)
+  return $ maybe (60*60*24*3652) realToFrac
+         $ idleTimeout st `max` absoluteTimeout st
+
+
+-- | 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>).
+forceInvalidate :: WS.Session m Text ByteString -> ForceInvalidate -> m ()
+forceInvalidate (_, insert) = insert forceInvalidateKey . B8.pack . show