{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE CPP #-}
module Snap.Snaplet.Auth.Backends.Persistent
( PersistAuthManager
, initPersistAuthManager
, initPersistAuthManager'
, authEntityDefs
, module Snap.Snaplet.Auth.Backends.Persistent.Types
, db2au
, dbUserSplices
, userDBKey
, textPassword
) where
import Control.Monad
import Control.Monad.Trans
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Syntax as MS
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time
import Database.Persist
import Database.Persist.Postgresql
import Database.Persist.Quasi
import Database.Persist.Quasi.Internal
import Database.Persist.TH hiding (derivePersistField)
import Heist
import Heist.Compiled
import Paths_snaplet_persistent
import Safe
import Snap.Snaplet
import Snap.Snaplet.Auth
import Snap.Snaplet.Persistent
import Snap.Snaplet.Session
import Web.ClientSession (getKey)
import Snap.Snaplet.Auth.Backends.Persistent.Types
authEntityDefs :: [UnboundEntityDef]
authEntityDefs :: [UnboundEntityDef]
authEntityDefs = $(persistFileWith lowerCaseSettings "schema.txt")
db2au :: Entity SnapAuthUser -> AuthUser
db2au :: Entity SnapAuthUser -> AuthUser
db2au (Entity Key SnapAuthUser
k SnapAuthUser{Int
String
Maybe Text
Maybe UTCTime
Text
UTCTime
snapAuthUserMeta :: SnapAuthUser -> String
snapAuthUserRoles :: SnapAuthUser -> String
snapAuthUserResetRequestedAt :: SnapAuthUser -> Maybe UTCTime
snapAuthUserResetToken :: SnapAuthUser -> Maybe Text
snapAuthUserUpdatedAt :: SnapAuthUser -> UTCTime
snapAuthUserCreatedAt :: SnapAuthUser -> UTCTime
snapAuthUserLastIp :: SnapAuthUser -> Maybe Text
snapAuthUserCurrentIp :: SnapAuthUser -> Maybe Text
snapAuthUserLastLoginAt :: SnapAuthUser -> Maybe UTCTime
snapAuthUserCurrentLoginAt :: SnapAuthUser -> Maybe UTCTime
snapAuthUserLockedOutUntil :: SnapAuthUser -> Maybe UTCTime
snapAuthUserFailedLoginCount :: SnapAuthUser -> Int
snapAuthUserLoginCount :: SnapAuthUser -> Int
snapAuthUserRememberToken :: SnapAuthUser -> Maybe Text
snapAuthUserSuspendedAt :: SnapAuthUser -> Maybe UTCTime
snapAuthUserActivatedAt :: SnapAuthUser -> Maybe UTCTime
snapAuthUserPassword :: SnapAuthUser -> Text
snapAuthUserEmail :: SnapAuthUser -> Text
snapAuthUserLogin :: SnapAuthUser -> Text
snapAuthUserMeta :: String
snapAuthUserRoles :: String
snapAuthUserResetRequestedAt :: Maybe UTCTime
snapAuthUserResetToken :: Maybe Text
snapAuthUserUpdatedAt :: UTCTime
snapAuthUserCreatedAt :: UTCTime
snapAuthUserLastIp :: Maybe Text
snapAuthUserCurrentIp :: Maybe Text
snapAuthUserLastLoginAt :: Maybe UTCTime
snapAuthUserCurrentLoginAt :: Maybe UTCTime
snapAuthUserLockedOutUntil :: Maybe UTCTime
snapAuthUserFailedLoginCount :: Int
snapAuthUserLoginCount :: Int
snapAuthUserRememberToken :: Maybe Text
snapAuthUserSuspendedAt :: Maybe UTCTime
snapAuthUserActivatedAt :: Maybe UTCTime
snapAuthUserPassword :: Text
snapAuthUserEmail :: Text
snapAuthUserLogin :: Text
..}) = AuthUser :: Maybe UserId
-> Text
-> Maybe Text
-> Maybe Password
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Int
-> Int
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser
AuthUser
{ userId :: Maybe UserId
userId = UserId -> Maybe UserId
forall a. a -> Maybe a
Just (UserId -> Maybe UserId)
-> (Text -> UserId) -> Text -> Maybe UserId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> UserId
UserId (Text -> Maybe UserId) -> Text -> Maybe UserId
forall a b. (a -> b) -> a -> b
$ Key SnapAuthUser -> Text
forall e. ToBackendKey SqlBackend e => Key e -> Text
showKey Key SnapAuthUser
k
, userLogin :: Text
userLogin = Text
snapAuthUserLogin
, userEmail :: Maybe Text
userEmail = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
snapAuthUserEmail
, userPassword :: Maybe Password
userPassword = Password -> Maybe Password
forall a. a -> Maybe a
Just (Password -> Maybe Password)
-> (Text -> Password) -> Text -> Maybe Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Password
Encrypted (ByteString -> Password)
-> (Text -> ByteString) -> Text -> Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8
(Text -> Maybe Password) -> Text -> Maybe Password
forall a b. (a -> b) -> a -> b
$ Text
snapAuthUserPassword
, userActivatedAt :: Maybe UTCTime
userActivatedAt = Maybe UTCTime
snapAuthUserActivatedAt
, userSuspendedAt :: Maybe UTCTime
userSuspendedAt = Maybe UTCTime
snapAuthUserSuspendedAt
, userRememberToken :: Maybe Text
userRememberToken = Maybe Text
snapAuthUserRememberToken
, userLoginCount :: Int
userLoginCount = Int
snapAuthUserLoginCount
, userFailedLoginCount :: Int
userFailedLoginCount = Int
snapAuthUserFailedLoginCount
, userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = Maybe UTCTime
snapAuthUserLockedOutUntil
, userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt = Maybe UTCTime
snapAuthUserCurrentLoginAt
, userLastLoginAt :: Maybe UTCTime
userLastLoginAt = Maybe UTCTime
snapAuthUserLastLoginAt
, userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Text
snapAuthUserCurrentIp
, userLastLoginIp :: Maybe ByteString
userLastLoginIp = Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe Text
snapAuthUserLastIp
, userCreatedAt :: Maybe UTCTime
userCreatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
snapAuthUserCreatedAt
, userUpdatedAt :: Maybe UTCTime
userUpdatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
snapAuthUserUpdatedAt
, userResetToken :: Maybe Text
userResetToken = Maybe Text
snapAuthUserResetToken
, userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = Maybe UTCTime
snapAuthUserResetRequestedAt
, userRoles :: [Role]
userRoles = []
, userMeta :: HashMap Text Value
userMeta = HashMap Text Value
forall k v. HashMap k v
HM.empty
}
dbUserSplices :: Monad n
=> Splices (RuntimeSplice n (Entity SnapAuthUser) -> Splice n)
dbUserSplices :: Splices (RuntimeSplice n (Entity SnapAuthUser) -> Splice n)
dbUserSplices = ((RuntimeSplice n AuthUser -> Splice n)
-> RuntimeSplice n (Entity SnapAuthUser) -> Splice n)
-> MapSyntaxM Text (RuntimeSplice n AuthUser -> Splice n) ()
-> Splices (RuntimeSplice n (Entity SnapAuthUser) -> Splice n)
forall v1 v2 k a. (v1 -> v2) -> MapSyntaxM k v1 a -> MapSyntax k v2
MS.mapV ((Entity SnapAuthUser -> RuntimeSplice n AuthUser)
-> (RuntimeSplice n AuthUser -> Splice n)
-> RuntimeSplice n (Entity SnapAuthUser)
-> Splice n
forall (n :: * -> *) a b.
Monad n =>
(a -> RuntimeSplice n b)
-> (RuntimeSplice n b -> Splice n) -> RuntimeSplice n a -> Splice n
deferMap (AuthUser -> RuntimeSplice n AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> RuntimeSplice n AuthUser)
-> (Entity SnapAuthUser -> AuthUser)
-> Entity SnapAuthUser
-> RuntimeSplice n AuthUser
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity SnapAuthUser -> AuthUser
db2au)) MapSyntaxM Text (RuntimeSplice n AuthUser -> Splice n) ()
forall (m :: * -> *).
Monad m =>
Splices (RuntimeSplice m AuthUser -> Splice m)
userCSplices
data PersistAuthManager = PAM {
PersistAuthManager -> ConnectionPool
pamPool :: ConnectionPool
}
initPersistAuthManager :: SnapletLens b SessionManager
-> ConnectionPool
-> SnapletInit b (AuthManager b)
initPersistAuthManager :: SnapletLens b SessionManager
-> ConnectionPool -> SnapletInit b (AuthManager b)
initPersistAuthManager SnapletLens b SessionManager
l ConnectionPool
pool = Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall b v. Initializer b v v -> SnapletInit b v
make (Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b))
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall a b. (a -> b) -> a -> b
$ do
AuthSettings
aus <- Initializer b (AuthManager b) AuthSettings
forall b v. Initializer b v AuthSettings
authSettingsFromConfig
AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
forall b.
AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
initHelper AuthSettings
aus SnapletLens b SessionManager
l ConnectionPool
pool
initPersistAuthManager' :: AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> SnapletInit b (AuthManager b)
initPersistAuthManager' :: AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> SnapletInit b (AuthManager b)
initPersistAuthManager' AuthSettings
aus SnapletLens b SessionManager
l ConnectionPool
pool = Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall b v. Initializer b v v -> SnapletInit b v
make (Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b))
-> Initializer b (AuthManager b) (AuthManager b)
-> SnapletInit b (AuthManager b)
forall a b. (a -> b) -> a -> b
$ AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
forall b.
AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
initHelper AuthSettings
aus SnapletLens b SessionManager
l ConnectionPool
pool
make :: Initializer b v v -> SnapletInit b v
make :: Initializer b v v -> SnapletInit b v
make = Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"persist-auth" Text
description Maybe (IO String)
datadir
where
description :: Text
description =
Text
"A snaplet providing user authentication support using Persist"
datadir :: Maybe (IO String)
datadir = IO String -> Maybe (IO String)
forall a. a -> Maybe a
Just (IO String -> Maybe (IO String)) -> IO String -> Maybe (IO String)
forall a b. (a -> b) -> a -> b
$ (String -> String) -> IO String -> IO String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"/resources/auth") IO String
getDataDir
initHelper :: AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
initHelper :: AuthSettings
-> SnapletLens b SessionManager
-> ConnectionPool
-> Initializer b (AuthManager b) (AuthManager b)
initHelper AuthSettings
aus SnapletLens b SessionManager
l ConnectionPool
pool = IO (AuthManager b) -> Initializer b (AuthManager b) (AuthManager b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (AuthManager b)
-> Initializer b (AuthManager b) (AuthManager b))
-> IO (AuthManager b)
-> Initializer b (AuthManager b) (AuthManager b)
forall a b. (a -> b) -> a -> b
$ do
Key
key <- String -> IO Key
getKey (AuthSettings -> String
asSiteKey AuthSettings
aus)
RNG
rng <- IO RNG -> IO RNG
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RNG
mkRNG
AuthManager b -> IO (AuthManager b)
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthManager b -> IO (AuthManager b))
-> AuthManager b -> IO (AuthManager b)
forall a b. (a -> b) -> a -> b
$ AuthManager :: forall b r.
IAuthBackend r =>
r
-> SnapletLens b SessionManager
-> Maybe AuthUser
-> Int
-> ByteString
-> Maybe ByteString
-> Maybe Int
-> Key
-> Maybe (Int, NominalDiffTime)
-> RNG
-> AuthManager b
AuthManager {
backend :: PersistAuthManager
backend = ConnectionPool -> PersistAuthManager
PAM ConnectionPool
pool
, session :: SnapletLens b SessionManager
session = SnapletLens b SessionManager
l
, activeUser :: Maybe AuthUser
activeUser = Maybe AuthUser
forall a. Maybe a
Nothing
, minPasswdLen :: Int
minPasswdLen = AuthSettings -> Int
asMinPasswdLen AuthSettings
aus
, rememberCookieName :: ByteString
rememberCookieName = AuthSettings -> ByteString
asRememberCookieName AuthSettings
aus
, rememberCookieDomain :: Maybe ByteString
rememberCookieDomain = Maybe ByteString
forall a. Maybe a
Nothing
, rememberPeriod :: Maybe Int
rememberPeriod = AuthSettings -> Maybe Int
asRememberPeriod AuthSettings
aus
, siteKey :: Key
siteKey = Key
key
, lockout :: Maybe (Int, NominalDiffTime)
lockout = AuthSettings -> Maybe (Int, NominalDiffTime)
asLockout AuthSettings
aus
, randomNumberGenerator :: RNG
randomNumberGenerator = RNG
rng }
readT :: Text -> Int
readT :: Text -> Int
readT = String -> String -> Int
forall a. (Partial, Read a) => String -> String -> a
readNote String
"Can't read text" (String -> Int) -> (Text -> String) -> Text -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
userDBKey :: AuthUser -> Maybe SnapAuthUserId
userDBKey :: AuthUser -> Maybe (Key SnapAuthUser)
userDBKey AuthUser
au = case AuthUser -> Maybe UserId
userId AuthUser
au of
Maybe UserId
Nothing -> Maybe (Key SnapAuthUser)
forall a. Maybe a
Nothing
Just (UserId Text
k) -> Key SnapAuthUser -> Maybe (Key SnapAuthUser)
forall a. a -> Maybe a
Just (Key SnapAuthUser -> Maybe (Key SnapAuthUser))
-> (Int -> Key SnapAuthUser) -> Int -> Maybe (Key SnapAuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Key SnapAuthUser
forall entity. ToBackendKey SqlBackend entity => Int -> Key entity
mkKey (Int -> Maybe (Key SnapAuthUser))
-> Int -> Maybe (Key SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ (Text -> Int
readT Text
k :: Int)
textPassword :: Password -> Text
textPassword :: Password -> Text
textPassword (Encrypted ByteString
bs) = ByteString -> Text
T.decodeUtf8 ByteString
bs
textPassword (ClearText ByteString
bs) = ByteString -> Text
T.decodeUtf8 ByteString
bs
instance IAuthBackend PersistAuthManager where
save :: PersistAuthManager -> AuthUser -> IO (Either AuthFailure AuthUser)
save PAM{ConnectionPool
pamPool :: ConnectionPool
pamPool :: PersistAuthManager -> ConnectionPool
..} au :: AuthUser
au@AuthUser{Int
[Role]
Maybe ByteString
Maybe Text
Maybe UTCTime
Maybe Password
Maybe UserId
Text
HashMap Text Value
userMeta :: HashMap Text Value
userRoles :: [Role]
userResetRequestedAt :: Maybe UTCTime
userResetToken :: Maybe Text
userUpdatedAt :: Maybe UTCTime
userCreatedAt :: Maybe UTCTime
userLastLoginIp :: Maybe ByteString
userCurrentLoginIp :: Maybe ByteString
userLastLoginAt :: Maybe UTCTime
userCurrentLoginAt :: Maybe UTCTime
userLockedOutUntil :: Maybe UTCTime
userFailedLoginCount :: Int
userLoginCount :: Int
userRememberToken :: Maybe Text
userSuspendedAt :: Maybe UTCTime
userActivatedAt :: Maybe UTCTime
userPassword :: Maybe Password
userEmail :: Maybe Text
userLogin :: Text
userId :: Maybe UserId
userMeta :: AuthUser -> HashMap Text Value
userRoles :: AuthUser -> [Role]
userResetRequestedAt :: AuthUser -> Maybe UTCTime
userResetToken :: AuthUser -> Maybe Text
userUpdatedAt :: AuthUser -> Maybe UTCTime
userCreatedAt :: AuthUser -> Maybe UTCTime
userLastLoginIp :: AuthUser -> Maybe ByteString
userCurrentLoginIp :: AuthUser -> Maybe ByteString
userLastLoginAt :: AuthUser -> Maybe UTCTime
userCurrentLoginAt :: AuthUser -> Maybe UTCTime
userLockedOutUntil :: AuthUser -> Maybe UTCTime
userFailedLoginCount :: AuthUser -> Int
userLoginCount :: AuthUser -> Int
userRememberToken :: AuthUser -> Maybe Text
userSuspendedAt :: AuthUser -> Maybe UTCTime
userActivatedAt :: AuthUser -> Maybe UTCTime
userPassword :: AuthUser -> Maybe Password
userEmail :: AuthUser -> Maybe Text
userLogin :: AuthUser -> Text
userId :: AuthUser -> Maybe UserId
..} = do
UTCTime
now <- IO UTCTime -> IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
Password
pw <- Password -> IO Password
encryptPassword (Password -> IO Password) -> Password -> IO Password
forall a b. (a -> b) -> a -> b
$ Password -> Maybe Password -> Password
forall a. a -> Maybe a -> a
fromMaybe (ByteString -> Password
ClearText ByteString
"") Maybe Password
userPassword
ConnectionPool
-> SqlPersistM (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser)
forall (m :: * -> *) a.
MonadIO m =>
ConnectionPool -> SqlPersistM a -> m a
withPool ConnectionPool
pamPool (SqlPersistM (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser))
-> SqlPersistM (Either AuthFailure AuthUser)
-> IO (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ do
case Maybe UserId
userId of
Maybe UserId
Nothing -> do
SnapAuthUser
-> ReaderT
SqlBackend (NoLoggingT (ResourceT IO)) (Key SnapAuthUser)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
insert (SnapAuthUser
-> ReaderT
SqlBackend (NoLoggingT (ResourceT IO)) (Key SnapAuthUser))
-> SnapAuthUser
-> ReaderT
SqlBackend (NoLoggingT (ResourceT IO)) (Key SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ Text
-> Text
-> Text
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Int
-> Int
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe Text
-> UTCTime
-> UTCTime
-> Maybe Text
-> Maybe UTCTime
-> String
-> String
-> SnapAuthUser
SnapAuthUser
Text
userLogin
(Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
userEmail)
(Password -> Text
textPassword Password
pw)
Maybe UTCTime
userActivatedAt
Maybe UTCTime
userSuspendedAt
Maybe Text
userRememberToken
Int
userLoginCount
Int
userFailedLoginCount
Maybe UTCTime
userLockedOutUntil
Maybe UTCTime
userCurrentLoginAt
Maybe UTCTime
userLastLoginAt
((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 Maybe ByteString
userCurrentLoginIp)
((ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 Maybe ByteString
userLastLoginIp)
UTCTime
now
UTCTime
now
Maybe Text
forall a. Maybe a
Nothing
Maybe UTCTime
forall a. Maybe a
Nothing
String
""
String
""
Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right (AuthUser -> Either AuthFailure AuthUser)
-> AuthUser -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
au {userUpdatedAt :: Maybe UTCTime
userUpdatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now}
Just (UserId Text
t) -> do
let k :: Key SnapAuthUser
k = (Int -> Key SnapAuthUser
forall entity. ToBackendKey SqlBackend entity => Int -> Key entity
mkKey (Text -> Int
readT Text
t :: Int))
Key SnapAuthUser
-> [Update SnapAuthUser]
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> [Update record] -> ReaderT backend m ()
update Key SnapAuthUser
k ([Update SnapAuthUser]
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ())
-> [Update SnapAuthUser]
-> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) ()
forall a b. (a -> b) -> a -> b
$ [Maybe (Update SnapAuthUser)] -> [Update SnapAuthUser]
forall a. [Maybe a] -> [a]
catMaybes
[ Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser Text
forall typ. (typ ~ Text) => EntityField SnapAuthUser typ
SnapAuthUserLogin EntityField SnapAuthUser Text -> Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Text
userLogin
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser Text
forall typ. (typ ~ Text) => EntityField SnapAuthUser typ
SnapAuthUserEmail EntityField SnapAuthUser Text -> Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
userEmail
, (Password -> Update SnapAuthUser)
-> Maybe Password -> Maybe (Update SnapAuthUser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Encrypted ByteString
p) -> EntityField SnapAuthUser Text
forall typ. (typ ~ Text) => EntityField SnapAuthUser typ
SnapAuthUserPassword EntityField SnapAuthUser Text -> Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. ByteString -> Text
T.decodeUtf8 ByteString
p)
Maybe Password
userPassword
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserActivatedAt EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
userActivatedAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserSuspendedAt EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
userSuspendedAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe Text)
forall typ. (typ ~ Maybe Text) => EntityField SnapAuthUser typ
SnapAuthUserRememberToken EntityField SnapAuthUser (Maybe Text)
-> Maybe Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe Text
userRememberToken
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser Int
forall typ. (typ ~ Int) => EntityField SnapAuthUser typ
SnapAuthUserLoginCount EntityField SnapAuthUser Int -> Int -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
userLoginCount
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser Int
forall typ. (typ ~ Int) => EntityField SnapAuthUser typ
SnapAuthUserFailedLoginCount EntityField SnapAuthUser Int -> Int -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Int
userFailedLoginCount
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ (EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserLockedOutUntil EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.) Maybe UTCTime
userLockedOutUntil
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ (EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserCurrentLoginAt EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.) Maybe UTCTime
userCurrentLoginAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ (EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserLastLoginAt EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.) Maybe UTCTime
userLastLoginAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe Text)
forall typ. (typ ~ Maybe Text) => EntityField SnapAuthUser typ
SnapAuthUserCurrentIp EntityField SnapAuthUser (Maybe Text)
-> Maybe Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe ByteString
userCurrentLoginIp)
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ (EntityField SnapAuthUser (Maybe Text)
forall typ. (typ ~ Maybe Text) => EntityField SnapAuthUser typ
SnapAuthUserLastIp EntityField SnapAuthUser (Maybe Text)
-> Maybe Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.) (ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Maybe ByteString
userLastLoginIp)
, (UTCTime -> Update SnapAuthUser)
-> Maybe UTCTime -> Maybe (Update SnapAuthUser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (EntityField SnapAuthUser UTCTime
forall typ. (typ ~ UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserCreatedAt EntityField SnapAuthUser UTCTime -> UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=.) Maybe UTCTime
userCreatedAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser UTCTime
forall typ. (typ ~ UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserUpdatedAt EntityField SnapAuthUser UTCTime -> UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. UTCTime
now
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe Text)
forall typ. (typ ~ Maybe Text) => EntityField SnapAuthUser typ
SnapAuthUserResetToken EntityField SnapAuthUser (Maybe Text)
-> Maybe Text -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe Text
userResetToken
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser (Maybe UTCTime)
forall typ. (typ ~ Maybe UTCTime) => EntityField SnapAuthUser typ
SnapAuthUserResetRequestedAt EntityField SnapAuthUser (Maybe UTCTime)
-> Maybe UTCTime -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. Maybe UTCTime
userResetRequestedAt
, Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a. a -> Maybe a
Just (Update SnapAuthUser -> Maybe (Update SnapAuthUser))
-> Update SnapAuthUser -> Maybe (Update SnapAuthUser)
forall a b. (a -> b) -> a -> b
$ EntityField SnapAuthUser String
forall typ. (typ ~ String) => EntityField SnapAuthUser typ
SnapAuthUserRoles EntityField SnapAuthUser String -> String -> Update SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Update v
=. [Role] -> String
forall a. Show a => a -> String
show [Role]
userRoles
]
Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser))
-> Either AuthFailure AuthUser
-> SqlPersistM (Either AuthFailure AuthUser)
forall a b. (a -> b) -> a -> b
$ AuthUser -> Either AuthFailure AuthUser
forall a b. b -> Either a b
Right (AuthUser -> Either AuthFailure AuthUser)
-> AuthUser -> Either AuthFailure AuthUser
forall a b. (a -> b) -> a -> b
$ AuthUser
au {userUpdatedAt :: Maybe UTCTime
userUpdatedAt = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just UTCTime
now}
destroy :: PersistAuthManager -> AuthUser -> IO ()
destroy PersistAuthManager
_ AuthUser
_ = String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"We don't allow destroying users."
lookupByUserId :: PersistAuthManager -> UserId -> IO (Maybe AuthUser)
lookupByUserId PAM{ConnectionPool
pamPool :: ConnectionPool
pamPool :: PersistAuthManager -> ConnectionPool
..} (UserId Text
t) = ConnectionPool
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall (m :: * -> *) a.
MonadIO m =>
ConnectionPool -> SqlPersistM a -> m a
withPool ConnectionPool
pamPool (SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser))
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
let k :: Key SnapAuthUser
k = (Int -> Key SnapAuthUser
forall entity. ToBackendKey SqlBackend entity => Int -> Key entity
mkKey (Text -> Int
readT Text
t :: Int))
Maybe SnapAuthUser
u <- Key SnapAuthUser
-> ReaderT
SqlBackend (NoLoggingT (ResourceT IO)) (Maybe SnapAuthUser)
forall backend record (m :: * -> *).
(PersistStoreRead backend, MonadIO m,
PersistRecordBackend record backend) =>
Key record -> ReaderT backend m (Maybe record)
get Key SnapAuthUser
k
case Maybe SnapAuthUser
u of
Maybe SnapAuthUser
Nothing -> Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AuthUser
forall a. Maybe a
Nothing
Just SnapAuthUser
u' -> Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> SqlPersistM (Maybe AuthUser))
-> (AuthUser -> Maybe AuthUser)
-> AuthUser
-> SqlPersistM (Maybe AuthUser)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthUser -> Maybe AuthUser
forall a. a -> Maybe a
Just (AuthUser -> SqlPersistM (Maybe AuthUser))
-> AuthUser -> SqlPersistM (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ Entity SnapAuthUser -> AuthUser
db2au (Entity SnapAuthUser -> AuthUser)
-> Entity SnapAuthUser -> AuthUser
forall a b. (a -> b) -> a -> b
$ Key SnapAuthUser -> SnapAuthUser -> Entity SnapAuthUser
forall rec. Key rec -> rec -> Entity rec
Entity Key SnapAuthUser
k SnapAuthUser
u'
lookupByLogin :: PersistAuthManager -> Text -> IO (Maybe AuthUser)
lookupByLogin PAM{ConnectionPool
pamPool :: ConnectionPool
pamPool :: PersistAuthManager -> ConnectionPool
..} Text
login = ConnectionPool
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall (m :: * -> *) a.
MonadIO m =>
ConnectionPool -> SqlPersistM a -> m a
withPool ConnectionPool
pamPool (SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser))
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Maybe (Entity SnapAuthUser)
res <- [Filter SnapAuthUser]
-> [SelectOpt SnapAuthUser]
-> ReaderT
SqlBackend
(NoLoggingT (ResourceT IO))
(Maybe (Entity SnapAuthUser))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField SnapAuthUser Text
forall typ. (typ ~ Text) => EntityField SnapAuthUser typ
SnapAuthUserLogin EntityField SnapAuthUser Text -> Text -> Filter SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
login] []
Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> SqlPersistM (Maybe AuthUser))
-> Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ (Entity SnapAuthUser -> AuthUser)
-> Maybe (Entity SnapAuthUser) -> Maybe AuthUser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity SnapAuthUser -> AuthUser
db2au Maybe (Entity SnapAuthUser)
res
lookupByRememberToken :: PersistAuthManager -> Text -> IO (Maybe AuthUser)
lookupByRememberToken PAM{ConnectionPool
pamPool :: ConnectionPool
pamPool :: PersistAuthManager -> ConnectionPool
..} Text
token = ConnectionPool
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall (m :: * -> *) a.
MonadIO m =>
ConnectionPool -> SqlPersistM a -> m a
withPool ConnectionPool
pamPool (SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser))
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Maybe (Entity SnapAuthUser)
res <- [Filter SnapAuthUser]
-> [SelectOpt SnapAuthUser]
-> ReaderT
SqlBackend
(NoLoggingT (ResourceT IO))
(Maybe (Entity SnapAuthUser))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField SnapAuthUser (Maybe Text)
forall typ. (typ ~ Maybe Text) => EntityField SnapAuthUser typ
SnapAuthUserRememberToken EntityField SnapAuthUser (Maybe Text)
-> Maybe Text -> Filter SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text -> Maybe Text
forall a. a -> Maybe a
Just Text
token] []
Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> SqlPersistM (Maybe AuthUser))
-> Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ (Entity SnapAuthUser -> AuthUser)
-> Maybe (Entity SnapAuthUser) -> Maybe AuthUser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity SnapAuthUser -> AuthUser
db2au Maybe (Entity SnapAuthUser)
res
#if MIN_VERSION_snap(1,1,0)
lookupByEmail :: PersistAuthManager -> Text -> IO (Maybe AuthUser)
lookupByEmail PAM{ConnectionPool
pamPool :: ConnectionPool
pamPool :: PersistAuthManager -> ConnectionPool
..} Text
email = ConnectionPool
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall (m :: * -> *) a.
MonadIO m =>
ConnectionPool -> SqlPersistM a -> m a
withPool ConnectionPool
pamPool (SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser))
-> SqlPersistM (Maybe AuthUser) -> IO (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ do
Maybe (Entity SnapAuthUser)
res <- [Filter SnapAuthUser]
-> [SelectOpt SnapAuthUser]
-> ReaderT
SqlBackend
(NoLoggingT (ResourceT IO))
(Maybe (Entity SnapAuthUser))
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
PersistRecordBackend record backend) =>
[Filter record]
-> [SelectOpt record] -> ReaderT backend m (Maybe (Entity record))
selectFirst [EntityField SnapAuthUser Text
forall typ. (typ ~ Text) => EntityField SnapAuthUser typ
SnapAuthUserEmail EntityField SnapAuthUser Text -> Text -> Filter SnapAuthUser
forall v typ.
PersistField typ =>
EntityField v typ -> typ -> Filter v
==. Text
email] []
Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AuthUser -> SqlPersistM (Maybe AuthUser))
-> Maybe AuthUser -> SqlPersistM (Maybe AuthUser)
forall a b. (a -> b) -> a -> b
$ (Entity SnapAuthUser -> AuthUser)
-> Maybe (Entity SnapAuthUser) -> Maybe AuthUser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity SnapAuthUser -> AuthUser
db2au Maybe (Entity SnapAuthUser)
res
#endif