wai-session-maybe (empty) → 1.0.0

raw patch · 6 files changed

+243/−0 lines, 6 filesdep +StateVardep +basedep +blaze-buildersetup-changed

Dependencies added: StateVar, base, blaze-builder, bytestring, bytestring-builder, containers, cookie, entropy, http-types, time, transformers, vault, wai

Files

COPYING +13/−0
Network/Wai/Session/Maybe.hs +101/−0
Network/Wai/Session/Maybe/Map.hs +62/−0
README +10/−0
Setup.hs +3/−0
wai-session-maybe.cabal +54/−0

+ COPYING view

@@ -0,0 +1,13 @@+Copyright © 2012, Stephen Paul Weber <singpolyma.net>++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES+WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR+ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES+WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN+ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF+OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.

+ Network/Wai/Session/Maybe.hs view

@@ -0,0 +1,101 @@+{-# LANGUAGE CPP #-}+module Network.Wai.Session.Maybe (Session, SessionStore, withSession, genSessionId) where++import Data.Monoid (mconcat)+import Data.String (fromString)+import Control.Monad.IO.Class (liftIO)+import Network.HTTP.Types (ResponseHeaders)+import Network.Wai (Middleware, Request(..))+#if MIN_VERSION_wai(3,0,0)+import Network.Wai.Internal (Response(ResponseBuilder,ResponseFile,ResponseStream,ResponseRaw))+#else+import Network.Wai.Internal (Response(ResponseBuilder,ResponseFile,ResponseSource))+#endif+import Web.Cookie (parseCookies, renderSetCookie, SetCookie(..))++#if MIN_VERSION_vault(0,3,0)+import Data.Vault.Lazy (Key)+import qualified Data.Vault.Lazy as Vault+#else+import Data.Vault (Key)+import qualified Data.Vault as Vault+#endif+import Data.ByteString (ByteString, foldr')+import Data.ByteString.Lazy (toStrict)+import Data.ByteString.Builder (word8Hex, toLazyByteString)+import qualified Blaze.ByteString.Builder as Builder++import System.Entropy (getEntropy)++-- | Type representing a single session (a lookup, insert pair)+type Session m k v = ((k -> m (Maybe v)), (k -> v -> m ()))++-- | A 'SessionStore' takes in the contents of the cookie (if there was one)+-- and returns a ('Session', 'IO' action to get new contents for cookie) pair+type SessionStore m k v = (Maybe ByteString -> IO (Session m k v, IO (Maybe ByteString)))++-- | Fully parameterised middleware for cookie-based sessions+withSession ::+	SessionStore m k v+	-- ^ The 'SessionStore' to use for sessions+	-> ByteString+	-- ^ Name to use for the session cookie (MUST BE ASCII)+	-> SetCookie+	-- ^ Settings for the cookie (path, expiry, etc)+	-> Key (Session m k v)+	-- ^ 'Data.Vault.Vault' key to use when passing the session through+	-> Middleware+#if MIN_VERSION_wai(3,0,0)+withSession sessions cookieName cookieDefaults vkey app req respond = do+#else+withSession sessions cookieName cookieDefaults vkey app req = do+#endif+	(session, getNewCookie) <- liftIO $ sessions $ lookup cookieName =<< cookies+#if MIN_VERSION_wai(3,0,0)+	app (req {vault = Vault.insert vkey session (vault req)}) (\r -> do+			mNewCookieVal <- liftIO getNewCookie+			case mNewCookieVal of+				Just newCookieVal ->+					respond $ mapHeader (\hs -> (setCookie, newCookie newCookieVal):hs) r+				Nothing ->+					respond r+		)+#else+	resp <- app (req {vault = Vault.insert vkey session (vault req)})+	mNewCookieVal <- liftIO getNewCookie+	case mNewCookieVal of+		Just newCookieVal ->+			return $ mapHeader (\hs -> (setCookie, newCookie newCookieVal):hs) resp+		Nothing ->+			return resp+#endif+	where+	newCookie v = Builder.toByteString $ renderSetCookie $ cookieDefaults {+			setCookieName = cookieName, setCookieValue = v+		}+	cookies = fmap parseCookies $ lookup ciCookie (requestHeaders req)+	setCookie = fromString "Set-Cookie"+	ciCookie = fromString "Cookie"++-- | Simple session ID generator using cryptographically strong random IDs+--+-- Useful for session stores that use session IDs.+genSessionId :: IO ByteString+genSessionId = do+	randBytes <- getEntropy 32+	return $ prettyPrint randBytes+	where+	prettyPrint :: ByteString -> ByteString+	prettyPrint = toStrict . toLazyByteString . mconcat . Data.ByteString.foldr'+		( \ byte acc -> word8Hex byte:acc ) []++-- | Run a function over the headers in a 'Response'+mapHeader :: (ResponseHeaders -> ResponseHeaders) -> Response -> Response+mapHeader f (ResponseFile s h b1 b2) = ResponseFile s (f h) b1 b2+mapHeader f (ResponseBuilder s h b) = ResponseBuilder s (f h) b+#if MIN_VERSION_wai(3,0,0)+mapHeader f (ResponseStream s h b) = ResponseStream s (f h) b+mapHeader f (ResponseRaw io resp) = ResponseRaw io (mapHeader f resp)+#else+mapHeader f (ResponseSource s h b) = ResponseSource s (f h) b+#endif

+ Network/Wai/Session/Maybe/Map.hs view

@@ -0,0 +1,62 @@+{-# LANGUAGE CPP, FlexibleContexts #-}+module Network.Wai.Session.Maybe.Map (mapStore, mapStore_) where++import Control.Monad+import Data.StateVar+import Data.ByteString (ByteString)+import Control.Monad.IO.Class (liftIO, MonadIO)+import Data.IORef+import Network.Wai.Session.Maybe (Session, SessionStore, genSessionId)++import Data.Map (Map)+import qualified Data.Map as Map++-- | Simple session store based on threadsafe 'Data.IORef.IORef's and+-- 'Data.Map.Map'.  This only works if your application server remains+-- running (such as with warp).  All data is lost when the server+-- terminates (bad for CGI).+--+-- WARNING: This session is vulnerable to sidejacking,+-- use with TLS for security.+mapStore :: (Ord k, MonadIO m) =>+	IO ByteString+	-- ^ 'IO' action to generate unique session IDs+	-> IO (SessionStore m k v)+mapStore gen =+	liftM (mapStore' gen) (newThreadSafeStateVar Map.empty)+	where+	mapStore' _ ssv (Just k) = do+		m <- get ssv+		case Map.lookup k m of+			Just sv -> return (sessionFromMapStateVar sv, return (Just k))+			-- Could not find key, so it's as if we were not sent one+			Nothing -> mapStore' gen ssv Nothing+	mapStore' genNewKey ssv Nothing = do+		newKey <- genNewKey+		sv <- newThreadSafeStateVar Map.empty+		ssv $~ Map.insert newKey sv+		return (sessionFromMapStateVar sv, return (Just newKey))++-- | Store using simple session ID generator based on time and 'Data.Unique'+mapStore_ :: (Ord k, MonadIO m) => IO (SessionStore m k v)+mapStore_ = mapStore genSessionId++newThreadSafeStateVar :: a -> IO (StateVar a)+newThreadSafeStateVar a = do+	ref <- newIORef a+	return $ makeStateVar+		(atomicModifyIORef ref (\x -> (x,x)))+		(\x -> atomicModifyIORef ref (const (x,())))++#if MIN_VERSION_StateVar(1,1,0)+sessionFromMapStateVar :: (Ord k, MonadIO m) =>+	StateVar (Map k v) ->+#else+sessionFromMapStateVar :: (HasGetter sv, HasSetter sv, Ord k, MonadIO m) =>+	sv (Map k v) ->+#endif+	Session m k v+sessionFromMapStateVar sv = (+		(\k -> liftIO (Map.lookup k `liftM` get sv)),+		(\k v -> liftIO (sv $~ Map.insert k v))+	)

+ README view

@@ -0,0 +1,10 @@+Provides a generic, cookie-based middleware for sessions that is+parameterised over the session store, the cookie name, and the+cookie parameters (such as path, expiry, etc).  Passes a pair of+functions (lookup key, set key) for the current session through the+'Vault' in the 'Request'.++Also provides a simple example session store based on threadsafe+'IORef's and 'Data.Map'.++See example/Main.hs in git for example usage.

+ Setup.hs view

@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain

+ wai-session-maybe.cabal view

@@ -0,0 +1,54 @@+name:            wai-session-maybe+version:         1.0.0+cabal-version:   >= 1.10+license:         OtherLicense+license-file:    COPYING+category:        Web+copyright:       © 2012 Stephen Paul Weber+author:          Stephen Paul Weber <singpolyma@singpolyma.net>+maintainer:      support@digitallyinduced.com+stability:       experimental+tested-with:     GHC == 7.0.3+synopsis:        Flexible session middleware for WAI+homepage:        https://github.com/digitallyinduced/wai-session-maybe+bug-reports:     https://github.com/digitallyinduced/wai-session-maybe/issues+build-type:      Simple+description:+        Provides a generic, cookie-based middleware for sessions that is+        parameterised over the session store, the cookie name, and the+        cookie parameters (such as path, expiry, etc).  Passes a pair of+        functions (lookup key, set key) for the current session through the+        'Vault' in the 'Request'.+        .+        Also provides a simple example session store based on threadsafe+        'IORef's and 'Data.Map'.+        .+        See example/Main.hs in git for example usage.++extra-source-files:+        README++library+        default-language: Haskell2010+        exposed-modules:+                Network.Wai.Session.Maybe,+                Network.Wai.Session.Maybe.Map++        build-depends:+                base == 4.*,+                containers,+                bytestring,+                bytestring-builder,+                entropy,+                transformers,+                time,+                StateVar,+                vault,+                cookie,+                wai >= 2.0.0,+                http-types,+                blaze-builder++source-repository head+        type:     git+        location: https://github.com/digitallyinduced/wai-session-maybe.git