salvia-sessions (empty) → 1.0.0
raw patch · 5 files changed
+602/−0 lines, 5 filesdep +MaybeT-transformersdep +basedep +containerssetup-changed
Dependencies added: MaybeT-transformers, base, containers, fclabels, monads-fd, pureMD5, random, safe, salvia, salvia-protocol, stm, time, utf8-string
Files
- LICENSE +28/−0
- Setup.lhs +6/−0
- salvia-sessions.cabal +33/−0
- src/Network/Salvia/Handler/Login.hs +287/−0
- src/Network/Salvia/Handler/Session.hs +248/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.lhs view
@@ -0,0 +1,6 @@+#! /usr/bin/env runhaskell++>import Distribution.Simple++>main = defaultMain+
+ salvia-sessions.cabal view
@@ -0,0 +1,33 @@+Name: salvia-sessions+Version: 1.0.0+Description: Session support for the Salvia webserver.+Synopsis: Session support for the Salvia webserver.+Cabal-version: >= 1.6+Category: Network, Web+License: BSD3+License-file: LICENSE+Author: Sebastiaan Visser, Erik Hesselink+Maintainer: sfvisser@cs.uu.nl+Build-Type: Simple++Library+ GHC-Options: -Wall -fno-warn-orphans+ HS-Source-Dirs: src++ Build-Depends: base ==4.*,+ safe ==0.2.*,+ fclabels ==0.4.*,+ pureMD5 ==1.0.*,+ stm ==2.1.*,+ containers >= 0.2 && < 0.4,+ MaybeT-transformers == 0.1.*,+ random ==1.0.*,+ time ==1.1.*,+ utf8-string ==0.3.*,+ salvia ==1.0.*,+ salvia-protocol ==1.0.*,+ monads-fd ==0.0.*++ Exposed-modules: Network.Salvia.Handler.Login+ Network.Salvia.Handler.Session+
+ src/Network/Salvia/Handler/Login.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE+ FlexibleContexts+ , FlexibleInstances+ , UndecidableInstances+ , TemplateHaskell+ , ScopedTypeVariables+ , TypeOperators+ , RankNTypes+ , MultiParamTypeClasses+ , FunctionalDependencies+ #-}+module Network.Salvia.Handler.Login+(+-- * Basic types.++ Username+, Password+, Email+, Action+, User (User)+, email+, username+, password+, actions++-- * Login server aspect.++, LoginM (..)++-- * User Sessions.++, UserPayload (..)+, UserSession++-- * User database backend.++, UserDatabase (UserDatabase)+, users+, backend++, Backend (..)+, noBackend+, fileBackend++-- * Handlers.++, hGetUser+, hSignup+, hLogin+, hLogout+, hLoginfo+, hAuthorized++)+where++import Control.Applicative+import Control.Concurrent.STM+import Control.Monad.State hiding (get)+import Data.ByteString.Lazy.UTF8 hiding (lines)+import Data.Digest.Pure.MD5+import Data.List+import Data.Maybe+import Data.Record.Label+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Salvia.Handler.Body+import Network.Salvia.Handler.Session+import Network.Salvia.Impl.Handler+import Network.Salvia.Interface+import Prelude hiding (mod)+import Safe+import qualified Control.Monad.State as S++{- |+User containg a username, password and a list of actions this user is allowed+to perform within the system.+-}++type Username = String+type Email = String+type Password = String+type Action = String++data User = User+ { _username :: Username+ , _email :: Email+ , _password :: Password+ , _actions :: [Action]+ } deriving (Eq, Show)++$(mkLabels [''User])++username :: User :-> Username+email :: User :-> Email+password :: User :-> Password+actions :: User :-> [Action]++{- |+A user payload instance contains user related session information and can be+used as the payload for regular sessions. It contains a reference to the user+it belongs to, a flag to indicate whether the user is logged in or not and a+possible user specific session payload.+-}++data UserPayload a = UserPayload+ { upUser :: User+ , upLoggedIn :: Bool+ , upPayload :: Maybe a+ } deriving (Eq, Show)++type UserSession a = Session (UserPayload a)++data Backend = Backend+ { read :: MonadIO m => m UserDatabase+ , add :: MonadIO m => User -> m ()+ }++{- |+A user database containing a list of users and a reference to the backend the+database originates from and can be synchronized back to.+-}++data UserDatabase = UserDatabase+ { _backend :: Backend+ , _users :: [User]+ }++$(mkLabels [''UserDatabase])++users :: UserDatabase :-> [User]+backend :: UserDatabase :-> Backend++class (Applicative m, Monad m) => LoginM p m | m -> p where+ login :: m a -> (User -> m a) -> m a+ loginfo :: m ()+ logout :: m ()+ signup :: [Action] -> m a -> (User -> m a) -> m a+ authorized :: Maybe Action -> m a -> (User -> m a) -> m a++instance ( Contains q (TVar (Sessions (UserPayload p)))+ , Contains q (TVar UserDatabase)+ ) => LoginM p (Handler q) where+ login = hLogin (undefined :: p)+ logout = hLogout (undefined :: p)+ loginfo = hLoginfo (undefined :: p)+ signup = hSignup (undefined :: p)+ authorized = hAuthorized (undefined :: p)++hGetUser :: LoginM p m => m (Maybe User)+hGetUser = authorized Nothing (return Nothing) (return . Just)++{- |+The signup handler is used to create a new entry in the user database. It reads+a new username and password from the post parameters and adds a new entry into+the backend of the user database when no user with such name exists. The user+gets the specified initial set of actions assigned. When the signup fails the+first handler will be executed when the signup succeeds the second handler will+be executed which may access the fresh user object.+-}++hSignup+ :: forall m q p a. (MonadIO m, PayloadM q UserDatabase m, SessionM (UserPayload p) m, BodyM Request m, HttpM Request m)+ => p -> [Action] -> m a -> (User -> m a) -> m a+hSignup _ acts onFail onOk =+ do ps <- hRequestParameters "utf-8"+ join . payload $+ do db <- S.get+ case freshUserInfo ps (get users db) acts of+ Nothing -> return onFail+ Just user -> + do modM users (user:)+ return $+ do add (get backend db) user+ onOk user++-- | Helper functions that generates fresh user information.++freshUserInfo :: Parameters -> [User] -> [Action] -> Maybe User+freshUserInfo ps us acts =+ do user <- "username" `lookup` ps >>= id+ mail <- "email" `lookup` ps >>= id+ pass <- "password" `lookup` ps >>= id+ if null user || null mail || null pass+ then Nothing+ else case ( headMay $ filter ((==user) . get username) us+ , headMay $ filter ((==mail) . get email) us+ ) of+ (Nothing, Nothing) -> return $ User user mail (show (md5 (fromString pass))) acts+ _ -> Nothing++{- |+The login handler. Read the username and password values from the post data and+use that to authenticate the user. When the user can be found in the database+the user is logged in and stored in the session payload. When the login fails+the first handler will be executed when the login succeeds the second handler+will be executed which may access the fresh user object.+-}++hLogin+ :: forall m q p a. (PayloadM q UserDatabase m, SessionM (UserPayload p) m, HttpM Request m, MonadIO m, BodyM Request m)+ => p -> m a -> (User -> m a) -> m a+hLogin _ onFail onOk =+ do ps <- hRequestParameters "utf-8"+ db <- payload S.get :: m UserDatabase+ case authenticate ps db of+ Nothing -> onFail+ Just user -> do let pl = Just (UserPayload user True Nothing)+ withSession (set sPayload pl)+ onOk user++-- | Helper functions that performs the authentication check.++authenticate :: Parameters -> UserDatabase -> Maybe User+authenticate ps db =+ do user <- "username" `lookup` ps >>= id+ pass <- "password" `lookup` ps >>= id+ case headMay $ filter ((==user) . get username) (get users db) of+ Just u | get password u == show (md5 (fromString pass)) -> Just u+ _ -> Nothing++-- | Logout the current user by emptying the session payload.++hLogout :: SessionM (UserPayload p) m => p -> m ()+hLogout _ = withSession (set sPayload Nothing)++{- |+The `loginfo' handler exposes the current user session to the world using a+simple text based response. The response contains information about the current+session identifier, session start and expiration date and the possible user+payload that is included.+-}++hLoginfo :: (SessionM (UserPayload p) m, SendM m) => p -> m ()+hLoginfo _ =+ do hSessionInfo+ s <- getSession+ case get sPayload s of+ Nothing -> return ()+ Just (UserPayload (User uname mail _ acts) _ _) ->+ do send $ "\n" ++ intercalate "\n"+ [ "username=" ++ uname+ , "mail=" ++ mail+ , "actions=" ++ intercalate " " acts+ ]++{- |+Execute a handler only when the user for the current session is authorized to+do so. The user must have the specified action contained in its actions list in+order to be authorized. When the authorization fails the first handler will be+executed when the authorization succeeds the second handler will be executed+which may access the current user object. +-}++hAuthorized :: SessionM (UserPayload p) m => p -> Maybe Action -> m b -> (User -> m b) -> m b+hAuthorized _ maction onFail onOk =+ do session <- getSession+ case (maction, get sPayload session) of+ (Nothing, Just (UserPayload user _ _)) -> onOk user+ (Just action, Just (UserPayload user _ _)) | action `elem` get actions user -> onOk user+ _ -> onFail++-- | User database backend that does nothing and discards all changes made.++noBackend :: Backend+noBackend = let b = Backend (return (UserDatabase b [])) (const (return ())) in b++-- | File based user database backend. Format: /username password action*/.++fileBackend :: FilePath -> Backend+fileBackend file = bcknd+ where + bcknd = Backend+ ((UserDatabase bcknd . parse) `liftM` liftIO (readFile file))+ (liftIO . appendFile file . printUserLine)+ parse = catMaybes . map parseUserLine . lines+ parseUserLine line =+ case (line, words line) of+ ('#':_, _) -> Nothing+ (_, user:mail:pass:acts) -> Just (User user mail pass acts)+ _ -> Nothing+ printUserLine u = intercalate " " $+ [ get username u+ , get email u+ , get password u+ ] ++ get actions u ++ ["\n"]+
+ src/Network/Salvia/Handler/Session.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE+ FlexibleContexts+ , FlexibleInstances+ , UndecidableInstances+ , TemplateHaskell+ , TypeOperators+ , ScopedTypeVariables+ , GeneralizedNewtypeDeriving+ , MultiParamTypeClasses+ , FunctionalDependencies+ #-}+module Network.Salvia.Handler.Session where++import Control.Applicative hiding (empty)+import Control.Category+import Control.Concurrent.STM hiding (check)+import Control.Monad.Maybe+import Control.Monad.State hiding (get, sequence)+import Data.List+import Data.Maybe+import Data.Record.Label+import Data.Time.Clock+import Data.Time.LocalTime+import Network.Protocol.Cookie hiding (empty)+import Network.Protocol.Http hiding (cookie)+import Network.Salvia.Handler.Cookie+import Network.Salvia.Impl.Handler+import Network.Salvia.Interface+import Prelude hiding ((.), id, lookup, sequence, mod)+import Safe+import System.Random+import qualified Control.Monad.State as S+import qualified Data.Map as M++-- | A session identifier. Should be unique for every session.++newtype SessionID = SID { _sid :: Integer }+ deriving (Eq, Ord, Random)++$(mkLabels [''SessionID])++sid :: SessionID :-> Integer++instance Show SessionID where+ show = show . get sid++-- | The session data type with polymorphic payload.++data Session p =+ Session+ { _sID :: SessionID+ , _sStart :: UTCTime+ , _sLast :: UTCTime+ , _sExpire :: Integer+ , _sPayload :: Maybe p+ } deriving (Show)++$(mkLabels [''Session])++-- | A globally unique session identifier.+sID :: Session p :-> SessionID++-- | The time the session started.+sStart :: Session p :-> UTCTime++-- | Last time session was used.+sLast :: Session p :-> UTCTime++-- | Expire after this amount of time when unused.+sExpire :: Session p :-> Integer++-- | The information this session stores.+sPayload :: Session p :-> Maybe p++-- | Session type classes that hides the inner workings from the outside world.++class (Applicative m, Monad m) => SessionM p m | m -> p where+ prolongSession :: Integer -> m ()+ getSession :: m (Session p)+ putSession :: Session p -> m ()+ delSession :: m ()+ withSession :: (Session p -> Session p) -> m ()++-- | Default instance for the `Handler' context.++instance Contains q (TVar (Sessions p)) => SessionM p (Handler q) where+ prolongSession = hProlongSession (undefined :: p)+ getSession = hGetSession+ putSession = hPutSession+ delSession = hDelSession (undefined :: p)+ withSession = hWithSession++-- | A mapping from unique session IDs to shared session variables.++type SessionMap p = M.Map SessionID (TVar (Session p))+newtype Sessions p = Sessions { unSessions :: SessionMap p }++-- | Apply a function to the sessions in the `Sessions` newtype.++withSessions :: (SessionMap p -> SessionMap p) -> Sessions p -> Sessions p+withSessions f = Sessions . f . unSessions++-- | Create a new, empty, store of sessions.++mkSessions :: Sessions p+mkSessions = Sessions M.empty++{- | todo doc:+The session handler. This handler will try to return an existing session from+the sessions map based on a session identifier found in the HTTP `cookie`. When+such a session can be found the expiration date will be updated to a number of+seconds in the future. When no session can be found a new one will be created.+A cookie will be set that informs the client of the current session.+-}++hProlongSession+ :: forall m q p. (MonadIO m, HttpM' m, ServerM m, ServerAddressM m, PayloadM q (Sessions p) m)+ => p -> Integer -> m ()+hProlongSession _ e =+ do n <- liftIO getCurrentTime+ var <- existingSessionVarOrNew+ session <- modVar (set sLast n . set sExpire e) (var :: TVar (Session p)) >>= getVar+ setCookieSession (get sID session) (willExpireAt session)++hGetSession :: (MonadIO m, HttpM' m, ServerM m, PayloadM q (Sessions p) m) => m (Session p)+hGetSession = existingSessionVarOrNew >>= getVar++hPutSession+ :: (MonadIO m, HttpM' m, ServerM m, ServerAddressM m, PayloadM q (Sessions p) m)+ => Session p -> m ()+hPutSession session =+ do var <- existingSessionVarOrNew+ putVar var session+ setCookieSession (get sID session) (willExpireAt session)++hDelSession :: forall q p m. (PayloadM q (Sessions p) m, HttpM' m, MonadIO m) => p -> m ()+hDelSession _ =+ do msid <- getCookieSessionID+ case msid of+ Just sd ->+ do delCookieSession+ payload . S.modify . withSessions $ (M.delete sd :: SessionMap p -> SessionMap p)+ Nothing -> return ()++hWithSession+ :: (PayloadM q (Sessions p) m, MonadIO m, HttpM Request m)+ => (Session p -> Session p) -> m ()+hWithSession f =+ do _ <- existingSessionVarOrNew >>= modVar f+ return ()++hSessionInfo :: (SessionM p m, SendM m) => m ()+hSessionInfo =+ do s <- getSession+ (send . intercalate "\n")+ [ "id=" ++ show (get sID s)+ , "start=" ++ show (get sStart s)+ , "last=" ++ show (get sLast s)+ , "expire=" ++ show (get sExpire s)+ , "payload=" ++ show (isJust $ get sPayload s)+ ]++{- | todo:+Given an existing session identifier lookup a session from the session map.+When no session is available, or the session is expired, create a new one using+the `newSessionVar' function. Otherwise the expiration date of the existing+session is updated.+-}++existingSessionVarOrNew+ :: (Applicative m, MonadIO m, HttpM Request m, PayloadM q (Sessions p) m)+ => m (TVar (Session p))+existingSessionVarOrNew = fromMaybeTM newSessionVar $+ do sd <- MaybeT getCookieSessionID+ svar <- MaybeT (lookupSessionVar sd)+ MaybeT (whenNotExpired svar)++whenNotExpired :: MonadIO m => TVar (Session p) -> m (Maybe (TVar (Session p)))+whenNotExpired var =+ do n <- liftIO getCurrentTime+ session <- getVar var+ return $ if (willExpireAt session > n) then Just var else Nothing++{- |+This handler sets the HTTP cookie for the specified session. It will+use a default cookie with an additional `sid' attribute with the+session identifier as value. The session expiration date will be used+as the cookie expire field. The session is valid for all subdomains.+-}++setCookieSession :: (MonadIO m, ServerM m, ServerAddressM m, HttpM Response m) => SessionID -> UTCTime -> m ()+setCookieSession sd ex =+ do zone <- liftIO getCurrentTimeZone+ let time = utcToLocalTime zone ex+ ck <- set name "sid" . set value (show sd) <$> hNewCookie time True+ hSetCookie (fromList [ck])++-- | Given the (possibly wrong) request cookie, try to recover the existing+-- session identifier.++getCookieSessionID :: (MonadIO m, HttpM Request m) => m (Maybe SessionID)+getCookieSessionID =+ -- todo : join . fmap == (=<<)+ fmap SID . join . fmap readMay . join . fmap (get (fmapL value . pickCookie "sid"))+ <$> hCookie++delCookieSession :: HttpM Response m => m ()+delCookieSession = hDelCookie "sid"++-- | Create a new session with a specified expiration date. The session will be+-- stored in the session map.++newSessionVar :: (MonadIO m, PayloadM q (Sessions p) m) => m (TVar (Session p))+newSessionVar = do+ t <- liftIO getCurrentTime+ session <- newVar (Session undefined t t 0 Nothing)+ keys <- liftIO newStdGen >>= return . randoms+ sd <- payload $ do+ sd <- newSessionID keys+ S.modify . withSessions $ M.insert sd session+ return sd+ modVar (set sID sd) session++newSessionID :: (MonadState (Sessions p) m, Functor m) => [SessionID] -> m SessionID+newSessionID keys =+ do store <- unSessions <$> S.get+ return . head . filter (flip M.notMember store) $ keys++willExpireAt :: Session p -> UTCTime+willExpireAt session = fromInteger (get sExpire session) `addUTCTime` get sLast session ++lookupSessionVar+ :: (MonadIO m, PayloadM q (Sessions p) m)+ => SessionID -> m (Maybe (TVar (Session p)))+lookupSessionVar sd = payload (S.gets (M.lookup sd . unSessions))++-- STM utilities.++newVar :: MonadIO m => a -> m (TVar a)+getVar :: MonadIO m => TVar a -> m a+putVar :: MonadIO m => TVar a -> a -> m ()+modVar :: MonadIO m => (a -> a) -> TVar a -> m (TVar a)++newVar = liftIO . atomically . newTVar+getVar = liftIO . atomically . readTVar+putVar var = liftIO . atomically . writeTVar var+modVar f var = liftIO . atomically $ (readTVar var >>= writeTVar var . f) >> return var+