{-# LANGUAGE EmptyDataDecls    #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE GADTs             #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE CPP #-}


module Snap.Snaplet.Auth.Backends.Persistent
--    ( module Snap.Snaplet.Auth.Backends.Persistent
    ( PersistAuthManager
    , initPersistAuthManager
    , initPersistAuthManager'
    , authEntityDefs

    -- * Persistent Auth Data Types
    -- $datatypes
    , module Snap.Snaplet.Auth.Backends.Persistent.Types
--    , SnapAuthUserGeneric(..)
--    , SnapAuthUser
--    , SnapAuthUserId
    , 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


------------------------------------------------------------------------------
-- | The list of entity definitions this snaplet exposes. You need
-- them so that you can append to your application's list of
-- entity definitions and perform the migration in one block.
--
-- See how this example combined an app's own entity definitions and
-- the auth snaplet's in one migration block:
--
-- > share [mkMigrate "migrateAll"] $
-- >    authEntityDefs ++
-- >    $(persistFileWith lowerCaseSettings "schema.txt")
authEntityDefs :: [UnboundEntityDef]
authEntityDefs :: [UnboundEntityDef]
authEntityDefs = $(persistFileWith lowerCaseSettings "schema.txt")


-- $datatypes
--
-- Persistent creates its own data types mirroring the database schema, so we
-- have to export this extra layer of types and conversion to 'AuthUser'.


------------------------------------------------------------------------------
-- | Function to convert a 'SnapAuthUser' entity into the auth snaplet's
-- 'AuthUser'.
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
  }


------------------------------------------------------------------------------
-- | Splices for 'SnapAuthUser' that are equivalent to the ones for
-- 'AuthUser'.
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
      }


------------------------------------------------------------------------------
-- | Initializer that gets AuthSettings from a config file.
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



------------------------------------------------------------------------------
-- | Initializer that lets you specify AuthSettings.
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


------------------------------------------------------------------------------
-- | Get the db key from an 'AuthUser'
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