Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Restructured auth snaplet to improve haddock structure. Other misc wo…

…rk on

docs and tests.
  • Loading branch information...
commit e88b397294af2fcb7adbf5e4604e3022a91e056d 1 parent b494ed1
@mightybyte mightybyte authored
View
3  examples/App.hs
@@ -17,8 +17,7 @@ import Snap.Snaplet
import Snap.Snaplet.Heist
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Backends.CookieSession
-import Snap.Snaplet.Auth
-import Snap.Snaplet.Auth.Handlers
+import Snap.Snaplet.Auth hiding (session)
import Snap.Snaplet.Auth.Backends.JsonFile
import Text.Templating.Heist
View
36 snap.cabal
@@ -51,10 +51,6 @@ Library
Snap.Snaplet,
Snap.Snaplet.Heist,
Snap.Snaplet.Auth,
- Snap.Snaplet.Auth.AuthManager,
- Snap.Snaplet.Auth.Types,
- Snap.Snaplet.Auth.Handlers,
- Snap.Snaplet.Auth.SpliceHelpers,
Snap.Snaplet.Auth.Backends.JsonFile,
Snap.Snaplet.Session,
Snap.Snaplet.Session.Backends.CookieSession
@@ -62,7 +58,11 @@ Library
other-modules:
Snap.Loader.Devel.Evaluator,
Snap.Loader.Devel.Signal,
- Snap.Loader.Devel.TreeWatcher
+ Snap.Loader.Devel.TreeWatcher,
+ Snap.Snaplet.Auth.AuthManager,
+ Snap.Snaplet.Auth.Types,
+ Snap.Snaplet.Auth.Handlers,
+ Snap.Snaplet.Auth.SpliceHelpers,
Snap.Snaplet.HeistNoClass,
Snap.Snaplet.Internal.Initializer,
Snap.Snaplet.Internal.LensT,
@@ -163,32 +163,6 @@ Executable snap
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
-fno-warn-orphans
-Executable app
- hs-source-dirs: src, examples
- main-is: App.hs
-
- build-depends:
- base >= 4 && < 5,
- bytestring,
- mtl >= 2,
- old-locale,
- old-time,
- snap-core >= 0.6 && < 0.7,
- snap-server >= 0.6 && < 0.7,
- template-haskell >= 2.3 && < 2.7,
- text >= 0.11 && <0.12,
- time,
- unix-compat
-
- ghc-prof-options: -prof -auto-all
-
- if impl(ghc >= 6.12.0)
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
- -fno-warn-orphans -fno-warn-unused-do-bind
- else
- ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
- -fno-warn-orphans
-
source-repository head
type: git
location: https://github.com/snapframework/snap.git
View
341 src/Snap/Snaplet/Auth.hs
@@ -34,340 +34,39 @@ module Snap.Snaplet.Auth
, checkPasswordAndLogin
-- * Types
- , AuthManager
- , IAuthBackend
+ , AuthManager(..)
+ , IAuthBackend(..)
, AuthSettings(..)
, defAuthSettings
, AuthUser(..)
+ , defAuthUser
, UserId(..)
, Password(..)
, AuthFailure(..)
, BackendError(..)
+ , Role(..)
-- * Other Utilities
+ , encryptPassword
+ , checkPassword
, authenticatePassword
, setPassword
- )
- where
-
-import Control.Monad.State
-import Data.ByteString (ByteString)
-import Data.Maybe (isJust)
-import Data.Serialize hiding (get)
-import Data.Time
-import Data.Text.Encoding (decodeUtf8)
-import Data.Text (Text)
-import Web.ClientSession
-
-import Snap.Core
-import Snap.Snaplet
-import qualified Snap.Snaplet.Auth.AuthManager as AM
-import Snap.Snaplet.Auth.AuthManager (IAuthBackend(..), AuthManager(..))
-import Snap.Snaplet.Auth.Types
-import Snap.Snaplet.Session
-import Snap.Snaplet.Session.Common
-import Snap.Snaplet.Session.SecureCookie
-
-
-
-------------------------------------------------------------------------------
--- Higher level functions
---
-------------------------------------------------------------------------------
-
-
-------------------------------------------------------------------------------
--- | Create a new user from just a username and password
---
--- May throw a "DuplicateLogin" if given username is not unique
-createUser
- :: Text -- Username
- -> ByteString -- Password
- -> Handler b (AuthManager b) AuthUser
-createUser unm pwd = do
- (AuthManager r _ _ _ _ _ _ _) <- get
- liftIO $ AM.createUser r unm pwd
-
-
-------------------------------------------------------------------------------
--- | Lookup a user by her username, check given password and perform login
-loginByUsername
- :: ByteString -- ^ Username/login for user
- -> Password -- ^ Should be ClearText
- -> Bool -- ^ Set remember token?
- -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
-loginByUsername unm pwd rm = do
- AuthManager r _ _ _ cn rp sk _ <- get
- au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
- case au of
- Nothing -> return $ Left UserNotFound
- Just au' -> do
- res <- checkPasswordAndLogin au' pwd
- case res of
- Left e -> return $ Left e
- Right au'' -> do
- case rm of
- True -> do
- token <- liftIO $ randomToken 64
- setRememberToken sk cn rp token
- let au''' = au'' { userRememberToken = Just (decodeUtf8 token) }
- saveUser au'''
- return $ Right au'''
- False -> return $ Right au''
-
-
-------------------------------------------------------------------------------
--- | Remember user from the remember token if possible and perform login
-loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
-loginByRememberToken = do
- (AuthManager r _ _ _ rc rp sk _) <- get
- token <- getRememberToken sk rc rp
- au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
- case au of
- Just au' -> forceLogin au' >> return au
- Nothing -> return Nothing
-
-
-------------------------------------------------------------------------------
--- | Logout the active user
-logout :: Handler b (AuthManager b) ()
-logout = do
- s <- gets session
- withTop s $ withSession s removeSessionUserId
- AuthManager _ _ _ _ rc _ _ _ <- get
- forgetRememberToken rc
- modify (\mgr -> mgr { activeUser = Nothing } )
-
-
-------------------------------------------------------------------------------
--- | Return the current user; trying to remember from cookie if possible.
-currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
-currentUser = cacheOrLookup f
- where
- f = do
- (AuthManager r s _ _ _ _ _ _) <- get
- uid <- withTop s getSessionUserId
- case uid of
- Nothing -> loginByRememberToken
- Just uid' -> liftIO $ lookupByUserId r uid'
-
-
-------------------------------------------------------------------------------
--- | Convenience wrapper around 'rememberUser' that returns a bool result
-isLoggedIn :: Handler b (AuthManager b) Bool
-isLoggedIn = isJust `fmap` currentUser
-
-
-------------------------------------------------------------------------------
--- | Create or update a given user
---
--- May throw a 'BackendError' if something goes wrong.
-saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
-saveUser u = do
- (AuthManager r _ _ _ _ _ _ _) <- get
- liftIO $ save r u
-
-
-------------------------------------------------------------------------------
--- | Destroy the given user
---
--- May throw a 'BackendError' if something goes wrong.
-destroyUser :: AuthUser -> Handler b (AuthManager b) ()
-destroyUser u = do
- (AuthManager r _ _ _ _ _ _ _) <- get
- liftIO $ destroy r u
-
-
-------------------------------------------------------------------------------
--- Lower level helper functions
---
-------------------------------------------------------------------------------
-
-
-------------------------------------------------------------------------------
--- | Mutate an 'AuthUser', marking failed authentication
---
--- This will save the user to the backend.
-markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
-markAuthFail u = do
- (AuthManager r _ _ _ _ _ _ lo) <- get
- incFailCtr u >>= checkLockout lo >>= liftIO . save r
- where
- incFailCtr u' = return $ u'
- { userFailedLoginCount = userFailedLoginCount u' + 1}
- checkLockout lo u' = case lo of
- Nothing -> return u'
- Just (mx, wait) ->
- case userFailedLoginCount u' >= mx of
- True -> do
- now <- liftIO getCurrentTime
- let reopen = addUTCTime wait now
- return $ u' { userLockedOutUntil = Just reopen }
-
-
-------------------------------------------------------------------------------
--- | Mutate an 'AuthUser', marking successful authentication
---
--- This will save the user to the backend.
-markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
-markAuthSuccess u = do
- (AuthManager r _ _ _ _ _ _ _) <- get
- incLoginCtr u >>= updateIp >>= updateLoginTS
- >>= resetFailCtr >>= liftIO . save r
- where
- incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
- updateIp u' = do
- ip <- rqRemoteAddr `fmap` getRequest
- return $ u' { userLastLoginIp = userCurrentLoginIp u'
- , userCurrentLoginIp = Just ip }
- updateLoginTS u' = do
- now <- liftIO getCurrentTime
- return $
- u' { userCurrentLoginAt = Just now
- , userLastLoginAt = userCurrentLoginAt u' }
- resetFailCtr u' = return $
- u' { userFailedLoginCount = 0
- , userLockedOutUntil = Nothing }
-
-
-------------------------------------------------------------------------------
--- | Authenticate and log the user into the current session if successful.
---
--- This is a mid-level function exposed to allow roll-your-own ways of looking
--- up a user from the database.
---
--- This function will:
---
--- 1. Check the password
---
--- 2. Login the user into the current session
---
--- 3. Mark success/failure of the authentication trial on the user record
-checkPasswordAndLogin
- :: AuthUser -- ^ An existing user, somehow looked up from db
- -> Password -- ^ A ClearText password
- -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-checkPasswordAndLogin u pw =
- case userLockedOutUntil u of
- Just x -> do
- now <- liftIO getCurrentTime
- if now > x
- then auth u
- else return . Left $ LockedOut x
- Nothing -> auth u
- where
- auth user =
- case authenticatePassword user pw of
- Just e -> do
- markAuthFail user
- return $ Left e
- Nothing -> do
- forceLogin user
- modify (\mgr -> mgr { activeUser = Just user })
- user' <- markAuthSuccess user
- return $ Right user'
-
-
-------------------------------------------------------------------------------
--- | Login and persist the given 'AuthUser' in the active session
---
--- Meant to be used if you have other means of being sure that the person is
--- who she says she is.
-forceLogin
- :: AuthUser
- -- ^ An existing user, somehow looked up from db
- -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
-forceLogin u = do
- AuthManager _ s _ _ _ _ _ _ <- get
- withSession s $ do
- case userId u of
- Just x -> do
- withTop s (setSessionUserId x)
- return $ Right u
- Nothing -> return . Left $
- AuthError "forceLogin: Can't force the login of a user without userId"
-
-
-
-------------------------------------------------------------------------------
--- Internal, non-exported helpers
---
-------------------------------------------------------------------------------
-
-
-getRememberToken :: (Serialize t, MonadSnap m)
- => Key
- -> ByteString
- -> Maybe Int
- -> m (Maybe t)
-getRememberToken sk rc rp = getSecureCookie rc sk rp
+ -- * Handlers
+ , registerUser
+ , loginUser
+ , logoutUser
+ , requireUser
-setRememberToken :: (Serialize t, MonadSnap m)
- => Key
- -> ByteString
- -> Maybe Int
- -> t
- -> m ()
-setRememberToken sk rc rp token = setSecureCookie rc sk rp token
-
-
-forgetRememberToken :: MonadSnap m => ByteString -> m ()
-forgetRememberToken rc = expireCookie rc (Just "/")
-
-
-------------------------------------------------------------------------------
--- | Set the current user's 'UserId' in the active session
-setSessionUserId :: UserId -> Handler b SessionManager ()
-setSessionUserId (UserId t) = setInSession "__user_id" t
-
-
-------------------------------------------------------------------------------
--- | Remove 'UserId' from active session, effectively logging the user out.
-removeSessionUserId :: Handler b SessionManager ()
-removeSessionUserId = deleteFromSession "__user_id"
-
-
-------------------------------------------------------------------------------
--- | Get the current user's 'UserId' from the active session
-getSessionUserId :: Handler b SessionManager (Maybe UserId)
-getSessionUserId = do
- uid <- getFromSession "__user_id"
- return $ uid >>= return . UserId
-
-
-------------------------------------------------------------------------------
--- | Check password for a given user.
---
--- Returns "Nothing" if check is successful and an "IncorrectPassword" error
--- otherwise
-authenticatePassword
- :: AuthUser -- ^ Looked up from the back-end
- -> Password -- ^ Check against this password
- -> Maybe AuthFailure
-authenticatePassword u pw = auth
+ -- * Splice helpers
+ , addAuthSplices
+ , ifLoggedIn
+ , ifLoggedOut
+ )
where
- auth = case userPassword u of
- Nothing -> Just PasswordMissing
- Just upw -> check $ checkPassword pw upw
- check b = if b then Nothing else Just IncorrectPassword
-
-
-------------------------------------------------------------------------------
--- | Wrap lookups around request-local cache
-cacheOrLookup
- :: Handler b (AuthManager b) (Maybe AuthUser)
- -- ^ Lookup action to perform if request local cache is empty
- -> Handler b (AuthManager b) (Maybe AuthUser)
-cacheOrLookup f = do
- au <- gets activeUser
- if isJust au
- then return au
- else do
- au' <- f
- modify (\mgr -> mgr { activeUser = au' })
- return au'
-
+import Snap.Snaplet.Auth.AuthManager
+import Snap.Snaplet.Auth.Handlers
+import Snap.Snaplet.Auth.SpliceHelpers
+import Snap.Snaplet.Auth.Types
View
6 src/Snap/Snaplet/Auth/AuthManager.hs
@@ -14,7 +14,7 @@ module Snap.Snaplet.Auth.AuthManager
, IAuthBackend(..)
-- * Context-free Operations
- , createUser
+ , buildAuthUser
) where
@@ -33,7 +33,7 @@ import Snap.Snaplet.Auth.Types
-- | Create a new user from just a username and password
--
-- May throw a "DuplicateLogin" if given username is not unique
-createUser
+buildAuthUser
:: (IAuthBackend r)
=> r
-- ^ An auth backend
@@ -42,7 +42,7 @@ createUser
-> ByteString
-- ^ Password
-> IO AuthUser
-createUser r unm pass = do
+buildAuthUser r unm pass = do
now <- getCurrentTime
let au = defAuthUser {
userLogin = unm
View
2  src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -28,7 +28,7 @@ import System.Directory
import Snap.Snaplet
import Snap.Snaplet.Auth.Types
-import Snap.Snaplet.Auth.AuthManager hiding (createUser)
+import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Session
View
321 src/Snap/Snaplet/Auth/Handlers.hs
@@ -10,23 +10,327 @@
-}
-module Snap.Snaplet.Auth.Handlers
- (
- registerUser
- , loginUser
- , logoutUser
- , requireUser
- ) where
+module Snap.Snaplet.Auth.Handlers where
import Control.Monad.CatchIO (throw)
import Control.Monad.State
import Data.ByteString (ByteString)
import Data.Lens.Lazy
+import Data.Maybe (isJust)
+import Data.Serialize hiding (get)
+import Data.Time
import Data.Text.Encoding (decodeUtf8)
+import Data.Text (Text)
+import Web.ClientSession
import Snap.Core
-import Snap.Snaplet.Auth
import Snap.Snaplet
+import Snap.Snaplet.Auth.AuthManager
+import Snap.Snaplet.Auth.Types
+import Snap.Snaplet.Session
+import Snap.Snaplet.Session.Common
+import Snap.Snaplet.Session.SecureCookie
+
+
+
+------------------------------------------------------------------------------
+-- Higher level functions
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- | Create a new user from just a username and password
+--
+-- May throw a "DuplicateLogin" if given username is not unique
+createUser
+ :: Text -- Username
+ -> ByteString -- Password
+ -> Handler b (AuthManager b) AuthUser
+createUser unm pwd = do
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ liftIO $ buildAuthUser r unm pwd
+
+
+------------------------------------------------------------------------------
+-- | Lookup a user by her username, check given password and perform login
+loginByUsername
+ :: ByteString -- ^ Username/login for user
+ -> Password -- ^ Should be ClearText
+ -> Bool -- ^ Set remember token?
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
+loginByUsername unm pwd rm = do
+ AuthManager r _ _ _ cn rp sk _ <- get
+ au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
+ case au of
+ Nothing -> return $ Left UserNotFound
+ Just au' -> do
+ res <- checkPasswordAndLogin au' pwd
+ case res of
+ Left e -> return $ Left e
+ Right au'' -> do
+ case rm of
+ True -> do
+ token <- liftIO $ randomToken 64
+ setRememberToken sk cn rp token
+ let au''' = au'' { userRememberToken = Just (decodeUtf8 token) }
+ saveUser au'''
+ return $ Right au'''
+ False -> return $ Right au''
+
+
+------------------------------------------------------------------------------
+-- | Remember user from the remember token if possible and perform login
+loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
+loginByRememberToken = do
+ (AuthManager r _ _ _ rc rp sk _) <- get
+ token <- getRememberToken sk rc rp
+ au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
+ case au of
+ Just au' -> forceLogin au' >> return au
+ Nothing -> return Nothing
+
+
+------------------------------------------------------------------------------
+-- | Logout the active user
+logout :: Handler b (AuthManager b) ()
+logout = do
+ s <- gets session
+ withTop s $ withSession s removeSessionUserId
+ AuthManager _ _ _ _ rc _ _ _ <- get
+ forgetRememberToken rc
+ modify (\mgr -> mgr { activeUser = Nothing } )
+
+
+------------------------------------------------------------------------------
+-- | Return the current user; trying to remember from cookie if possible.
+currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
+currentUser = cacheOrLookup f
+ where
+ f = do
+ (AuthManager r s _ _ _ _ _ _) <- get
+ uid <- withTop s getSessionUserId
+ case uid of
+ Nothing -> loginByRememberToken
+ Just uid' -> liftIO $ lookupByUserId r uid'
+
+
+------------------------------------------------------------------------------
+-- | Convenience wrapper around 'rememberUser' that returns a bool result
+isLoggedIn :: Handler b (AuthManager b) Bool
+isLoggedIn = isJust `fmap` currentUser
+
+
+------------------------------------------------------------------------------
+-- | Create or update a given user
+--
+-- May throw a 'BackendError' if something goes wrong.
+saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
+saveUser u = do
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ liftIO $ save r u
+
+
+------------------------------------------------------------------------------
+-- | Destroy the given user
+--
+-- May throw a 'BackendError' if something goes wrong.
+destroyUser :: AuthUser -> Handler b (AuthManager b) ()
+destroyUser u = do
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ liftIO $ destroy r u
+
+
+------------------------------------------------------------------------------
+-- Lower level helper functions
+--
+------------------------------------------------------------------------------
+
+
+------------------------------------------------------------------------------
+-- | Mutate an 'AuthUser', marking failed authentication
+--
+-- This will save the user to the backend.
+markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthFail u = do
+ (AuthManager r _ _ _ _ _ _ lo) <- get
+ incFailCtr u >>= checkLockout lo >>= liftIO . save r
+ where
+ incFailCtr u' = return $ u'
+ { userFailedLoginCount = userFailedLoginCount u' + 1}
+ checkLockout lo u' = case lo of
+ Nothing -> return u'
+ Just (mx, wait) ->
+ case userFailedLoginCount u' >= mx of
+ True -> do
+ now <- liftIO getCurrentTime
+ let reopen = addUTCTime wait now
+ return $ u' { userLockedOutUntil = Just reopen }
+
+
+------------------------------------------------------------------------------
+-- | Mutate an 'AuthUser', marking successful authentication
+--
+-- This will save the user to the backend.
+markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthSuccess u = do
+ (AuthManager r _ _ _ _ _ _ _) <- get
+ incLoginCtr u >>= updateIp >>= updateLoginTS
+ >>= resetFailCtr >>= liftIO . save r
+ where
+ incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
+ updateIp u' = do
+ ip <- rqRemoteAddr `fmap` getRequest
+ return $ u' { userLastLoginIp = userCurrentLoginIp u'
+ , userCurrentLoginIp = Just ip }
+ updateLoginTS u' = do
+ now <- liftIO getCurrentTime
+ return $
+ u' { userCurrentLoginAt = Just now
+ , userLastLoginAt = userCurrentLoginAt u' }
+ resetFailCtr u' = return $
+ u' { userFailedLoginCount = 0
+ , userLockedOutUntil = Nothing }
+
+
+------------------------------------------------------------------------------
+-- | Authenticate and log the user into the current session if successful.
+--
+-- This is a mid-level function exposed to allow roll-your-own ways of looking
+-- up a user from the database.
+--
+-- This function will:
+--
+-- 1. Check the password
+--
+-- 2. Login the user into the current session
+--
+-- 3. Mark success/failure of the authentication trial on the user record
+checkPasswordAndLogin
+ :: AuthUser -- ^ An existing user, somehow looked up from db
+ -> Password -- ^ A ClearText password
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+checkPasswordAndLogin u pw =
+ case userLockedOutUntil u of
+ Just x -> do
+ now <- liftIO getCurrentTime
+ if now > x
+ then auth u
+ else return . Left $ LockedOut x
+ Nothing -> auth u
+ where
+ auth user =
+ case authenticatePassword user pw of
+ Just e -> do
+ markAuthFail user
+ return $ Left e
+ Nothing -> do
+ forceLogin user
+ modify (\mgr -> mgr { activeUser = Just user })
+ user' <- markAuthSuccess user
+ return $ Right user'
+
+
+------------------------------------------------------------------------------
+-- | Login and persist the given 'AuthUser' in the active session
+--
+-- Meant to be used if you have other means of being sure that the person is
+-- who she says she is.
+forceLogin
+ :: AuthUser
+ -- ^ An existing user, somehow looked up from db
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+forceLogin u = do
+ AuthManager _ s _ _ _ _ _ _ <- get
+ withSession s $ do
+ case userId u of
+ Just x -> do
+ withTop s (setSessionUserId x)
+ return $ Right u
+ Nothing -> return . Left $
+ AuthError "forceLogin: Can't force the login of a user without userId"
+
+
+
+------------------------------------------------------------------------------
+-- Internal, non-exported helpers
+--
+------------------------------------------------------------------------------
+
+
+getRememberToken :: (Serialize t, MonadSnap m)
+ => Key
+ -> ByteString
+ -> Maybe Int
+ -> m (Maybe t)
+getRememberToken sk rc rp = getSecureCookie rc sk rp
+
+
+setRememberToken :: (Serialize t, MonadSnap m)
+ => Key
+ -> ByteString
+ -> Maybe Int
+ -> t
+ -> m ()
+setRememberToken sk rc rp token = setSecureCookie rc sk rp token
+
+
+forgetRememberToken :: MonadSnap m => ByteString -> m ()
+forgetRememberToken rc = expireCookie rc (Just "/")
+
+
+------------------------------------------------------------------------------
+-- | Set the current user's 'UserId' in the active session
+setSessionUserId :: UserId -> Handler b SessionManager ()
+setSessionUserId (UserId t) = setInSession "__user_id" t
+
+
+------------------------------------------------------------------------------
+-- | Remove 'UserId' from active session, effectively logging the user out.
+removeSessionUserId :: Handler b SessionManager ()
+removeSessionUserId = deleteFromSession "__user_id"
+
+
+------------------------------------------------------------------------------
+-- | Get the current user's 'UserId' from the active session
+getSessionUserId :: Handler b SessionManager (Maybe UserId)
+getSessionUserId = do
+ uid <- getFromSession "__user_id"
+ return $ uid >>= return . UserId
+
+
+------------------------------------------------------------------------------
+-- | Check password for a given user.
+--
+-- Returns "Nothing" if check is successful and an "IncorrectPassword" error
+-- otherwise
+authenticatePassword
+ :: AuthUser -- ^ Looked up from the back-end
+ -> Password -- ^ Check against this password
+ -> Maybe AuthFailure
+authenticatePassword u pw = auth
+ where
+ auth = case userPassword u of
+ Nothing -> Just PasswordMissing
+ Just upw -> check $ checkPassword pw upw
+ check b = if b then Nothing else Just IncorrectPassword
+
+
+------------------------------------------------------------------------------
+-- | Wrap lookups around request-local cache
+cacheOrLookup
+ :: Handler b (AuthManager b) (Maybe AuthUser)
+ -- ^ Lookup action to perform if request local cache is empty
+ -> Handler b (AuthManager b) (Maybe AuthUser)
+cacheOrLookup f = do
+ au <- gets activeUser
+ if isJust au
+ then return au
+ else do
+ au' <- f
+ modify (\mgr -> mgr { activeUser = au' })
+ return au'
+
------------------------------------------------------------------------------
@@ -99,3 +403,4 @@ requireUser
requireUser auth bad good = do
loggedIn <- withTop auth isLoggedIn
if loggedIn then good else bad
+
View
3  src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -21,8 +21,9 @@ import Data.Lens.Lazy
import qualified Text.XmlHtml as X
import Text.Templating.Heist
-import Snap.Snaplet.Auth
import Snap.Snaplet
+import Snap.Snaplet.Auth.AuthManager
+import Snap.Snaplet.Auth.Handlers
import Snap.Snaplet.Heist
View
2  src/Snap/Snaplet/Auth/Types.hs
@@ -97,6 +97,8 @@ data AuthUser = AuthUser
} deriving (Show,Eq)
+------------------------------------------------------------------------------
+-- | Default AuthUser that has all empty values.
defAuthUser :: AuthUser
defAuthUser = AuthUser {
userId = Nothing
View
3  src/Snap/Snaplet/Heist.hs
@@ -34,6 +34,7 @@ module Snap.Snaplet.Heist
, Unclassed.SnapletSplice
, Unclassed.liftHeist
, Unclassed.liftHandler
+ , Unclassed.liftAppHandler
, Unclassed.liftWith
, Unclassed.bindSnapletSplices
@@ -88,7 +89,7 @@ addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)
------------------------------------------------------------------------------
-- | Adds templates to the Heist TemplateState, and lets you specify where
--- they are fonud in the filesystem.
+-- they are found in the filesystem.
addTemplatesAt :: HasHeist b => ByteString -> FilePath -> Initializer b v ()
addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)
View
1  test/runTestsAndCoverage.sh
@@ -31,6 +31,7 @@ EXCLUDES='Main
Blackbox.App
Blackbox.BarSnaplet
Blackbox.Common
+Blackbox.EmbeddedSnaplet
Blackbox.FooSnaplet
Blackbox.Tests
Blackbox.Types
View
1  test/suite/Snap/TestCommon.hs
@@ -32,6 +32,7 @@ testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
flip onException (setCurrentDirectory cwd >>
removeDirectoryRecursive projectPath) $ do
makeWorkDirectory projectPath
+ putStrLn $ "Changing directory to "++projectPath
setCurrentDirectory projectPath
snapExe <- findSnap
systemOrDie $ snapExe ++ " init " ++ snapInitArgs
View
54 test/suite/TestSuite.hs
@@ -4,10 +4,16 @@ module Main where
import Control.Concurrent
import Control.Exception
+import Control.Monad
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.ByteString.Char8 as S
+import qualified Network.HTTP.Enumerator as HTTP
import Snap.Http.Server.Config
import Snap.Snaplet
import System.Directory
-import Test.Framework (defaultMain)
+import Test.Framework (defaultMain, Test)
+import Test.Framework.Providers.HUnit
+import Test.HUnit hiding (Test, path)
import Snap.Http.Server (simpleHttpServe)
import Blackbox.App
@@ -16,6 +22,7 @@ import qualified Snap.Snaplet.Internal.Lensed.Tests
import qualified Snap.Snaplet.Internal.LensT.Tests
import qualified Snap.Snaplet.Internal.RST.Tests
import qualified Snap.Snaplet.Internal.Tests
+import Snap.TestCommon
------------------------------------------------------------------------------
@@ -25,6 +32,10 @@ main = do
Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl"
Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"
+ -- Test generated projects before we start the test server.
+ -- TODO Get this working properly. Might have to put in the test list.
+-- defaultMain [testBarebones, testDefault]
+
tid <- startServer
defaultMain tests
throwTo tid UserInterrupt
@@ -34,6 +45,8 @@ main = do
, Snap.Snaplet.Internal.LensT.Tests.tests
, Snap.Snaplet.Internal.RST.Tests.tests
, Snap.Snaplet.Internal.Tests.tests
+-- , testBarebones
+-- , testDefault
]
startServer :: IO ThreadId
@@ -51,17 +64,32 @@ startServer = do
doCleanup
---testBarebones :: Test
---testBarebones = testCase "snap/barebones" go
--- where
--- go = testGeneratedProject "barebonesTest"
--- "-b"
--- ""
--- port
--- testIt
--- port = 9990
--- testIt = do
--- body <- HTTP.simpleHttp "http://127.0.0.1:9990"
--- assertEqual "server not up" "hello world" body
+testBarebones :: Test
+testBarebones = testCase "snap/barebones" go
+ where
+ go = testGeneratedProject "barebonesTest"
+ "-b"
+ ""
+ port
+ testIt
+ port = 9990
+ testIt = do
+ body <- HTTP.simpleHttp "http://127.0.0.1:9990"
+ assertEqual "server not up" "hello world" body
+
+testDefault :: Test
+testDefault = testCase "snap/default" go
+ where
+ go = testGeneratedProject "defaultTest"
+ ""
+ ""
+ port
+ testIt
+ port = 9991
+ testIt = do
+ body <- liftM (S.concat . L.toChunks) $
+ HTTP.simpleHttp "http://127.0.0.1:9991"
+ assertBool "response contains phrase 'it works!'"
+ $ "It works!" `S.isInfixOf` body
Please sign in to comment.
Something went wrong with that request. Please try again.