scotty-session (empty) → 0.0.1

raw patch · 3 files changed

+157/−0 lines, 3 filesdep +basedep +base64-bytestringdep +blaze-buildersetup-changed

Dependencies added: base, base64-bytestring, blaze-builder, bytestring, crypto-api, http-types, old-locale, scotty, stm, text, time, transformers, unordered-containers, wai

Files

• Setup.hs +2/−0
• Web/Scotty/Session.hs +126/−0
• scotty-session.cabal +29/−0

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

@@ -0,0 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Scotty.Session+    ( createSessionManager+    , modifySession+    , readSession+    , ScottySM+    )+where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad.IO.Class (liftIO)+import Data.Monoid+import Control.Arrow++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Encoding as TEnc+import qualified Data.HashMap.Strict as HM++import Crypto.Random (newGenIO, genBytes, SystemRandom)+import Crypto.Types (ByteLength)+import qualified Data.ByteString.Base64 as B64++import Network.Wai++import Data.Time.Clock+import Data.Time.Format+import System.Locale (defaultTimeLocale)++import Web.Scotty++data Session a+   = Session+   { sess_id         :: T.Text+   , sess_validUntil :: UTCTime+   , sess_content    :: Maybe a+   } deriving (Show, Eq)+type SessionJar a = TVar (HM.HashMap T.Text (Session a))++newtype ScottySM a = ScottySM { _unSessionManager :: SessionJar a }++-- | Create a new session manager+createSessionManager :: ScottyM (ScottySM a)+createSessionManager =+    do storage <- liftIO $ atomically $ newTVar (HM.empty)+       liftIO $ forkIO $ maintainSessions storage+       return $ ScottySM storage++-- | Modify the current users session+modifySession :: ScottySM a -> (Maybe a -> Maybe a) -> ActionM ()+modifySession sm@(ScottySM storage) fun =+    do oldS <- readSession' sm id+       let newS = oldS { sess_content = fun (sess_content oldS) }+       liftIO $ insertSession newS storage++-- | Read the current users session+readSession :: ScottySM a -> ActionM (Maybe a)+readSession sm = readSession' sm sess_content++readSession' :: ScottySM a -> (Session a -> b) -> ActionM b+readSession' (ScottySM storage) fun =+    do mSession <- loadSession storage+       case mSession of+         Just s -> return $ fun s+         Nothing ->+             do newS <- liftIO $ createSession+                liftIO $ insertSession newS storage+                setCookie newS+                return $ fun newS++sessionTTL :: NominalDiffTime+sessionTTL = 36000 -- in seconds++sessionIdEntropy :: ByteLength+sessionIdEntropy = 12++createSession :: IO (Session a)+createSession =+    do gen <- g+       sid <- case genBytes sessionIdEntropy gen of+                 Left err -> fail $ show err+                 Right (x, _) -> return $ TEnc.decodeUtf8 $ B64.encode x+       now <- getCurrentTime+       let validUntil = addUTCTime sessionTTL now+       return $ Session sid validUntil Nothing+    where g = newGenIO :: IO SystemRandom++insertSession :: Session a -> SessionJar a -> IO ()+insertSession sess sessions =+    atomically $ modifyTVar sessions $ \m -> HM.insert (sess_id sess) sess m++getSession :: T.Text -> SessionJar a -> IO (Maybe (Session a))+getSession sessId sessions =+    do s <- atomically $ readTVar sessions+       return $ HM.lookup sessId s++maintainSessions :: SessionJar a -> IO ()+maintainSessions sessions =+  do now <- getCurrentTime+     let stillValid sess = (sess_validUntil sess) > now+     atomically $ modifyTVar sessions $ \m -> HM.filter stillValid m+     threadDelay 1000000+     maintainSessions sessions++setCookie :: Session a -> ActionM ()+setCookie sess =+    do let formattedExp = TL.pack $ formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" (sess_validUntil sess)+       header "Set-Cookie" $ "sid=" <> TL.fromStrict (sess_id sess) <> "; " <> formattedExp++loadSession :: SessionJar a -> ActionM (Maybe (Session a))+loadSession sessions =+    do req <- request+       liftIO $ getUserSession req sessions++getUserSession :: Request -> SessionJar a -> IO (Maybe (Session a))+getUserSession req sessions =+    case lookup "cookie" (requestHeaders req) >>=+         lookup "sid" . parseCookies . TEnc.decodeUtf8 of+      Just sid -> lookupSession sid+      Nothing -> return Nothing+    where lookupSession sid = getSession sid sessions++parseCookies :: T.Text -> [(T.Text, T.Text)]+parseCookies = map parseCookie . T.splitOn ";" . T.concat . T.words+    where parseCookie = first T.init . T.breakOnEnd "="

@@ -0,0 +1,29 @@+Name:                scotty-session+Version:             0.0.1+Synopsis:            Adding session functionality to scotty+Homepage:            https://github.com/agrafix/scotty-session+Bug-reports:         https://github.com/agrafix/scotty-session/issues+License:             BSD3+Author:              Alexander Thiemann <mail@agrafix.net>+Maintainer:          Alexander Thiemann <mail@agrafix.net>+Copyright:           (c) 2013 Alexander Thiemann+Category:            Web+Stability:           experimental+Build-type:          Simple+Cabal-version:       >= 1.10+Description:+  Adding PHP-like session management to Scotty.+  .+  [Scotty] <http://hackage.haskell.org/package/scotty>++Library+  Exposed-modules:     Web.Scotty.Session+  default-language:    Haskell2010+  build-depends:       base >= 3 && < 5, scotty, text, unordered-containers, transformers, stm, bytestring, blaze-builder, old-locale, time, http-types,+                       wai, base64-bytestring, crypto-api++  GHC-options: -Wall -fno-warn-orphans -fno-warn-unused-do-bind++source-repository head+  type:     git+  location: git://github.com/agrafix/scotty-session.git