diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/serversession-frontend-wai.cabal b/serversession-frontend-wai.cabal new file mode 100644 --- /dev/null +++ b/serversession-frontend-wai.cabal @@ -0,0 +1,44 @@ +name: serversession-frontend-wai +version: 1.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa +maintainer: Felipe Lessa +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 +extra-source-files: README.md + +library + hs-source-dirs: src + build-depends: + base >= 4.6 && < 5 + , bytestring + , cookie >= 0.4 + , data-default + , path-pieces + , text + , time + , transformers + , unordered-containers + , vault + , wai + , wai-session == 0.3.* + + , serversession == 1.0.* + exposed-modules: + Web.ServerSession.Frontend.Wai + Web.ServerSession.Frontend.Wai.Internal + extensions: + FlexibleContexts + OverloadedStrings + TypeFamilies + ghc-options: -Wall + +source-repository head + type: git + location: https://github.com/yesodweb/serversession diff --git a/src/Web/ServerSession/Frontend/Wai.hs b/src/Web/ServerSession/Frontend/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Frontend/Wai.hs @@ -0,0 +1,34 @@ +-- | @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 + , KeyValue(..) + -- * State configuration + , setCookieName + , setAuthKey + , setIdleTimeout + , setAbsoluteTimeout + , setTimeoutResolution + , setPersistentCookies + , setHttpOnlyCookies + , setSecureCookies + , State + ) where + +import Web.ServerSession.Core +import Web.ServerSession.Frontend.Wai.Internal diff --git a/src/Web/ServerSession/Frontend/Wai/Internal.hs b/src/Web/ServerSession/Frontend/Wai/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Web/ServerSession/Frontend/Wai/Internal.hs @@ -0,0 +1,154 @@ +-- | 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 + , KeyValue(..) + , createCookieTemplate + , calculateMaxAge + , forceInvalidate + ) where + +import Control.Applicative ((<$>)) +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.HashMap.Strict as HM +import qualified Data.IORef as I +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 + :: (Functor m, MonadIO m, MonadIO n, Storage sto, SessionData sto ~ SessionMap) + => V.Key (WS.Session m Text ByteString) -- ^ 'V.Vault' key to use when passing the session through. + -> (State sto -> State sto) -- ^ Set any options on the @serversession@ state. + -> sto -- ^ 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. +-- +-- As @wai-session@ always requires a value to be provided, we +-- return an empty @ByteString@ when the empty session was not +-- saved. +sessionStore + :: (Functor m, MonadIO m, Storage sto, KeyValue (SessionData sto)) + => State sto -- ^ @serversession@ state, incl. storage backend. + -> WS.SessionStore m (Key (SessionData sto)) (Value (SessionData sto)) + -- ^ @wai-session@ session store. +sessionStore state = + \mcookieVal -> do + (data1, saveSessionToken) <- loadSession state mcookieVal + sessionRef <- I.newIORef data1 + let save = do + data2 <- I.atomicModifyIORef' sessionRef $ \a -> (a, a) + msession <- saveSession state saveSessionToken data2 + return $ maybe "" (TE.encodeUtf8 . toPathPiece . sessionKey) msession + return (mkSession sessionRef, save) + + +-- | Build a 'WS.Session' from an 'I.IORef' containing the +-- session data. +mkSession :: (Functor m, MonadIO m, KeyValue sess) => I.IORef sess -> WS.Session m (Key sess) (Value sess) +mkSession sessionRef = + -- We need to use atomicModifyIORef instead of readIORef + -- because latter may be reordered (cf. "Memory Model" on + -- Data.IORef's documentation). + ( \k -> kvLookup k <$> liftIO (I.atomicModifyIORef' sessionRef $ \a -> (a, a)) + , \k v -> liftIO (I.atomicModifyIORef' sessionRef $ flip (,) () . kvInsert k v) + ) + + +---------------------------------------------------------------------- + + +-- | Class for session data types that can be used as key-value +-- stores. +class IsSessionData sess => KeyValue sess where + type Key sess :: * + type Value sess :: * + kvLookup :: Key sess -> sess -> Maybe (Value sess) + kvInsert :: Key sess -> Value sess -> sess -> sess + + +instance KeyValue SessionMap where + type Key SessionMap = Text + type Value SessionMap = ByteString + kvLookup k = HM.lookup k . unSessionMap + kvInsert k v (SessionMap m) = SessionMap (HM.insert k v m) + + +---------------------------------------------------------------------- + + +-- | 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 sto -> 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 sto -> 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. ). +forceInvalidate :: WS.Session m Text ByteString -> ForceInvalidate -> m () +forceInvalidate (_, insert) = insert forceInvalidateKey . B8.pack . show