Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Code cleanup for aesthetics / readability

  • Loading branch information...
commit 635004fb4d5bd59f2ba69fae1487a45cf32eb021 1 parent d9b2a8b
Gregory Collins gregorycollins authored
6 src/Snap/Snaplet/Auth.hs
View
@@ -8,9 +8,9 @@
It exports a number of high-level functions to be used directly in your
application handlers.
- We also export a number of mid-level functions that
- should be helpful when you are integrating with another way of confirming
- the authentication of login requests.
+ We also export a number of mid-level functions that should be helpful when
+ you are integrating with another way of confirming the authentication of
+ login requests.
-}
80 src/Snap/Snaplet/Auth/AuthManager.hs
View
@@ -1,8 +1,7 @@
-
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.Auth.AuthManager
@@ -18,11 +17,11 @@ module Snap.Snaplet.Auth.AuthManager
) where
-
+------------------------------------------------------------------------------
import Data.ByteString (ByteString)
import Data.Lens.Lazy
-import Data.Time
import Data.Text (Text)
+import Data.Time
import Web.ClientSession
import Snap.Snaplet
@@ -30,23 +29,19 @@ import Snap.Snaplet.Session
import Snap.Snaplet.Auth.Types
------------------------------------------------------------------------------
--- | Create a new user from just a username and password
+-- | Creates a new user from a username and password.
--
-- May throw a "DuplicateLogin" if given username is not unique
-buildAuthUser
- :: (IAuthBackend r)
- => r
- -- ^ An auth backend
- -> Text
- -- ^ Username
- -> ByteString
- -- ^ Password
- -> IO AuthUser
+buildAuthUser :: IAuthBackend r =>
+ r -- ^ An auth backend
+ -> Text -- ^ Username
+ -> ByteString -- ^ Password
+ -> IO AuthUser
buildAuthUser r unm pass = do
now <- getCurrentTime
let au = defAuthUser {
- userLogin = unm
- , userPassword = Nothing
+ userLogin = unm
+ , userPassword = Nothing
, userCreatedAt = Just now
, userUpdatedAt = Just now
}
@@ -59,44 +54,39 @@ buildAuthUser r unm pass = do
--
-- Backend operations may throw 'BackendError's
class IAuthBackend r where
-
-- | Needs to create or update the given 'AuthUser' record
- save :: r -> AuthUser -> IO AuthUser
-
- lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
-
- lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
-
- lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
-
- destroy :: r -> AuthUser -> IO ()
+ save :: r -> AuthUser -> IO AuthUser
+ lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
+ lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
+ lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
+ destroy :: r -> AuthUser -> IO ()
------------------------------------------------------------------------------
-- | Abstract data type holding all necessary information for auth operation
data AuthManager b = forall r. IAuthBackend r => AuthManager {
- backend :: r
- -- ^ Storage back-end
+ backend :: r
+ -- ^ Storage back-end
- , session :: Lens b (Snaplet SessionManager)
- -- ^ A lens pointer to a SessionManager
+ , session :: Lens b (Snaplet SessionManager)
+ -- ^ A lens pointer to a SessionManager
- , activeUser :: Maybe AuthUser
- -- ^ A per-request logged-in user cache
+ , activeUser :: Maybe AuthUser
+ -- ^ A per-request logged-in user cache
- , minPasswdLen :: Int
- -- ^ Password length range
+ , minPasswdLen :: Int
+ -- ^ Password length range
- , rememberCookieName :: ByteString
- -- ^ Cookie name for the remember token
+ , rememberCookieName :: ByteString
+ -- ^ Cookie name for the remember token
- , rememberPeriod :: Maybe Int
- -- ^ Remember period in seconds. Defaults to 2 weeks.
+ , rememberPeriod :: Maybe Int
+ -- ^ Remember period in seconds. Defaults to 2 weeks.
- , siteKey :: Key
- -- ^ A unique encryption key used to encrypt remember cookie
+ , siteKey :: Key
+ -- ^ A unique encryption key used to encrypt remember cookie
- , lockout :: Maybe (Int, NominalDiffTime)
- -- ^ Lockout after x tries, re-allow entry after y seconds
- }
+ , lockout :: Maybe (Int, NominalDiffTime)
+ -- ^ Lockout after x tries, re-allow entry after y seconds
+ }
330 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
View
@@ -37,29 +37,30 @@ import Snap.Snaplet.Session
------------------------------------------------------------------------------
-- | Initialize a JSON file backed 'AuthManager'
-initJsonFileAuthManager
- :: AuthSettings
- -- ^ Authentication settings for your app
- -> Lens b (Snaplet SessionManager)
- -- ^ Lens into a 'SessionManager' auth snaplet will use
- -> FilePath
- -- ^ Where to store user data as JSON
- -> SnapletInit b (AuthManager b)
+initJsonFileAuthManager :: AuthSettings
+ -- ^ Authentication settings for your app
+ -> Lens b (Snaplet SessionManager)
+ -- ^ Lens into a 'SessionManager' auth snaplet will
+ -- use
+ -> FilePath
+ -- ^ Where to store user data as JSON
+ -> SnapletInit b (AuthManager b)
initJsonFileAuthManager s l db =
- makeSnaplet "JsonFileAuthManager"
+ makeSnaplet
+ "JsonFileAuthManager"
"A snaplet providing user authentication using a JSON-file backend"
Nothing $ liftIO $ do
key <- getKey (asSiteKey s)
jsonMgr <- mkJsonAuthMgr db
- return $ AuthManager {
- backend = jsonMgr
- , session = l
- , activeUser = Nothing
- , minPasswdLen = asMinPasswdLen s
+ return $! AuthManager {
+ backend = jsonMgr
+ , session = l
+ , activeUser = Nothing
+ , minPasswdLen = asMinPasswdLen s
, rememberCookieName = asRememberCookieName s
- , rememberPeriod = asRememberPeriod s
- , siteKey = key
- , lockout = asLockout s
+ , rememberPeriod = asRememberPeriod s
+ , siteKey = key
+ , lockout = asLockout s
}
@@ -71,51 +72,55 @@ mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager
mkJsonAuthMgr fp = do
db <- loadUserCache fp
let db' = case db of
- Left e -> error e
+ Left e -> error e
Right x -> x
cache <- newTVarIO db'
- return $ JsonFileAuthManager {
+
+ return $! JsonFileAuthManager {
memcache = cache
- , dbfile = fp
+ , dbfile = fp
}
+------------------------------------------------------------------------------
type UserIdCache = Map UserId AuthUser
-
instance ToJSON UserIdCache where
toJSON m = toJSON $ HM.toList m
-
instance FromJSON UserIdCache where
parseJSON = fmap HM.fromList . parseJSON
-
+------------------------------------------------------------------------------
type LoginUserCache = Map Text UserId
+------------------------------------------------------------------------------
type RemTokenUserCache = Map Text UserId
--- JSON user back-end stores the user data and indexes for login and token
+------------------------------------------------------------------------------
+-- | JSON user back-end stores the user data and indexes for login and token
-- based logins.
data UserCache = UserCache {
- uidCache :: UserIdCache -- the actual datastore
- , loginCache :: LoginUserCache -- fast lookup for login field
- , tokenCache :: RemTokenUserCache -- fast lookup for remember tokens
- , uidCounter :: Int -- user id counter
+ uidCache :: UserIdCache -- ^ the actual datastore
+ , loginCache :: LoginUserCache -- ^ fast lookup for login field
+ , tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens
+ , uidCounter :: Int -- ^ user id counter
}
+------------------------------------------------------------------------------
defUserCache :: UserCache
defUserCache = UserCache {
- uidCache = HM.empty
+ uidCache = HM.empty
, loginCache = HM.empty
, tokenCache = HM.empty
, uidCounter = 0
}
+------------------------------------------------------------------------------
loadUserCache :: FilePath -> IO (Either String UserCache)
loadUserCache fp = do
chk <- doesFileExist fp
@@ -123,117 +128,136 @@ loadUserCache fp = do
True -> do
d <- B.readFile fp
case Atto.parseOnly json d of
- Left e -> return . Left $ "Can't open JSON auth backend. Error: " ++ e
+ Left e -> return $! Left $
+ "Can't open JSON auth backend. Error: " ++ e
Right v -> case fromJSON v of
- Error e -> return . Left $
- "Malformed JSON auth data store. Error: " ++ e
- Success db -> return $ Right db
+ Error e -> return $! Left $
+ "Malformed JSON auth data store. Error: " ++ e
+ Success db -> return $! Right db
False -> do
putStrLn "User JSON datafile not found. Creating a new one."
return $ Right defUserCache
+------------------------------------------------------------------------------
data JsonFileAuthManager = JsonFileAuthManager {
memcache :: TVar UserCache
- , dbfile :: FilePath
+ , dbfile :: FilePath
}
-instance IAuthBackend JsonFileAuthManager where
-
- save mgr u = do
- now <- getCurrentTime
+------------------------------------------------------------------------------
+jsonFileSave :: JsonFileAuthManager -> AuthUser -> IO AuthUser
+jsonFileSave mgr u = do
+ now <- getCurrentTime
oldByLogin <- lookupByLogin mgr (userLogin u)
- oldById <- case userId u of
- Nothing -> return Nothing
- Just x -> lookupByUserId mgr x
+ oldById <- case userId u of
+ Nothing -> return Nothing
+ Just x -> lookupByUserId mgr x
+
res <- atomically $ do
cache <- readTVar (memcache mgr)
- res <- case userId u of
- Nothing -> create cache now oldByLogin
- Just _ -> update cache now oldById
+ res <- case userId u of
+ Nothing -> create cache now oldByLogin
+ Just _ -> update cache now oldById
case res of
- Left e -> return $ Left e
+ Left e -> return $! Left e
Right (cache', u') -> do
writeTVar (memcache mgr) cache'
- return $ Right (cache', u')
+ return $! Right $! (cache', u')
+
case res of
- Left e -> throw e
+ Left e -> throw e
Right (cache', u') -> do
dumpToDisk cache'
- return u'
- where
- create
- :: UserCache
- -> UTCTime
- -> (Maybe AuthUser)
- -> STM (Either BackendError (UserCache, AuthUser))
- create cache now old = do
- case old of
- Just _ -> return $ Left DuplicateLogin
- Nothing -> do
- new <- do
- let uid' = UserId . showT $ uidCounter cache + 1
- let u' = u { userUpdatedAt = Just now, userId = Just uid' }
- return $ cache {
- uidCache = HM.insert uid' u' $ uidCache cache
- , loginCache = HM.insert (userLogin u') uid' $ loginCache cache
- , tokenCache = case userRememberToken u' of
- Nothing -> tokenCache cache
- Just x -> HM.insert x uid' $ tokenCache cache
- , uidCounter = uidCounter cache + 1
- }
- return $ Right (new, getLastUser new)
-
-
- -- lookup old record, see what's changed and update indexes accordingly
- update
- :: UserCache
- -> UTCTime
- -> (Maybe AuthUser)
- -> STM (Either BackendError (UserCache, AuthUser))
- update cache now old =
- case old of
- Nothing -> return $ Left $
- BackendError "User not found; should never happen"
- Just x -> do
- let oldLogin = userLogin x
- let oldToken = userRememberToken x
- let uid = fromJust $ userId u
- let newLogin = userLogin u
- let newToken = userRememberToken u
- let lc = if oldLogin /= userLogin u
- then HM.insert newLogin uid . HM.delete oldLogin $
- loginCache cache
- else loginCache cache
- let tc = if oldToken /= newToken && isJust oldToken
- then HM.delete (fromJust oldToken) $ loginCache cache
- else tokenCache cache
- let tc' = case newToken of
- Just t -> HM.insert t uid tc
- Nothing -> tc
- let u' = u { userUpdatedAt = Just now }
- let new = cache {
- uidCache = HM.insert uid u' $ uidCache cache
- , loginCache = lc
- , tokenCache = tc'
- }
- return $ Right (new, u')
-
- -- Sync user database to disk
- -- Need to implement a mutex here; simult syncs could screw things up
- dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)
-
- -- Get's the last added user
- getLastUser cache = maybe e id $ getUser cache uid
- where uid = UserId . showT $ uidCounter cache
- e = error "getLastUser failed. This should not happen."
+ return $! u'
+
+ where
+ --------------------------------------------------------------------------
+ create :: UserCache
+ -> UTCTime
+ -> (Maybe AuthUser)
+ -> STM (Either BackendError (UserCache, AuthUser))
+ create cache now old = do
+ case old of
+ Just _ -> return $! Left DuplicateLogin
+ Nothing -> do
+ new <- do
+ let uid' = UserId . showT $ uidCounter cache + 1
+ let u' = u { userUpdatedAt = Just now, userId = Just uid' }
+ return $! cache {
+ uidCache = HM.insert uid' u' $ uidCache cache
+ , loginCache = HM.insert (userLogin u') uid' $ loginCache cache
+ , tokenCache = case userRememberToken u' of
+ Nothing -> tokenCache cache
+ Just x -> HM.insert x uid' $ tokenCache cache
+ , uidCounter = uidCounter cache + 1
+ }
+ return $! Right (new, getLastUser new)
+
+ --------------------------------------------------------------------------
+ -- lookup old record, see what's changed and update indexes accordingly
+ update :: UserCache
+ -> UTCTime
+ -> (Maybe AuthUser)
+ -> STM (Either BackendError (UserCache, AuthUser))
+ update cache now old =
+ case old of
+ Nothing -> return $! Left $
+ BackendError "User not found; should never happen"
+ Just x -> do
+ let oldLogin = userLogin x
+ let oldToken = userRememberToken x
+ let uid = fromJust $ userId u
+ let newLogin = userLogin u
+ let newToken = userRememberToken u
+
+ let lc = if oldLogin /= userLogin u
+ then HM.insert newLogin uid $
+ HM.delete oldLogin $
+ loginCache cache
+ else loginCache cache
+
+ let tc = if oldToken /= newToken && isJust oldToken
+ then HM.delete (fromJust oldToken) $ loginCache cache
+ else tokenCache cache
+
+ let tc' = case newToken of
+ Just t -> HM.insert t uid tc
+ Nothing -> tc
+
+ let u' = u { userUpdatedAt = Just now }
+
+ let new = cache {
+ uidCache = HM.insert uid u' $ uidCache cache
+ , loginCache = lc
+ , tokenCache = tc'
+ }
+
+ return $! Right (new, u')
+
+ --------------------------------------------------------------------------
+ -- Sync user database to disk
+ -- Need to implement a mutex here; simult syncs could screw things up
+ dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)
+
+ --------------------------------------------------------------------------
+ -- Gets the last added user
+ getLastUser cache = maybe e id $ getUser cache uid
+ where
+ uid = UserId . showT $ uidCounter cache
+ e = error "getLastUser failed. This should not happen."
+------------------------------------------------------------------------------
+instance IAuthBackend JsonFileAuthManager where
+ save = jsonFileSave
+
destroy = error "JsonFile: destroy is not yet implemented"
lookupByUserId mgr uid = withCache mgr f
- where f cache = getUser cache uid
+ where
+ f cache = getUser cache uid
lookupByLogin mgr login = withCache mgr f
where
@@ -243,33 +267,42 @@ instance IAuthBackend JsonFileAuthManager where
lookupByRememberToken mgr token = withCache mgr f
where
f cache = getUid >>= getUser cache
- where getUid = HM.lookup token (tokenCache cache)
+ where
+ getUid = HM.lookup token (tokenCache cache)
+------------------------------------------------------------------------------
withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache mgr f = atomically $ do
cache <- readTVar $ memcache mgr
- return $ f cache
+ return $! f cache
+------------------------------------------------------------------------------
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser cache uid = HM.lookup uid (uidCache cache)
------------------------------------------------------------------------------
--- JSON Instances
---
-------------------------------------------------------------------------------
+showT :: Int -> Text
+showT = T.pack . show
+ --------------------
+ -- JSON Instances --
+ --------------------
+
+------------------------------------------------------------------------------
instance ToJSON UserCache where
toJSON uc = object
- [ "uidCache" .= uidCache uc
+ [ "uidCache" .= uidCache uc
, "loginCache" .= loginCache uc
, "tokenCache" .= tokenCache uc
- , "uidCounter" .= uidCounter uc]
+ , "uidCounter" .= uidCounter uc
+ ]
+------------------------------------------------------------------------------
instance FromJSON UserCache where
parseJSON (Object v) =
UserCache
@@ -279,57 +312,4 @@ instance FromJSON UserCache where
<*> v .: "uidCounter"
parseJSON _ = error "Unexpected JSON input"
-instance ToJSON AuthUser where
- toJSON u = object
- [ "uid" .= userId u
- , "login" .= userLogin u
- , "pw" .= userPassword u
- , "activated_at" .= userActivatedAt u
- , "suspended_at" .= userSuspendedAt u
- , "remember_token" .= userRememberToken u
- , "login_count" .= userLoginCount u
- , "failed_login_count" .= userFailedLoginCount u
- , "locked_until" .= userLockedOutUntil u
- , "current_login_at" .= userCurrentLoginAt u
- , "last_login_at" .= userLastLoginAt u
- , "current_ip" .= userCurrentLoginIp u
- , "last_ip" .= userLastLoginIp u
- , "created_at" .= userCreatedAt u
- , "updated_at" .= userUpdatedAt u
- , "meta" .= userMeta u ]
-
-
-instance FromJSON AuthUser where
- parseJSON (Object v) = AuthUser
- <$> v .: "uid"
- <*> v .: "login"
- <*> v .: "pw"
- <*> v .: "activated_at"
- <*> v .: "suspended_at"
- <*> v .: "remember_token"
- <*> v .: "login_count"
- <*> v .: "failed_login_count"
- <*> v .: "locked_until"
- <*> v .: "current_login_at"
- <*> v .: "last_login_at"
- <*> v .: "current_ip"
- <*> v .: "last_ip"
- <*> v .: "created_at"
- <*> v .: "updated_at"
- <*> return []
- <*> v .: "meta"
- parseJSON _ = error "Unexpected JSON input"
-
-
-instance ToJSON Password where
- toJSON (Encrypted x) = toJSON x
- toJSON (ClearText _) =
- error "ClearText passwords can't be serialized into JSON"
-
-instance FromJSON Password where
- parseJSON = fmap Encrypted . parseJSON
-
-
-showT :: Int -> Text
-showT = T.pack . show
413 src/Snap/Snaplet/Auth/Handlers.hs
View
@@ -1,29 +1,29 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Rank2Types #-}
-{-|
-
- Pre-packaged Handlers that deal with form submissions and standard use-cases
- involving authentication.
-
--}
+------------------------------------------------------------------------------
+-- | Pre-packaged Handlers that deal with form submissions and standard
+-- use-cases involving authentication.
module Snap.Snaplet.Auth.Handlers where
+------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad.CatchIO (throw)
import Control.Monad.State
+import Control.Monad.Trans.Error
+import Control.Monad.Trans.Maybe
import Data.ByteString (ByteString)
import Data.Lens.Lazy
-import Data.Maybe (isJust)
+import Data.Maybe (fromMaybe, 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 Snap.Snaplet.Auth.AuthManager
@@ -31,111 +31,125 @@ import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Session
import Snap.Snaplet.Session.Common
import Snap.Snaplet.Session.SecureCookie
-
-
-
-------------------------------------------------------------------------------
--- Higher level functions
------------------------------------------------------------------------------
+ ----------------------------
+ -- 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
+-- May throw a "DuplicateLogin" if given username is not unique.
+--
+createUser :: Text -- ^ Username
+ -> ByteString -- ^ Password
+ -> Handler b (AuthManager b) AuthUser
createUser unm pwd = withBackend (\r -> liftIO $ buildAuthUser r unm pwd)
+
------------------------------------------------------------------------------
-- | Check whether a user with the given username exists.
-usernameExists
- :: Text
- -- ^ The username to be checked
- -> Handler b (AuthManager b) Bool
-usernameExists username = withBackend $
- \r -> liftIO $ isJust <$> lookupByLogin r username
+--
+usernameExists :: Text -- ^ The username to be checked
+ -> Handler b (AuthManager b) Bool
+usernameExists username =
+ withBackend $ \r -> liftIO $ isJust <$> lookupByLogin r username
+
------------------------------------------------------------------------------
-- | 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 :: 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
- sk <- gets siteKey
- cn <- gets rememberCookieName
- rp <- gets rememberPeriod
- withBackend $ loginByUsername' sk cn rp
+loginByUsername unm pwd shouldRemember = do
+ sk <- gets siteKey
+ cn <- gets rememberCookieName
+ rp <- gets rememberPeriod
+ withBackend $ loginByUsername' sk cn rp
+
where
- loginByUsername' :: (IAuthBackend t)
- => Key -> ByteString -> Maybe Int -> t
- -> Handler b (AuthManager b)
- (Either AuthFailure AuthUser)
- loginByUsername' sk cn rp r = do
- 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
+ --------------------------------------------------------------------------
+ loginByUsername' :: (IAuthBackend t) =>
+ Key
+ -> ByteString
+ -> Maybe Int
+ -> t
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+ loginByUsername' sk cn rp r =
+ liftIO (lookupByLogin r $ decodeUtf8 unm) >>=
+ maybe (return $! Left UserNotFound) found
+
+ where
+ ----------------------------------------------------------------------
+ found user = checkPasswordAndLogin user pwd >>=
+ either (return . Left) matched
+
+ ----------------------------------------------------------------------
+ matched user
+ | shouldRemember = 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''
+
+ let user' = user {
+ userRememberToken = Just (decodeUtf8 token)
+ }
+
+ saveUser user'
+ return $! Right user'
+
+ | otherwise = return $ Right user
------------------------------------------------------------------------------
-- | Remember user from the remember token if possible and perform login
+--
loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
-loginByRememberToken = withBackend $ \r -> do
- sk <- gets siteKey
- rc <- gets rememberCookieName
- rp <- gets rememberPeriod
- 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
+loginByRememberToken = withBackend $ \impl -> do
+ key <- gets siteKey
+ cookieName_ <- gets rememberCookieName
+ period <- gets rememberPeriod
+
+ runMaybeT $ do
+ token <- MaybeT $ getRememberToken key cookieName_ period
+ user <- MaybeT $ liftIO $ lookupByRememberToken impl
+ $ decodeUtf8 token
+ lift $ forceLogin user
+ return user
------------------------------------------------------------------------------
-- | Logout the active user
+--
logout :: Handler b (AuthManager b) ()
logout = do
- s <- gets session
- withTop s $ withSession s removeSessionUserId
- rc <- gets rememberCookieName
- forgetRememberToken rc
- modify (\mgr -> mgr { activeUser = Nothing } )
+ s <- gets session
+ withTop s $ withSession s removeSessionUserId
+ rc <- gets rememberCookieName
+ 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 $ withBackend $ \r -> do
- s <- gets session
- uid <- withTop s getSessionUserId
- case uid of
- Nothing -> loginByRememberToken
- Just uid' -> liftIO $ lookupByUserId r uid'
+ s <- gets session
+ 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
@@ -144,6 +158,7 @@ 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 = withBackend $ liftIO . flip save u
@@ -152,60 +167,76 @@ saveUser u = withBackend $ liftIO . flip save u
-- | Destroy the given user
--
-- May throw a 'BackendError' if something goes wrong.
+--
destroyUser :: AuthUser -> Handler b (AuthManager b) ()
destroyUser u = withBackend $ liftIO . flip destroy u
-------------------------------------------------------------------------------
--- Lower level helper functions
---
-------------------------------------------------------------------------------
-
+ -----------------------------------
+ -- 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 = withBackend $ \r -> do
- lo <- gets lockout
- incFailCtr u >>= checkLockout lo >>= liftIO . save r
+ lo <- gets lockout
+ 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) ->
- if userFailedLoginCount u' >= mx
- then do
- now <- liftIO getCurrentTime
- let reopen = addUTCTime wait now
- return $ u' { userLockedOutUntil = Just reopen }
- else return u'
+ --------------------------------------------------------------------------
+ incFailCtr u' = return $ u' {
+ userFailedLoginCount = userFailedLoginCount u' + 1
+ }
+
+ --------------------------------------------------------------------------
+ checkLockout lo u' =
+ case lo of
+ Nothing -> return u'
+ Just (mx, wait) ->
+ if userFailedLoginCount u' >= mx
+ then do
+ now <- liftIO getCurrentTime
+ let reopen = addUTCTime wait now
+ return $! u' { userLockedOutUntil = Just reopen }
+ else return u'
------------------------------------------------------------------------------
-- | Mutate an 'AuthUser', marking successful authentication
--
-- This will save the user to the backend.
+--
markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
-markAuthSuccess u = withBackend $ \r -> do
- incLoginCtr u >>= updateIp >>= updateLoginTS
- >>= resetFailCtr >>= liftIO . save r
+markAuthSuccess u = withBackend $ \r ->
+ 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 }
+ 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 }
+ now <- liftIO getCurrentTime
+ return $
+ u' { userCurrentLoginAt = Just now
+ , userLastLoginAt = userCurrentLoginAt u' }
+
+ --------------------------------------------------------------------------
+ resetFailCtr u' = return $ u' { userFailedLoginCount = 0
+ , userLockedOutUntil = Nothing }
------------------------------------------------------------------------------
@@ -221,24 +252,27 @@ markAuthSuccess u = withBackend $ \r -> do
-- 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
+ 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 })
@@ -251,27 +285,27 @@ checkPasswordAndLogin u pw =
--
-- 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 :: AuthUser -- ^ An existing user, somehow looked up from db
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
forceLogin u = do
- s <- gets session
- 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"
+ s <- gets session
+ 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
---
-------------------------------------------------------------------------------
+ ------------------------------------
+ -- Internal, non-exported helpers --
+ ------------------------------------
+------------------------------------------------------------------------------
getRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
@@ -280,6 +314,7 @@ getRememberToken :: (Serialize t, MonadSnap m)
getRememberToken sk rc rp = getSecureCookie rc sk rp
+------------------------------------------------------------------------------
setRememberToken :: (Serialize t, MonadSnap m)
=> Key
-> ByteString
@@ -289,12 +324,14 @@ setRememberToken :: (Serialize t, MonadSnap 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
@@ -307,6 +344,7 @@ 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"
@@ -318,53 +356,56 @@ getSessionUserId = do
--
-- 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 :: 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
+ 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'
+ au <- gets activeUser
+ if isJust au
+ then return au
+ else do
+ au' <- f
+ modify (\mgr -> mgr { activeUser = au' })
+ return au'
------------------------------------------------------------------------------
-- | Register a new user by specifying login and password 'Param' fields
+--
registerUser
- :: ByteString -- Login field
- -> ByteString -- Password field
+ :: ByteString -- ^ Login field
+ -> ByteString -- ^ Password field
-> Handler b (AuthManager b) AuthUser
registerUser lf pf = do
- l <- fmap decodeUtf8 `fmap` getParam lf
- p <- getParam pf
- case liftM2 (,) l p of
- Nothing -> throw PasswordMissing
- Just (lgn, pwd) -> do
- createUser lgn pwd
+ l <- fmap decodeUtf8 `fmap` getParam lf
+ p <- getParam pf
+ case liftM2 (,) l p of
+ Nothing -> throw PasswordMissing
+ Just (lgn, pwd) -> createUser lgn pwd
------------------------------------------------------------------------------
-- | A 'MonadSnap' handler that processes a login form.
--
-- The request paremeters are passed to 'performLogin'
+--
loginUser
:: ByteString
-- ^ Username field
@@ -378,26 +419,29 @@ loginUser
-- ^ Upon success
-> Handler b (AuthManager b) ()
loginUser unf pwdf remf loginFail loginSucc = do
- username <- getParam unf
- password <- getParam pwdf
- remember <- maybe False (=="1") `fmap`
- maybe (return Nothing) getParam remf
- mMatch <- case password of
- Nothing -> return $ Left PasswordMissing
- Just password' -> do
- case username of
- Nothing -> return . Left $ AuthError "Username is missing"
- Just username' -> do
- loginByUsername username' (ClearText password') remember
- either loginFail (const loginSucc) mMatch
+ runErrorT go >>= either loginFail (const loginSucc)
+
+ where
+ go = do
+ mbUsername <- getParam unf
+ mbPassword <- getParam pwdf
+ remember <- (runMaybeT $ do
+ field <- MaybeT $ return remf
+ value <- MaybeT $ getParam field
+ return $ value == "1"
+ ) >>= return . fromMaybe False
+
+
+ password <- maybe (throwError PasswordMissing) return mbPassword
+ username <- maybe (fail "Username is missing") return mbUsername
+ lift $ loginByUsername username (ClearText password) remember
------------------------------------------------------------------------------
-- | Simple handler to log the user out. Deletes user from session.
-logoutUser
- :: Handler b (AuthManager b) ()
- -- ^ What to do after logging out
- -> Handler b (AuthManager b) ()
+--
+logoutUser :: Handler b (AuthManager b) () -- ^ What to do after logging out
+ -> Handler b (AuthManager b) ()
logoutUser target = logout >> target
@@ -407,17 +451,17 @@ logoutUser target = logout >> target
--
-- This function has no DB cost - only checks to see if a user_id is present
-- in the current session.
-requireUser
- :: Lens b (Snaplet (AuthManager b))
- -- Lens reference to an "AuthManager"
- -> Handler b v a
- -- ^ Do this if no authenticated user is present.
- -> Handler b v a
- -- ^ Do this if an authenticated user is present.
- -> Handler b v a
+--
+requireUser :: Lens b (Snaplet (AuthManager b))
+ -- ^ Lens reference to an "AuthManager"
+ -> Handler b v a
+ -- ^ Do this if no authenticated user is present.
+ -> Handler b v a
+ -- ^ Do this if an authenticated user is present.
+ -> Handler b v a
requireUser auth bad good = do
- loggedIn <- withTop auth isLoggedIn
- if loggedIn then good else bad
+ loggedIn <- withTop auth isLoggedIn
+ if loggedIn then good else bad
------------------------------------------------------------------------------
@@ -428,10 +472,11 @@ requireUser auth bad good = do
-- (AuthManager v) a and not a is because anything that uses the
-- backend will return an IO something, which you can liftIO, or a
-- Handler b (AuthManager v) a if it uses other handler things.
-withBackend
- :: (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)
- -- ^ The function to run with the handler.
+--
+withBackend ::
+ (forall r. (IAuthBackend r) => r -> Handler b (AuthManager v) a)
+ -- ^ The function to run with the handler.
-> Handler b (AuthManager v) a
withBackend f = join $ do
- (AuthManager bckend _ _ _ _ _ _ _) <- get
- return $ f bckend
+ (AuthManager backend_ _ _ _ _ _ _ _) <- get
+ return $ f backend_
234 src/Snap/Snaplet/Auth/Types.hs
View
@@ -1,20 +1,23 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
module Snap.Snaplet.Auth.Types where
+------------------------------------------------------------------------------
+import Control.Applicative
import Control.Monad.CatchIO
+import Control.Monad.Trans.Error
+import Crypto.PasswordStore
import Data.Aeson
-import Data.ByteString (ByteString)
-import Data.HashMap.Strict (HashMap)
-import qualified Data.HashMap.Strict as HM
-import Data.Hashable (Hashable)
+import Data.ByteString (ByteString)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
import Data.Time
+import Data.Text (Text)
import Data.Typeable
-import Data.Text (Text)
-import Crypto.PasswordStore
------------------------------------------------------------------------------
@@ -22,7 +25,13 @@ import Crypto.PasswordStore
-- returned from the db.
data Password = ClearText ByteString
| Encrypted ByteString
- deriving (Read, Show, Ord, Eq)
+ deriving (Read, Show, Ord, Eq)
+
+
+------------------------------------------------------------------------------
+-- | Default strength level to pass into makePassword.
+defaultStrength :: Int
+defaultStrength = 12
------------------------------------------------------------------------------
@@ -30,13 +39,16 @@ data Password = ClearText ByteString
-- stuffed into a database.
encryptPassword :: Password -> IO Password
encryptPassword p@(Encrypted {}) = return p
-encryptPassword (ClearText p) = do
- hashed <- makePassword p 12
+encryptPassword (ClearText p) = do
+ hashed <- makePassword p defaultStrength
return $ Encrypted hashed
+------------------------------------------------------------------------------
checkPassword :: Password -> Password -> Bool
checkPassword (ClearText pw) (Encrypted pw') = verifyPassword pw pw'
+checkPassword (ClearText pw) (ClearText pw') = pw == pw'
+checkPassword (Encrypted pw) (Encrypted pw') = pw == pw'
checkPassword _ _ =
error "checkPassword failed. Make sure you pass ClearText passwords"
@@ -46,18 +58,17 @@ checkPassword _ _ =
-- They may provide useful information to the developer, although it is
-- generally not advisable to show the user the exact details about why login
-- failed.
-data AuthFailure =
- UserNotFound
- | IncorrectPassword
- | PasswordMissing
- | LockedOut UTCTime
- -- ^ Locked out until given time
- | AuthError String
+data AuthFailure = UserNotFound
+ | IncorrectPassword
+ | PasswordMissing
+ | LockedOut UTCTime -- ^ Locked out until given time
+ | AuthError String
deriving (Read, Show, Ord, Eq, Typeable)
-
instance Exception AuthFailure
+instance Error AuthFailure where
+ strMsg = AuthError
------------------------------------------------------------------------------
-- | Internal representation of a 'User'. By convention, we demand that the
@@ -66,59 +77,61 @@ instance Exception AuthFailure
-- Think of this type as a secure, authenticated user. You should normally
-- never see this type unless a user has been authenticated.
newtype UserId = UserId { unUid :: Text }
- deriving (Read,Show,Ord,Eq,FromJSON,ToJSON,Hashable)
+ deriving ( Read, Show, Ord, Eq, FromJSON, ToJSON, Hashable )
+------------------------------------------------------------------------------
-- | This will be replaced by a role-based permission system.
data Role = Role ByteString
- deriving (Read,Show,Ord,Eq)
+ deriving (Read, Show, Ord, Eq)
------------------------------------------------------------------------------
-- | Type representing the concept of a User in your application.
data AuthUser = AuthUser
- { userId :: Maybe UserId
- , userLogin :: Text
- , userPassword :: Maybe Password
- , userActivatedAt :: Maybe UTCTime
- , userSuspendedAt :: Maybe UTCTime
- , userRememberToken :: Maybe Text
- , userLoginCount :: Int
- , userFailedLoginCount :: Int
- , userLockedOutUntil :: Maybe UTCTime
- , userCurrentLoginAt :: Maybe UTCTime
- , userLastLoginAt :: Maybe UTCTime
- , userCurrentLoginIp :: Maybe ByteString
- , userLastLoginIp :: Maybe ByteString
- , userCreatedAt :: Maybe UTCTime
- , userUpdatedAt :: Maybe UTCTime
- , userRoles :: [Role]
- , userMeta :: HashMap Text Value
- } deriving (Show,Eq)
+ { userId :: Maybe UserId
+ , userLogin :: Text
+ , userPassword :: Maybe Password
+ , userActivatedAt :: Maybe UTCTime
+ , userSuspendedAt :: Maybe UTCTime
+ , userRememberToken :: Maybe Text
+ , userLoginCount :: Int
+ , userFailedLoginCount :: Int
+ , userLockedOutUntil :: Maybe UTCTime
+ , userCurrentLoginAt :: Maybe UTCTime
+ , userLastLoginAt :: Maybe UTCTime
+ , userCurrentLoginIp :: Maybe ByteString
+ , userLastLoginIp :: Maybe ByteString
+ , userCreatedAt :: Maybe UTCTime
+ , userUpdatedAt :: Maybe UTCTime
+ , userRoles :: [Role]
+ , userMeta :: HashMap Text Value
+ }
+ deriving (Show,Eq)
------------------------------------------------------------------------------
-- | Default AuthUser that has all empty values.
defAuthUser :: AuthUser
-defAuthUser = AuthUser {
- userId = Nothing
- , userLogin = ""
- , userPassword = Nothing
- , userActivatedAt = Nothing
- , userSuspendedAt = Nothing
- , userRememberToken = Nothing
- , userLoginCount = 0
- , userFailedLoginCount = 0
- , userLockedOutUntil = Nothing
- , userCurrentLoginAt = Nothing
- , userLastLoginAt = Nothing
- , userCurrentLoginIp = Nothing
- , userLastLoginIp = Nothing
- , userCreatedAt = Nothing
- , userUpdatedAt = Nothing
- , userRoles = []
- , userMeta = HM.empty
-}
+defAuthUser = AuthUser
+ { userId = Nothing
+ , userLogin = ""
+ , userPassword = Nothing
+ , userActivatedAt = Nothing
+ , userSuspendedAt = Nothing
+ , userRememberToken = Nothing
+ , userLoginCount = 0
+ , userFailedLoginCount = 0
+ , userLockedOutUntil = Nothing
+ , userCurrentLoginAt = Nothing
+ , userLastLoginAt = Nothing
+ , userCurrentLoginIp = Nothing
+ , userLastLoginIp = Nothing
+ , userCreatedAt = Nothing
+ , userUpdatedAt = Nothing
+ , userRoles = []
+ , userMeta = HM.empty
+ }
------------------------------------------------------------------------------
@@ -126,24 +139,28 @@ defAuthUser = AuthUser {
-- clear-text; it will be encrypted into a 'Encrypted'.
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword au pass = do
- pw <- Encrypted `fmap` (makePassword pass 12)
- return $ au { userPassword = Just pw }
+ pw <- Encrypted `fmap` (makePassword pass defaultStrength)
+ return $! au { userPassword = Just pw }
------------------------------------------------------------------------------
-- | Authetication settings defined at initialization time
data AuthSettings = AuthSettings {
- asMinPasswdLen :: Int
- -- ^ Currently not used/checked
+ asMinPasswdLen :: Int
+ -- ^ Currently not used/checked
+
, asRememberCookieName :: ByteString
- -- ^ Name of the desired remember cookie
- , asRememberPeriod :: Maybe Int
- -- ^ How long to remember when the option is used in rest of the API.
- -- 'Nothing' means remember until end of session.
- , asLockout :: Maybe (Int, NominalDiffTime)
- -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])
- , asSiteKey :: FilePath
- -- ^ Location of app's encryption key
+ -- ^ Name of the desired remember cookie
+
+ , asRememberPeriod :: Maybe Int
+ -- ^ How long to remember when the option is used in rest of the API.
+ -- 'Nothing' means remember until end of session.
+
+ , asLockout :: Maybe (Int, NominalDiffTime)
+ -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])
+
+ , asSiteKey :: FilePath
+ -- ^ Location of app's encryption key
}
@@ -157,19 +174,78 @@ data AuthSettings = AuthSettings {
-- > asSiteKey = "site_key.txt"
defAuthSettings :: AuthSettings
defAuthSettings = AuthSettings {
- asMinPasswdLen = 8
+ asMinPasswdLen = 8
, asRememberCookieName = "_remember"
- , asRememberPeriod = Just (2*7*24*60*60)
- , asLockout = Nothing
- , asSiteKey = "site_key.txt"
+ , asRememberPeriod = Just (2*7*24*60*60)
+ , asLockout = Nothing
+ , asSiteKey = "site_key.txt"
}
-data BackendError =
- DuplicateLogin
- | BackendError String
+------------------------------------------------------------------------------
+data BackendError = DuplicateLogin
+ | BackendError String
deriving (Eq,Show,Read,Typeable)
-
instance Exception BackendError
+
+ --------------------
+ -- JSON Instances --
+ --------------------
+
+------------------------------------------------------------------------------
+instance ToJSON AuthUser where
+ toJSON u = object
+ [ "uid" .= userId u
+ , "login" .= userLogin u
+ , "pw" .= userPassword u
+ , "activated_at" .= userActivatedAt u
+ , "suspended_at" .= userSuspendedAt u
+ , "remember_token" .= userRememberToken u
+ , "login_count" .= userLoginCount u
+ , "failed_login_count" .= userFailedLoginCount u
+ , "locked_until" .= userLockedOutUntil u
+ , "current_login_at" .= userCurrentLoginAt u
+ , "last_login_at" .= userLastLoginAt u
+ , "current_ip" .= userCurrentLoginIp u
+ , "last_ip" .= userLastLoginIp u
+ , "created_at" .= userCreatedAt u
+ , "updated_at" .= userUpdatedAt u
+ , "meta" .= userMeta u
+ ]
+
+
+------------------------------------------------------------------------------
+instance FromJSON AuthUser where
+ parseJSON (Object v) = AuthUser
+ <$> v .: "uid"
+ <*> v .: "login"
+ <*> v .: "pw"
+ <*> v .: "activated_at"
+ <*> v .: "suspended_at"
+ <*> v .: "remember_token"
+ <*> v .: "login_count"
+ <*> v .: "failed_login_count"
+ <*> v .: "locked_until"
+ <*> v .: "current_login_at"
+ <*> v .: "last_login_at"
+ <*> v .: "current_ip"
+ <*> v .: "last_ip"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> return []
+ <*> v .: "meta"
+ parseJSON _ = error "Unexpected JSON input"
+
+
+------------------------------------------------------------------------------
+instance ToJSON Password where
+ toJSON (Encrypted x) = toJSON x
+ toJSON (ClearText _) =
+ error "ClearText passwords can't be serialized into JSON"
+
+
+------------------------------------------------------------------------------
+instance FromJSON Password where
+ parseJSON = fmap Encrypted . parseJSON
Please sign in to comment.
Something went wrong with that request. Please try again.