happstack-auth (empty) → 0.2
raw patch · 15 files changed
+1039/−0 lines, 15 filesdep +Cryptodep +basedep +bytestringsetup-changed
Dependencies added: Crypto, base, bytestring, containers, convertible, happstack, happstack-data, happstack-ixset, happstack-server, happstack-state, mtl, old-time, random
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- happstack-auth.cabal +56/−0
- src/Happstack/Auth.hs +456/−0
- src/Happstack/Auth/Internal.hs +262/−0
- src/Happstack/Auth/Internal/Data.hs +37/−0
- src/Happstack/Auth/Internal/Data/AuthState.hs +33/−0
- src/Happstack/Auth/Internal/Data/Old/SessionData0.hs +21/−0
- src/Happstack/Auth/Internal/Data/SaltedHash.hs +16/−0
- src/Happstack/Auth/Internal/Data/SessionData.hs +31/−0
- src/Happstack/Auth/Internal/Data/SessionKey.hs +17/−0
- src/Happstack/Auth/Internal/Data/Sessions.hs +19/−0
- src/Happstack/Auth/Internal/Data/User.hs +27/−0
- src/Happstack/Auth/Internal/Data/UserId.hs +17/−0
- src/Happstack/Auth/Internal/Data/Username.hs +15/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2010, Nils Schweinsberg++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 Nils Schweinsberg nor the names of other+ 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,2 @@+import Distribution.Simple+main = defaultMain
+ happstack-auth.cabal view
@@ -0,0 +1,56 @@+Name: happstack-auth+Version: 0.2+License: BSD3+License-File: LICENSE+Author: Nils Schweinsberg+Maintainer: mail@n-sch.de+Category: Web++Synopsis: A Happstack Authentication Suite+Description: An easy way to to implement user authentication for+ Happstack web applications.++Homepage: http://n-sch.de/happstack-auth+Build-Type: Simple+Cabal-Version: >= 1.8++Source-Repository head+ type: git+ location: http://github.com/mcmaniac/happstack-auth++Library++ HS-Source-Dirs: src+ GHC-Options: -Wall++ Build-Depends:+ base == 4.*,+ bytestring == 0.*,+ mtl == 1.*,+ containers == 0.*,+ random == 1.*,+ old-time == 1.*,+ happstack == 0.5.*,+ happstack-state == 0.5.*,+ happstack-server == 0.5.*,+ happstack-ixset == 0.5.*,+ happstack-data == 0.5.*,+ Crypto == 4.*,+ convertible == 1.*++ Exposed-Modules:+ Happstack.Auth+ Happstack.Auth.Internal+ Happstack.Auth.Internal.Data++ Other-Modules:+ Happstack.Auth.Internal.Data.AuthState+ Happstack.Auth.Internal.Data.SaltedHash+ Happstack.Auth.Internal.Data.SessionData+ Happstack.Auth.Internal.Data.SessionKey+ Happstack.Auth.Internal.Data.Sessions+ Happstack.Auth.Internal.Data.User+ Happstack.Auth.Internal.Data.UserId+ Happstack.Auth.Internal.Data.Username++ Happstack.Auth.Internal.Data.Old.SessionData0
+ src/Happstack/Auth.hs view
@@ -0,0 +1,456 @@+--------------------------------------------------------------------------------+-- |+-- Module : Happstack.Auth+-- Copyright : (c) Nils Schweinsberg 2010+-- License : BSD3 (see LICENSE file)+--+-- Maintainer : mail@n-sch.de+-- Stability : experimental+-- Portability : non-portable+--+-- Happstack.Auth offers an easy way to implement user authentication for+-- Happstack web applications. It uses "Happstack.State" as database back-end+-- and SHA512 for password encryption. Session safety is ensured by a HTTP+-- header fingerprint (client ip & user-agent) and a configurable session+-- timeout.+-- +-- To use this module, add the `AuthState' to your state dependencies, for+-- example:+--+-- > import Happstack.Auth+-- >+-- > instance Component MyState where+-- > type Dependencies MyState = AuthState :+: End+-- > initialValue = ...+--+-- One of the first things in your response monad should be `updateTimeout' to+-- make sure session timeouts are updated correctly.+--+--------------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses,+ FlexibleContexts, FlexibleInstances, TupleSections, CPP+ #-}++module Happstack.Auth+ (+ -- * High level functions++ -- ** User registration+ register+ , changePassword+ , setPassword++ -- ** Session management+ , updateTimeout+ , performLogin+ , performLogout+ , loginHandler+ , logoutHandler+ , withSession+ , loginGate+ , getSessionData+ , getSessionKey+ , clearSessionCookie++ -- * Basic functions++ -- ** Users+ , addUser+ , getUser+ , getUserById+ , delUser+ , updateUser+ , authUser+ , isUser+ , listUsers+ , numUsers+ , askUsers++ -- ** Sessions+ , newSession+ , getSession+ , setSession+ , delSession+ , clearAllSessions+ , numSessions+ , getSessions+ , clearExpiredSessions++ -- * Data types+ -- $datatypes+ , User (), userName, userId+ , Username+ , Password+ , UserId+ , SessionData (..)+ , SessionKey+ , Minutes+ , AuthState+ , authProxy+ ) where+++import Control.Applicative+import Control.Monad.Reader+import Data.Maybe+import System.Time++import qualified Data.ByteString.Char8 as BS8++import Data.Convertible+import Happstack.Server+import Happstack.State++import Happstack.Auth.Internal+import Happstack.Auth.Internal.Data hiding (Username, User, SessionData)+import qualified Happstack.Auth.Internal.Data as D+++#if MIN_VERSION_happstack(0,5,1)+queryPolicy :: BodyPolicy+queryPolicy = defaultBodyPolicy "/tmp/happstack-auth" 0 4096 4096+#endif++sessionCookie :: String+sessionCookie = "sid"+++--------------------------------------------------------------------------------+-- Avoid the whole newtype packing:++{- $datatypes++These data types collide with the data definitions used internaly in+"Happstack.Auth.Data.Internal". However, if you need both modules you might+want to import the Data module qualified:++> import Happstack.Auth+> import qualified Happstack.Auth.Data.Internal as AuthD++-}++--+-- Users:+--+type Username = String+type Password = String++data User = User+ { userId :: UserId+ , userName :: Username+ , _userPass :: SaltedHash+ }++fromDUser :: D.User -> User+fromDUser (D.User i (D.Username n) p) = User i n p++instance Convertible D.User User where+ safeConvert = Right . fromDUser++toDUser :: User -> D.User+toDUser (User i n p) = D.User i (D.Username n) p++instance Convertible User D.User where+ safeConvert = Right . toDUser+++maybeUser :: MonadIO m => m (Maybe D.User) -> m (Maybe User)+maybeUser m = m >>= return . fmap fromDUser++--+-- Sessions:+--++data SessionData = SessionData+ { sessionUserId :: UserId+ , sessionUsername :: Username+ , sessionTimeout :: ClockTime+ , sessionFingerprint :: (Either String BS8.ByteString, Maybe BS8.ByteString) -- ^ either IP or \"x-forwarded-for\" header & user-agent+ }++fromDSession :: D.SessionData -> SessionData+fromDSession (D.SessionData i (D.Username n) t f) = SessionData i n t f++instance Convertible D.SessionData SessionData where+ safeConvert = Right . fromDSession++toDSession :: SessionData -> D.SessionData+toDSession (SessionData i n t f) = D.SessionData i (D.Username n) t f++instance Convertible SessionData D.SessionData where+ safeConvert = Right . toDSession+++--+-- Auth Proxy+--++authProxy :: Proxy AuthState+authProxy = Proxy+++--------------------------------------------------------------------------------+-- End user functions: Users++addUser :: (MonadIO m) => Username -> Password -> m (Maybe User)+addUser u p = do+ s <- liftIO $ buildSaltAndHash p+ case s of+ Just s' -> maybeUser . update $ AddUser (D.Username u) s'+ Nothing -> return Nothing++getUser :: (MonadIO m) => Username -> m (Maybe User)+getUser u = maybeUser . query $ GetUser (D.Username u)++getUserById :: (MonadIO m) => UserId -> m (Maybe User)+getUserById i = maybeUser . query $ GetUserById i++delUser :: (MonadIO m) => Username -> m ()+delUser u = update $ DelUser (D.Username u)++authUser :: (MonadIO m) => Username -> Password -> m (Maybe User)+authUser u p = maybeUser . query $ AuthUser u p++isUser :: (MonadIO m) => Username -> m Bool+isUser u = query $ IsUser (D.Username u)++listUsers :: (MonadIO m) => m [Username]+listUsers = query ListUsers >>= return . map D.unUser++numUsers :: (MonadIO m) => m Int+numUsers = query NumUsers++-- | Update (replace) a user+updateUser :: (MonadIO m) => User -> m ()+updateUser u = update $ UpdateUser (toDUser u)++-- | Warning: This `UserDB' uses the internal types from+-- "Happstack.Auth.Data.Internal"+askUsers :: (MonadIO m) => m UserDB+askUsers = query AskUsers+++--------------------------------------------------------------------------------+-- End user functions: Sessions++clearAllSessions :: (MonadIO m) => m ()+clearAllSessions = update ClearAllSessions++setSession :: (MonadIO m) => SessionKey -> SessionData -> m ()+setSession k d = update $ SetSession k (toDSession d)++getSession :: (MonadIO m) => SessionKey -> m (Maybe SessionData)+getSession k = query (GetSession k) >>= return . fmap fromDSession++newSession :: (MonadIO m) => SessionData -> m SessionKey+newSession d = update $ NewSession (toDSession d)++delSession :: (MonadIO m) => SessionKey -> m ()+delSession k = update $ DelSession k++numSessions :: (MonadIO m) => m Int+numSessions = query $ NumSessions++getFingerprint :: (MonadIO m, ServerMonad m) => m (Either String BS8.ByteString, Maybe BS8.ByteString)+getFingerprint = do+ userAgent <- getHeaderM "user-agent"+ forwarded <- getHeaderM "x-forwarded-for"+ case forwarded of+ Just f -> return (Right f, userAgent)+ Nothing -> do+ (ip, _) <- askRq >>= return . rqPeer+ return (Left ip, userAgent)++-- | Warning: This `Sessions' uses the internal types from+-- "Happstack.Auth.Data.Internal"+getSessions :: (MonadIO m) => m (Sessions D.SessionData)+getSessions = query GetSessions+++--------------------------------------------------------------------------------+-- Session managment++type Minutes = Int+++-- | Update the session timeout of logged in users. Add this to the top of your+-- application route, for example:+--+-- > appRoute :: ServerPart Response+-- > appRoute = updateTimeout 5 >> msum+-- > [ {- your routing here -}+-- > ]+updateTimeout :: (MonadIO m, FilterMonad Response m, MonadPlus m, ServerMonad m)+ => Minutes+ -> m ()+updateTimeout mins = withSessionId action+ where+ action Nothing = return ()+ action (Just sid) = do+ c <- liftIO getClockTime+ let c' = addToClockTime noTimeDiff { tdMin = mins } c+ cookie = mkCookie sessionCookie (show sid)+ update $ UpdateTimeout sid c'+ addCookie (mins * 60) cookie+++performLogin :: (MonadIO m, FilterMonad Response m, ServerMonad m)+ => Minutes -- ^ Session timeout+ -> User+ -> m a -- ^ Run with modified headers, including the new session cookie+ -> m a+performLogin mins user action = do++ f <- getFingerprint+ c <- liftIO getClockTime+ let clock = addToClockTime noTimeDiff { tdMin = mins } c+ key <- newSession $ SessionData (userId user) (userName user) clock f++ let cookie = mkCookie sessionCookie (show key)+ addCookie (mins * 60) cookie++ localRq (\r -> r { rqCookies = (rqCookies r) ++ [(sessionCookie, cookie)] }) action++-- | Handles data from a login form to log the user in.+loginHandler :: (MonadIO m, FilterMonad Response m, MonadPlus m, ServerMonad m)+ => Minutes -- ^ Session timeout+ -> Maybe String -- ^ POST field to look for username (default: \"username\")+ -> Maybe String -- ^ POST field to look for password (default: \"password\")+ -> m a -- ^ Success response+ -> (Maybe Username -> Maybe Password -> m a) -- ^ Fail response. Arguments: Post data+ -> m a+loginHandler mins muname mpwd okR failR = do+#if MIN_VERSION_happstack(0,5,1)+ dat <- getDataFn queryPolicy . body $ do+#else+ dat <- getDataFn $ do+#endif+ un <- look $ fromMaybe "username" muname+ pw <- optional . look $ fromMaybe "password" mpwd+ return (un,pw)++ case dat of+ Right (u, Just p) -> authUser u p+ >>= maybe (failR (Just u) (Just p))+ (\user -> performLogin mins user okR)+ Right (u, mp) -> failR (Just u) mp+ _ -> failR Nothing Nothing+++performLogout :: (MonadIO m, FilterMonad Response m) => SessionKey -> m ()+performLogout sid = do+ clearSessionCookie+ delSession sid+++logoutHandler :: (ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m)+ => m a -- ^ Response after logout+ -> m a+logoutHandler target = withSessionId handler+ where+ handler (Just sid) = do+ performLogout sid+ target+ handler Nothing = target+++clearSessionCookie :: (FilterMonad Response m) => m ()+clearSessionCookie = addCookie' 0 (mkCookie sessionCookie "0")+ where+ -- Used to replace any previous "addCookie" commands (-> updateTimeout)+ addCookie' sec = (setHeaderM "Set-Cookie") . mkCookieHeader sec++clearExpiredSessions :: (MonadIO m) => m ()+clearExpiredSessions = liftIO getClockTime >>= update . ClearExpiredSessions+++-- | Get the `SessionData' of the currently logged in user+getSessionData :: (MonadIO m, MonadPlus m, ServerMonad m)+ => m (Maybe SessionData)+getSessionData = do+ d <- withSessionId action+ f <- getFingerprint+ case d of+ Just sd | f == sessionFingerprint sd ->+ return $ Just sd+ _ ->+ return Nothing+ where+ action (Just sid) = getSession sid+ action Nothing = return Nothing++-- | Get the identifier for the current session+getSessionKey :: (MonadIO m, MonadPlus m, ServerMonad m)+ => m (Maybe SessionKey)+getSessionKey = withSessionId return++withSessionId :: (Read a, MonadIO m, MonadPlus m, ServerMonad m)+ => (Maybe a -> m r)+ -> m r+withSessionId f = do+ clearExpiredSessions+ withDataFn queryPolicy getSessionId f+ where+ getSessionId :: (Read a) => RqData (Maybe a)+ getSessionId = optional $ readCookieValue sessionCookie+++-- | Run a `ServerPartT' with the `SessionData' of the currently logged in user+-- (if available)+withSession :: (MonadIO m)+ => (SessionData -> ServerPartT m a) -- ^ Logged in response+ -> ServerPartT m a -- ^ Not logged in response+ -> ServerPartT m a+withSession f guestSPT = withSessionId action+ where+ action (Just sid) = getSession sid >>= maybe noSession f+ action Nothing = guestSPT+ noSession = clearSessionCookie >> guestSPT+++-- | Require a login+loginGate :: (MonadIO m)+ => ServerPartT m a -- ^ Logged in+ -> ServerPartT m a -- ^ Not registered+ -> ServerPartT m a+loginGate reg guest = withSession (\_ -> reg) guest+++--------------------------------------------------------------------------------+-- User registration++-- | Register a new user+register :: (MonadIO m, FilterMonad Response m, ServerMonad m)+ => Minutes -- ^ Session timeout+ -> Username+ -> Password+ -> m a -- ^ User exists response+ -> m a -- ^ Success response+ -> m a+register mins user pass uExists good = do+ u <- addUser user pass+ case u of+ Just u' -> performLogin mins u' good+ Nothing -> uExists++changePassword :: (MonadIO m)+ => Username+ -> Password -- ^ Old password+ -> Password -- ^ New password+ -> m Bool+changePassword user oldpass newpass = do+ ms <- liftIO $ buildSaltAndHash newpass+ case ms of+ Just s -> update $ ChangePassword user oldpass s+ _ -> return False++setPassword :: MonadIO m+ => Username+ -> Password+ -> m Bool+setPassword un p = do+ ms <- liftIO $ buildSaltAndHash p+ case ms of+ Just s -> update $ SetPassword (D.Username un) s+ _ -> return False
+ src/Happstack/Auth/Internal.hs view
@@ -0,0 +1,262 @@+--------------------------------------------------------------------------------+-- |+-- Module : Happstack.Auth.Internal+-- Copyright : (c) Nils Schweinsberg 2010+-- License : BSD3 (see LICENSE file)+--+-- Maintainer : mail@n-sch.de+-- Stability : experimental+-- Portability : non-portable+--+-- Internal representation of state functions.+--+--------------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, TypeSynonymInstances, MultiParamTypeClasses,+ FlexibleContexts, FlexibleInstances, DeriveDataTypeable+ #-}+{-# OPTIONS -fno-warn-orphans #-}++module Happstack.Auth.Internal+ ( buildSaltAndHash++ , AskUsers (..)+ , AddUser (..)+ , GetUser (..)+ , GetUserById (..)+ , DelUser (..)+ , AuthUser (..)+ , IsUser (..)+ , ListUsers (..)+ , NumUsers (..)+ , UpdateUser (..)+ , SetPassword (..)+ , ChangePassword (..)++ , ClearAllSessions (..)+ , SetSession (..)+ , GetSession (..)+ , GetSessions (..)+ , NewSession (..)+ , DelSession (..)+ , NumSessions (..)+ , ClearExpiredSessions (..)+ , UpdateTimeout (..)+ ) where+++import Control.Monad.Reader+import Control.Monad.State (modify,get,gets)+import Data.Maybe+import Numeric+import System.Random++import qualified Data.Map as M++import Codec.Utils+import Data.ByteString.Internal+import Data.Digest.SHA512+import Happstack.Data.IxSet hiding (null)+import Happstack.State+import Happstack.State.ClockTime++import Happstack.Auth.Internal.Data hiding (Username, User, SessionData)+import qualified Happstack.Auth.Internal.Data as D+++-------------------------------------------------------------------------------+-- Password generation++saltLength :: Num t => t+saltLength = 16++strToOctets :: String -> [Octet]+strToOctets = listToOctets . (map c2w)++slowHash :: [Octet] -> [Octet]+slowHash a = (iterate hash a) !! 512++randomSalt :: IO String+randomSalt = liftM concat $ sequence $ take saltLength $ repeat $+ randomRIO (0::Int,15) >>= return . flip showHex ""++buildSaltAndHash :: String -> IO (Maybe SaltedHash)+buildSaltAndHash str+ | null str = return Nothing+ | otherwise = do+ salt <- randomSalt+ let salt' = strToOctets salt+ str' = strToOctets str+ h = slowHash (salt'++str')+ return . Just $ SaltedHash $ salt'++h++checkSalt :: String -> SaltedHash -> Bool+checkSalt str (SaltedHash h) = h == salt++(slowHash $ salt++(strToOctets str))+ where salt = take saltLength h+++--------------------------------------------------------------------------------+-- State functions: Users++askUsers :: Query AuthState UserDB+askUsers = return . users =<< ask++getUser :: D.Username -> Query AuthState (Maybe D.User)+getUser un = do+ udb <- askUsers+ return $ getOne $ udb @= un++getUserById :: D.UserId -> Query AuthState (Maybe D.User)+getUserById uid = do+ udb <- askUsers+ return $ getOne $ udb @= uid++modUsers :: (UserDB -> UserDB) -> Update AuthState ()+modUsers f = modify (\s -> (AuthState (sessions s) (f $ users s) (nextUid s)))++getAndIncUid :: Update AuthState D.UserId+getAndIncUid = do+ uid <- gets nextUid+ modify (\s -> (AuthState (sessions s) (users s) (uid+1)))+ return uid++isUser :: D.Username -> Query AuthState Bool+isUser name = do+ us <- askUsers+ return $ isJust $ getOne $ us @= name++addUser :: D.Username -> SaltedHash -> Update AuthState (Maybe D.User)+addUser name pass+ | null (unUser name) = return Nothing+ | otherwise = do+ s <- get+ let exists = isJust $ getOne $ (users s) @= name+ if exists+ then return Nothing+ else do u <- newUser name pass+ modUsers $ insert u+ return $ Just u+ where newUser u p = do uid <- getAndIncUid+ return $ D.User uid u p++delUser :: D.Username -> Update AuthState ()+delUser name = modUsers del+ where del db = case getOne (db @= name) of+ Just u -> delete u db+ Nothing -> db++updateUser :: D.User -> Update AuthState ()+updateUser u = modUsers (updateIx (userid u) u)++authUser :: String -> String -> Query AuthState (Maybe D.User)+authUser name pass = do+ udb <- askUsers+ let u = getOne $ udb @= (D.Username name)+ case u of+ (Just v) -> return $ if checkSalt pass (userpass v) then u else Nothing+ Nothing -> return Nothing++listUsers :: Query AuthState [D.Username]+listUsers = do+ udb <- askUsers+ return $ map username $ toList udb++numUsers :: Query AuthState Int+numUsers = liftM length listUsers++setPassword :: D.Username -> SaltedHash -> Update AuthState Bool+setPassword un h = do+ mu <- runQuery $ getUser un+ case mu of+ Just u -> do+ updateUser u { userpass = h }+ return True+ _ ->+ return False++changePassword :: String -- ^ Username+ -> String -- ^ Old password+ -> SaltedHash -- ^ New password+ -> Update AuthState Bool+changePassword un op s = do+ mu <- runQuery $ authUser un op+ case mu of+ Just u -> do+ updateUser u { userpass = s }+ return True+ _ ->+ return False+++--------------------------------------------------------------------------------+-- State functions: Sessions++askSessions :: Query AuthState (Sessions D.SessionData)+askSessions = return . sessions =<< ask++modSessions :: (Sessions D.SessionData -> Sessions D.SessionData) -> Update AuthState ()+modSessions f = modify (\s -> (AuthState (f $ sessions s) (users s) (nextUid s)))++setSession :: SessionKey -> D.SessionData -> Update AuthState ()+setSession key u = do+ modSessions $ Sessions . (M.insert key u) . unsession+ return ()++newSession :: D.SessionData -> Update AuthState SessionKey+newSession u = do+ key <- getRandom+ setSession key u+ return key++delSession :: SessionKey -> Update AuthState ()+delSession key = do+ modSessions $ Sessions . (M.delete key) . unsession+ return ()++clearAllSessions :: Update AuthState ()+clearAllSessions = modSessions $ const (Sessions M.empty)++getSession :: SessionKey -> Query AuthState (Maybe D.SessionData)+getSession key = liftM ((M.lookup key) . unsession) askSessions++getSessions :: Query AuthState (Sessions D.SessionData)+getSessions = askSessions++numSessions :: Query AuthState Int+numSessions = liftM (M.size . unsession) askSessions++clearExpiredSessions :: ClockTime -> Update AuthState ()+clearExpiredSessions c =+ modSessions $ Sessions . (M.filter ((c <) . sesTimeout)) . unsession++updateTimeout :: SessionKey -> ClockTime -> Update AuthState ()+updateTimeout sid c = do+ modSessions $ Sessions . (M.update (\sd -> Just sd { sesTimeout = c }) sid) . unsession++--------------------------------------------------------------------------------+-- Generate Methods++$(mkMethods ''AuthState+ [ 'askUsers+ , 'addUser+ , 'getUser+ , 'getUserById+ , 'delUser+ , 'authUser+ , 'isUser+ , 'listUsers+ , 'numUsers+ , 'updateUser+ , 'setPassword+ , 'changePassword++ , 'clearAllSessions+ , 'setSession+ , 'getSession+ , 'getSessions+ , 'newSession+ , 'delSession+ , 'numSessions+ , 'clearExpiredSessions+ , 'updateTimeout+ ])
+ src/Happstack/Auth/Internal/Data.hs view
@@ -0,0 +1,37 @@+--------------------------------------------------------------------------------+-- |+-- Module : Happstack.Auth.Internal.Data+-- Copyright : (c) Nils Schweinsberg 2010+-- License : BSD3 (see LICENSE file)+--+-- Maintainer : mail@n-sch.de+-- Stability : experimental+-- Portability : non-portable+--+-- Internal representation of state data types.+--+--------------------------------------------------------------------------------++{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data+ ( module Happstack.Auth.Internal.Data.AuthState+ , module Happstack.Auth.Internal.Data.SaltedHash+ , module Happstack.Auth.Internal.Data.SessionData+ , module Happstack.Auth.Internal.Data.SessionKey+ , module Happstack.Auth.Internal.Data.Sessions+ , module Happstack.Auth.Internal.Data.User+ , module Happstack.Auth.Internal.Data.UserId+ , module Happstack.Auth.Internal.Data.Username+ ) where++import Happstack.Auth.Internal.Data.AuthState+import Happstack.Auth.Internal.Data.SaltedHash+import Happstack.Auth.Internal.Data.SessionData+import Happstack.Auth.Internal.Data.SessionKey+import Happstack.Auth.Internal.Data.Sessions+import Happstack.Auth.Internal.Data.User+import Happstack.Auth.Internal.Data.UserId+import Happstack.Auth.Internal.Data.Username
+ src/Happstack/Auth/Internal/Data/AuthState.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.AuthState where++import Data.Data+import Happstack.Data+import Happstack.Data.IxSet+import Happstack.State++import qualified Data.Map as M++import Happstack.Auth.Internal.Data.SessionData+import Happstack.Auth.Internal.Data.Sessions+import Happstack.Auth.Internal.Data.User+import Happstack.Auth.Internal.Data.UserId++-- | Add this to your Dependency-List of your application state+data AuthState = AuthState+ { sessions :: Sessions SessionData+ , users :: UserDB+ , nextUid :: UserId+ }+ deriving (Show,Typeable,Data)++instance Version AuthState++$(deriveSerialize ''AuthState)++instance Component AuthState where+ type Dependencies AuthState = End+ initialValue = AuthState (Sessions M.empty) empty 0
+ src/Happstack/Auth/Internal/Data/Old/SessionData0.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.Old.SessionData0 where++import Data.Data+import Happstack.Data++import Happstack.Auth.Internal.Data.UserId+import Happstack.Auth.Internal.Data.Username++data SessionData = SessionData+ { sesUid :: UserId+ , sesUsername :: Username+ }+ deriving (Read,Show,Eq,Typeable,Data)++$(deriveSerialize ''SessionData)++instance Version SessionData
+ src/Happstack/Auth/Internal/Data/SaltedHash.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.SaltedHash where++import Data.Data+import Happstack.Data+import Codec.Utils++newtype SaltedHash = SaltedHash [Octet]+ deriving (Read,Show,Ord,Eq,Typeable,Data)++$(deriveSerialize ''SaltedHash)++instance Version SaltedHash
+ src/Happstack/Auth/Internal/Data/SessionData.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies, MultiParamTypeClasses+ #-}++module Happstack.Auth.Internal.Data.SessionData where++import Data.Data+import Data.ByteString+import Happstack.Data+import Happstack.State.ClockTime++import Happstack.Auth.Internal.Data.UserId+import Happstack.Auth.Internal.Data.Username++import qualified Happstack.Auth.Internal.Data.Old.SessionData0 as Old++data SessionData = SessionData+ { sesUid :: UserId+ , sesUsername :: Username+ , sesTimeout :: ClockTime+ , sesFingerprint :: (Either String ByteString, Maybe ByteString)+ }+ deriving (Show,Eq,Typeable,Data)++$(deriveSerialize ''SessionData)++instance Version SessionData where+ mode = extension 1 (Proxy :: Proxy Old.SessionData)++instance Migrate Old.SessionData SessionData where+ migrate (Old.SessionData uid un) = SessionData uid un (TOD 0 0) (Left "", Nothing)
+ src/Happstack/Auth/Internal/Data/SessionKey.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.SessionKey where++import Data.Data+import System.Random+import Happstack.Data++-- | Abstract session identification+newtype SessionKey = SessionKey Integer+ deriving (Read,Show,Ord,Eq,Typeable,Data,Num,Random)++$(deriveSerialize ''SessionKey)++instance Version SessionKey
+ src/Happstack/Auth/Internal/Data/Sessions.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.Sessions where++import Data.Data+import Happstack.Data++import qualified Data.Map as M++import Happstack.Auth.Internal.Data.SessionKey++data Sessions a = Sessions { unsession :: M.Map SessionKey a }+ deriving (Read,Show,Eq,Typeable,Data)++$(deriveSerialize ''Sessions)++instance Version (Sessions a)
+ src/Happstack/Auth/Internal/Data/User.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies, MultiParamTypeClasses+ #-}+++module Happstack.Auth.Internal.Data.User where++import Data.Data+import Happstack.Data+import Happstack.Data.IxSet++import Happstack.Auth.Internal.Data.SaltedHash+import Happstack.Auth.Internal.Data.UserId+import Happstack.Auth.Internal.Data.Username++data User = User+ { userid :: UserId+ , username :: Username+ , userpass :: SaltedHash+ }+ deriving (Read,Show,Ord,Eq,Typeable,Data)++$(deriveSerialize ''User)++instance Version User++$(inferIxSet "UserDB" ''User 'noCalcs [''UserId, ''Username])
+ src/Happstack/Auth/Internal/Data/UserId.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.UserId where++import Data.Data+import Data.Word+import Happstack.Data++-- | Abstract user identification+newtype UserId = UserId { unUid :: Word64 }+ deriving (Read,Show,Ord,Eq,Typeable,Data,Num)++$(deriveSerialize ''UserId)++instance Version UserId
+ src/Happstack/Auth/Internal/Data/Username.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE TemplateHaskell, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies+ #-}++module Happstack.Auth.Internal.Data.Username where++import Data.Data+import Happstack.Data++newtype Username = Username { unUser :: String }+ deriving (Read,Show,Ord,Eq,Typeable,Data)++$(deriveSerialize ''Username)++instance Version Username