happstack-clientsession (empty) → 7.0.0

raw patch · 4 files changed

+211/−0 lines, 4 filesdep +basedep +bytestringdep +cerealsetup-changed

Dependencies added: base, bytestring, cereal, clientsession, happstack-server, mtl, safecopy

Files

COPYING +29/−0
Setup.hs +3/−0
happstack-clientsession.cabal +32/−0
src/Happstack/Server/ClientSession.hs +147/−0

+ COPYING view

@@ -0,0 +1,29 @@+Copyright (c) 2012 Dag Odenhall+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++Redistributions of source code must retain the above copyright+notice, this list of conditions and the following disclaimer.++Redistributions in binary form must reproduce the above copyright+notice, this list of conditions and the following disclaimer in the+documentation and/or other materials provided with the distribution.++Neither the name of the HAppS.org; nor the names of its contributors+may be used to endorse or promote products derived from this software+without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT OWNER OR+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,+EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,+PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR+PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING+NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks simpleUserHooks

+ happstack-clientsession.cabal view

@@ -0,0 +1,32 @@+Name          : happstack-clientsession+Version       : 7.0.0+License       : BSD3+License-file  : COPYING+Synopsis      : client-side session data+Description   : uses the clientsession library to store session data in an HTTP cookie+Author        : Dag Odenhall+Maintainer    : Happstack team <happs@googlegroups.com>+Homepage      : http://happstack.com+Cabal-Version : >= 1.6+Category      : Web, Happstack+Build-Type    : Simple++source-repository head+    type:     darcs+    subdir:   happstack-clientsession+    location: http://patch-tag.com/r/mae/happstack+++Library+  GHC-Options     : -Wall+  Hs-Source-Dirs  : src+  Exposed-Modules :+    Happstack.Server.ClientSession+  Build-Depends   :+    base             == 4.*,+    bytestring       == 0.9.*,+    cereal           == 0.3.*,+    clientsession    == 0.7.*,+    happstack-server == 7.0.*,+    mtl              == 2.0.*,+    safecopy         == 0.6.*

+ src/Happstack/Server/ClientSession.hs view

@@ -0,0 +1,147 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}++module Happstack.Server.ClientSession+  ( ClientSession(..)+  , SessionConf(..)+  , mkSessionConf+  , ClientSessionT+  , runClientSessionT+  , getSession+  , putSession+  , expireSession+  , withSession+  , sessionPart+  ) where++import Control.Applicative   (Applicative, Alternative, optional)+import Control.Monad         (MonadPlus, when)+import Control.Monad.Reader  (ReaderT, runReaderT, ask, asks)+import Control.Monad.State   (StateT, State, evalStateT, runState, get, put)+import Control.Monad.Trans   (MonadIO, liftIO)+import Data.ByteString.Char8 (pack, unpack)+import Data.SafeCopy         (SafeCopy, safeGet, safePut)+import Data.Serialize        (runGet, runPut)+import Happstack.Server      (HasRqData, FilterMonad, WebMonad, ServerMonad, Happstack, Response, CookieLife(Session), Cookie(secure), lookCookieValue, addCookie, mkCookie, expireCookie)+import Web.ClientSession     (Key, decrypt, encryptIO)++-- | Your session type must have an instance for this class.+class SafeCopy st => ClientSession st where+  -- | An empty session, i.e. what you get when there is no existing+  -- session stored.+  empty :: st++data SessionState st = Encoded | Decoded st | Modified st | Expired++-- | Configuration for the session cookie for passing to 'runClientSessionT'.+data SessionConf = SessionConf+    { sessionCookieName :: String      -- ^ Name of the cookie to hold your session data.+    , sessionCookieLife :: CookieLife  -- ^ Lifetime of that cookie.+    , sessionKey        :: Key         -- ^ Encryption key, usually from 'getKey' or 'getDefaultKey'.+    , sessionSecure     :: Bool        -- ^ Only use a session over secure transports.+    }++-- | Create a 'SessionConf' using defaults for everything except+-- 'sessionKey'.  You can use record update syntax to override individual+-- fields.+--+-- > main = do key <- getDefaultKey+-- >           let sessConf = (mkSessionConf key) { sessionCookieLife = oneWeek }+-- >           simpleHTTP nullConf $ runClientSessionT handlers sessConf+-- >   where+-- >     oneWeek  = MaxAge $ 60 * 60 * 24 * 7+-- >     handlers = sessionPart $ msum [...]+mkSessionConf :: Key -> SessionConf+mkSessionConf key = SessionConf+    { sessionCookieName = "Happstack.ClientSession"+    , sessionCookieLife = Session+    , sessionKey        = key+    , sessionSecure     = True+    }++-- | Transformer for monads capable of using a session.+newtype ClientSessionT st m a =+    ClientSessionT { unClientSessionT :: ReaderT SessionConf (StateT (SessionState st) m) a }+  deriving ( Functor, Applicative, Alternative+           , Monad, MonadIO, MonadPlus+           , HasRqData, FilterMonad r, WebMonad r, ServerMonad+           )++instance Happstack m => Happstack (ClientSessionT st m)++-- | Get the inner monad of a 'ClientSessionT'.+runClientSessionT :: Monad m => ClientSessionT st m a -> SessionConf -> m a+runClientSessionT cs sc =+    evalStateT (runReaderT (unClientSessionT cs) sc) Encoded++askCS :: Monad m => ClientSessionT st m SessionConf+askCS = ClientSessionT ask++asksCS :: Monad m => (SessionConf -> a) -> ClientSessionT st m a+asksCS = ClientSessionT . asks++getCS :: Monad m => ClientSessionT st m (SessionState st)+getCS = ClientSessionT get++putCS :: Monad m => SessionState st -> ClientSessionT st m ()+putCS = ClientSessionT . put++-- | Get the session value.  If the cookie has not been decoded yet, it+-- will be decoded.  If no session data is stored or the session has been+-- expired, 'empty' is returned.+getSession :: (Functor m, MonadPlus m, HasRqData m, ClientSession st)+           => ClientSessionT st m st+getSession = do+    ss <- getCS+    case ss of+      Decoded a  -> return a+      Modified a -> return a+      Expired    -> new+      Encoded    -> do a <- getValue+                       putCS $ Decoded a+                       return a+  where+    new      = return empty+    getValue = do name <- asksCS sessionCookieName+                  value <- optional $ lookCookieValue name+                  maybe new decode value+    decode v = do key <- asksCS sessionKey+                  maybe new (either (const new) return . runGet safeGet)+                    . decrypt key $ pack v++-- | Put a new value in the session.+putSession :: (Monad m, ClientSession st) => st -> ClientSessionT st m ()+putSession = putCS . Modified++-- | Expire the session, i.e. the cookie holding it.+expireSession :: Monad m => ClientSessionT st m ()+expireSession = putCS Expired++-- | Run a 'State' monad with the session.+withSession :: (Functor m, MonadPlus m, HasRqData m, ClientSession st, Eq st)+            => State st a -> ClientSessionT st m a+withSession m = do s <- getSession+                   let (a,st) = runState m s+                   when (st /= s) $ putSession st+                   return a++-- | Wrapper around your handlers that use the session.  Takes care of+-- expiring the cookie of an expired session, or encrypting a modified+-- session into the cookie.+sessionPart :: (Functor m, Monad m, MonadIO m, FilterMonad Response m, ClientSession st)+            => ClientSessionT st m a -> ClientSessionT st m a+sessionPart part = do+    a  <- part+    ss <- getCS+    case ss of+      Modified st -> encode st+      Expired     -> expire+      _           -> return ()+    return a+  where+    encode st = do SessionConf{..} <- askCS+                   bytes <- liftIO . encryptIO sessionKey . runPut . safePut $ st+                   addCookie sessionCookieLife $ (mkCookie sessionCookieName $ unpack bytes) { secure = sessionSecure }+    expire    = do name <- asksCS sessionCookieName+                   expireCookie name