{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
module Snap.Snaplet.Auth.Types where
import Control.Arrow
import Control.Monad.Trans
import Crypto.PasswordStore
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.Configurator as C
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.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Typeable
import Snap.Snaplet
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
data Password = ClearText ByteString
| Encrypted ByteString
deriving (ReadPrec [Password]
ReadPrec Password
Int -> ReadS Password
ReadS [Password]
(Int -> ReadS Password)
-> ReadS [Password]
-> ReadPrec Password
-> ReadPrec [Password]
-> Read Password
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Password]
$creadListPrec :: ReadPrec [Password]
readPrec :: ReadPrec Password
$creadPrec :: ReadPrec Password
readList :: ReadS [Password]
$creadList :: ReadS [Password]
readsPrec :: Int -> ReadS Password
$creadsPrec :: Int -> ReadS Password
Read, Int -> Password -> ShowS
[Password] -> ShowS
Password -> String
(Int -> Password -> ShowS)
-> (Password -> String) -> ([Password] -> ShowS) -> Show Password
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Password] -> ShowS
$cshowList :: [Password] -> ShowS
show :: Password -> String
$cshow :: Password -> String
showsPrec :: Int -> Password -> ShowS
$cshowsPrec :: Int -> Password -> ShowS
Show, Eq Password
Eq Password =>
(Password -> Password -> Ordering)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Bool)
-> (Password -> Password -> Password)
-> (Password -> Password -> Password)
-> Ord Password
Password -> Password -> Bool
Password -> Password -> Ordering
Password -> Password -> Password
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Password -> Password -> Password
$cmin :: Password -> Password -> Password
max :: Password -> Password -> Password
$cmax :: Password -> Password -> Password
>= :: Password -> Password -> Bool
$c>= :: Password -> Password -> Bool
> :: Password -> Password -> Bool
$c> :: Password -> Password -> Bool
<= :: Password -> Password -> Bool
$c<= :: Password -> Password -> Bool
< :: Password -> Password -> Bool
$c< :: Password -> Password -> Bool
compare :: Password -> Password -> Ordering
$ccompare :: Password -> Password -> Ordering
$cp1Ord :: Eq Password
Ord, Password -> Password -> Bool
(Password -> Password -> Bool)
-> (Password -> Password -> Bool) -> Eq Password
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c== :: Password -> Password -> Bool
Eq)
defaultStrength :: Int
defaultStrength :: Int
defaultStrength = 12
encrypt :: ByteString -> IO ByteString
encrypt :: ByteString -> IO ByteString
encrypt = (ByteString -> Int -> IO ByteString)
-> Int -> ByteString -> IO ByteString
forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Int -> IO ByteString
makePassword Int
defaultStrength
verify
:: ByteString
-> ByteString
-> Bool
verify :: ByteString -> ByteString -> Bool
verify = ByteString -> ByteString -> Bool
verifyPassword
encryptPassword :: Password -> IO Password
encryptPassword :: Password -> IO Password
encryptPassword p :: Password
p@(Encrypted {}) = Password -> IO Password
forall (m :: * -> *) a. Monad m => a -> m a
return Password
p
encryptPassword (ClearText p :: ByteString
p) = ByteString -> Password
Encrypted (ByteString -> Password) -> IO ByteString -> IO Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` ByteString -> IO ByteString
encrypt ByteString
p
checkPassword :: Password -> Password -> Bool
checkPassword :: Password -> Password -> Bool
checkPassword (ClearText pw :: ByteString
pw) (Encrypted pw' :: ByteString
pw') = ByteString -> ByteString -> Bool
verify ByteString
pw ByteString
pw'
checkPassword (ClearText pw :: ByteString
pw) (ClearText pw' :: ByteString
pw') = ByteString
pw ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pw'
checkPassword (Encrypted pw :: ByteString
pw) (Encrypted pw' :: ByteString
pw') = ByteString
pw ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
pw'
checkPassword _ _ =
String -> Bool
forall a. HasCallStack => String -> a
error "checkPassword failed. Make sure you pass ClearText passwords"
data AuthFailure = AuthError String
| BackendError
| DuplicateLogin
| EncryptedPassword
| IncorrectPassword
| LockedOut UTCTime
| PasswordMissing
| UsernameMissing
| UserNotFound
deriving (ReadPrec [AuthFailure]
ReadPrec AuthFailure
Int -> ReadS AuthFailure
ReadS [AuthFailure]
(Int -> ReadS AuthFailure)
-> ReadS [AuthFailure]
-> ReadPrec AuthFailure
-> ReadPrec [AuthFailure]
-> Read AuthFailure
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [AuthFailure]
$creadListPrec :: ReadPrec [AuthFailure]
readPrec :: ReadPrec AuthFailure
$creadPrec :: ReadPrec AuthFailure
readList :: ReadS [AuthFailure]
$creadList :: ReadS [AuthFailure]
readsPrec :: Int -> ReadS AuthFailure
$creadsPrec :: Int -> ReadS AuthFailure
Read, Eq AuthFailure
Eq AuthFailure =>
(AuthFailure -> AuthFailure -> Ordering)
-> (AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> AuthFailure)
-> (AuthFailure -> AuthFailure -> AuthFailure)
-> Ord AuthFailure
AuthFailure -> AuthFailure -> Bool
AuthFailure -> AuthFailure -> Ordering
AuthFailure -> AuthFailure -> AuthFailure
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AuthFailure -> AuthFailure -> AuthFailure
$cmin :: AuthFailure -> AuthFailure -> AuthFailure
max :: AuthFailure -> AuthFailure -> AuthFailure
$cmax :: AuthFailure -> AuthFailure -> AuthFailure
>= :: AuthFailure -> AuthFailure -> Bool
$c>= :: AuthFailure -> AuthFailure -> Bool
> :: AuthFailure -> AuthFailure -> Bool
$c> :: AuthFailure -> AuthFailure -> Bool
<= :: AuthFailure -> AuthFailure -> Bool
$c<= :: AuthFailure -> AuthFailure -> Bool
< :: AuthFailure -> AuthFailure -> Bool
$c< :: AuthFailure -> AuthFailure -> Bool
compare :: AuthFailure -> AuthFailure -> Ordering
$ccompare :: AuthFailure -> AuthFailure -> Ordering
$cp1Ord :: Eq AuthFailure
Ord, AuthFailure -> AuthFailure -> Bool
(AuthFailure -> AuthFailure -> Bool)
-> (AuthFailure -> AuthFailure -> Bool) -> Eq AuthFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthFailure -> AuthFailure -> Bool
$c/= :: AuthFailure -> AuthFailure -> Bool
== :: AuthFailure -> AuthFailure -> Bool
$c== :: AuthFailure -> AuthFailure -> Bool
Eq, Typeable)
instance Show AuthFailure where
show :: AuthFailure -> String
show (AuthError s :: String
s) = String
s
show (AuthFailure
BackendError) = "Failed to store data in the backend."
show (AuthFailure
DuplicateLogin) = "This login already exists in the backend."
show (AuthFailure
EncryptedPassword) = "Cannot login with encrypted password."
show (AuthFailure
IncorrectPassword) = "The password provided was not valid."
show (LockedOut time :: UTCTime
time) = "The login is locked out until " String -> ShowS
forall a. [a] -> [a] -> [a]
++ UTCTime -> String
forall a. Show a => a -> String
show UTCTime
time
show (AuthFailure
PasswordMissing) = "No password provided."
show (AuthFailure
UsernameMissing) = "No username provided."
show (AuthFailure
UserNotFound) = "User not found in the backend."
newtype UserId = UserId { UserId -> Text
unUid :: Text }
deriving ( ReadPrec [UserId]
ReadPrec UserId
Int -> ReadS UserId
ReadS [UserId]
(Int -> ReadS UserId)
-> ReadS [UserId]
-> ReadPrec UserId
-> ReadPrec [UserId]
-> Read UserId
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [UserId]
$creadListPrec :: ReadPrec [UserId]
readPrec :: ReadPrec UserId
$creadPrec :: ReadPrec UserId
readList :: ReadS [UserId]
$creadList :: ReadS [UserId]
readsPrec :: Int -> ReadS UserId
$creadsPrec :: Int -> ReadS UserId
Read, Int -> UserId -> ShowS
[UserId] -> ShowS
UserId -> String
(Int -> UserId -> ShowS)
-> (UserId -> String) -> ([UserId] -> ShowS) -> Show UserId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserId] -> ShowS
$cshowList :: [UserId] -> ShowS
show :: UserId -> String
$cshow :: UserId -> String
showsPrec :: Int -> UserId -> ShowS
$cshowsPrec :: Int -> UserId -> ShowS
Show, Eq UserId
Eq UserId =>
(UserId -> UserId -> Ordering)
-> (UserId -> UserId -> Bool)
-> (UserId -> UserId -> Bool)
-> (UserId -> UserId -> Bool)
-> (UserId -> UserId -> Bool)
-> (UserId -> UserId -> UserId)
-> (UserId -> UserId -> UserId)
-> Ord UserId
UserId -> UserId -> Bool
UserId -> UserId -> Ordering
UserId -> UserId -> UserId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UserId -> UserId -> UserId
$cmin :: UserId -> UserId -> UserId
max :: UserId -> UserId -> UserId
$cmax :: UserId -> UserId -> UserId
>= :: UserId -> UserId -> Bool
$c>= :: UserId -> UserId -> Bool
> :: UserId -> UserId -> Bool
$c> :: UserId -> UserId -> Bool
<= :: UserId -> UserId -> Bool
$c<= :: UserId -> UserId -> Bool
< :: UserId -> UserId -> Bool
$c< :: UserId -> UserId -> Bool
compare :: UserId -> UserId -> Ordering
$ccompare :: UserId -> UserId -> Ordering
$cp1Ord :: Eq UserId
Ord, UserId -> UserId -> Bool
(UserId -> UserId -> Bool)
-> (UserId -> UserId -> Bool) -> Eq UserId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserId -> UserId -> Bool
$c/= :: UserId -> UserId -> Bool
== :: UserId -> UserId -> Bool
$c== :: UserId -> UserId -> Bool
Eq, Value -> Parser [UserId]
Value -> Parser UserId
(Value -> Parser UserId)
-> (Value -> Parser [UserId]) -> FromJSON UserId
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [UserId]
$cparseJSONList :: Value -> Parser [UserId]
parseJSON :: Value -> Parser UserId
$cparseJSON :: Value -> Parser UserId
FromJSON, [UserId] -> Encoding
[UserId] -> Value
UserId -> Encoding
UserId -> Value
(UserId -> Value)
-> (UserId -> Encoding)
-> ([UserId] -> Value)
-> ([UserId] -> Encoding)
-> ToJSON UserId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [UserId] -> Encoding
$ctoEncodingList :: [UserId] -> Encoding
toJSONList :: [UserId] -> Value
$ctoJSONList :: [UserId] -> Value
toEncoding :: UserId -> Encoding
$ctoEncoding :: UserId -> Encoding
toJSON :: UserId -> Value
$ctoJSON :: UserId -> Value
ToJSON, Int -> UserId -> Int
UserId -> Int
(Int -> UserId -> Int) -> (UserId -> Int) -> Hashable UserId
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: UserId -> Int
$chash :: UserId -> Int
hashWithSalt :: Int -> UserId -> Int
$chashWithSalt :: Int -> UserId -> Int
Hashable )
#if MIN_VERSION_aeson(1,0,0)
deriving instance FromJSONKey UserId
deriving instance ToJSONKey UserId
#endif
data Role = Role ByteString
deriving (ReadPrec [Role]
ReadPrec Role
Int -> ReadS Role
ReadS [Role]
(Int -> ReadS Role)
-> ReadS [Role] -> ReadPrec Role -> ReadPrec [Role] -> Read Role
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Role]
$creadListPrec :: ReadPrec [Role]
readPrec :: ReadPrec Role
$creadPrec :: ReadPrec Role
readList :: ReadS [Role]
$creadList :: ReadS [Role]
readsPrec :: Int -> ReadS Role
$creadsPrec :: Int -> ReadS Role
Read, Int -> Role -> ShowS
[Role] -> ShowS
Role -> String
(Int -> Role -> ShowS)
-> (Role -> String) -> ([Role] -> ShowS) -> Show Role
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Role] -> ShowS
$cshowList :: [Role] -> ShowS
show :: Role -> String
$cshow :: Role -> String
showsPrec :: Int -> Role -> ShowS
$cshowsPrec :: Int -> Role -> ShowS
Show, Eq Role
Eq Role =>
(Role -> Role -> Ordering)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Bool)
-> (Role -> Role -> Role)
-> (Role -> Role -> Role)
-> Ord Role
Role -> Role -> Bool
Role -> Role -> Ordering
Role -> Role -> Role
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Role -> Role -> Role
$cmin :: Role -> Role -> Role
max :: Role -> Role -> Role
$cmax :: Role -> Role -> Role
>= :: Role -> Role -> Bool
$c>= :: Role -> Role -> Bool
> :: Role -> Role -> Bool
$c> :: Role -> Role -> Bool
<= :: Role -> Role -> Bool
$c<= :: Role -> Role -> Bool
< :: Role -> Role -> Bool
$c< :: Role -> Role -> Bool
compare :: Role -> Role -> Ordering
$ccompare :: Role -> Role -> Ordering
$cp1Ord :: Eq Role
Ord, Role -> Role -> Bool
(Role -> Role -> Bool) -> (Role -> Role -> Bool) -> Eq Role
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Role -> Role -> Bool
$c/= :: Role -> Role -> Bool
== :: Role -> Role -> Bool
$c== :: Role -> Role -> Bool
Eq)
data AuthUser = AuthUser
{ AuthUser -> Maybe UserId
userId :: Maybe UserId
, AuthUser -> Text
userLogin :: Text
, AuthUser -> Maybe Text
userEmail :: Maybe Text
, AuthUser -> Maybe Password
userPassword :: Maybe Password
, AuthUser -> Maybe UTCTime
userActivatedAt :: Maybe UTCTime
, AuthUser -> Maybe UTCTime
userSuspendedAt :: Maybe UTCTime
, AuthUser -> Maybe Text
userRememberToken :: Maybe Text
, AuthUser -> Int
userLoginCount :: Int
, AuthUser -> Int
userFailedLoginCount :: Int
, AuthUser -> Maybe UTCTime
userLockedOutUntil :: Maybe UTCTime
, AuthUser -> Maybe UTCTime
userCurrentLoginAt :: Maybe UTCTime
, AuthUser -> Maybe UTCTime
userLastLoginAt :: Maybe UTCTime
, AuthUser -> Maybe ByteString
userCurrentLoginIp :: Maybe ByteString
, AuthUser -> Maybe ByteString
userLastLoginIp :: Maybe ByteString
, AuthUser -> Maybe UTCTime
userCreatedAt :: Maybe UTCTime
, AuthUser -> Maybe UTCTime
userUpdatedAt :: Maybe UTCTime
, AuthUser -> Maybe Text
userResetToken :: Maybe Text
, AuthUser -> Maybe UTCTime
userResetRequestedAt :: Maybe UTCTime
, AuthUser -> [Role]
userRoles :: [Role]
, AuthUser -> HashMap Text Value
userMeta :: HashMap Text Value
}
deriving (Int -> AuthUser -> ShowS
[AuthUser] -> ShowS
AuthUser -> String
(Int -> AuthUser -> ShowS)
-> (AuthUser -> String) -> ([AuthUser] -> ShowS) -> Show AuthUser
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthUser] -> ShowS
$cshowList :: [AuthUser] -> ShowS
show :: AuthUser -> String
$cshow :: AuthUser -> String
showsPrec :: Int -> AuthUser -> ShowS
$cshowsPrec :: Int -> AuthUser -> ShowS
Show,AuthUser -> AuthUser -> Bool
(AuthUser -> AuthUser -> Bool)
-> (AuthUser -> AuthUser -> Bool) -> Eq AuthUser
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthUser -> AuthUser -> Bool
$c/= :: AuthUser -> AuthUser -> Bool
== :: AuthUser -> AuthUser -> Bool
$c== :: AuthUser -> AuthUser -> Bool
Eq)
defAuthUser :: AuthUser
defAuthUser :: AuthUser
defAuthUser = 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 = Maybe UserId
forall a. Maybe a
Nothing
, userLogin :: Text
userLogin = ""
, userEmail :: Maybe Text
userEmail = Maybe Text
forall a. Maybe a
Nothing
, userPassword :: Maybe Password
userPassword = Maybe Password
forall a. Maybe a
Nothing
, userActivatedAt :: Maybe UTCTime
userActivatedAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userSuspendedAt :: Maybe UTCTime
userSuspendedAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userRememberToken :: Maybe Text
userRememberToken = Maybe Text
forall a. Maybe a
Nothing
, userLoginCount :: Int
userLoginCount = 0
, userFailedLoginCount :: Int
userFailedLoginCount = 0
, userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil = Maybe UTCTime
forall a. Maybe a
Nothing
, userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userLastLoginAt :: Maybe UTCTime
userLastLoginAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp = Maybe ByteString
forall a. Maybe a
Nothing
, userLastLoginIp :: Maybe ByteString
userLastLoginIp = Maybe ByteString
forall a. Maybe a
Nothing
, userCreatedAt :: Maybe UTCTime
userCreatedAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userUpdatedAt :: Maybe UTCTime
userUpdatedAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userResetToken :: Maybe Text
userResetToken = Maybe Text
forall a. Maybe a
Nothing
, userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = Maybe UTCTime
forall a. Maybe a
Nothing
, userRoles :: [Role]
userRoles = []
, userMeta :: HashMap Text Value
userMeta = HashMap Text Value
forall k v. HashMap k v
HM.empty
}
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword au :: AuthUser
au pass :: ByteString
pass = do
Password
pw <- ByteString -> Password
Encrypted (ByteString -> Password) -> IO ByteString -> IO Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Int -> IO ByteString
makePassword ByteString
pass Int
defaultStrength
AuthUser -> IO AuthUser
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthUser -> IO AuthUser) -> AuthUser -> IO AuthUser
forall a b. (a -> b) -> a -> b
$! AuthUser
au { userPassword :: Maybe Password
userPassword = Password -> Maybe Password
forall a. a -> Maybe a
Just Password
pw }
data AuthSettings = AuthSettings {
AuthSettings -> Int
asMinPasswdLen :: Int
, AuthSettings -> ByteString
asRememberCookieName :: ByteString
, AuthSettings -> Maybe Int
asRememberPeriod :: Maybe Int
, AuthSettings -> Maybe (Int, NominalDiffTime)
asLockout :: Maybe (Int, NominalDiffTime)
, AuthSettings -> String
asSiteKey :: FilePath
}
defAuthSettings :: AuthSettings
defAuthSettings :: AuthSettings
defAuthSettings = AuthSettings :: Int
-> ByteString
-> Maybe Int
-> Maybe (Int, NominalDiffTime)
-> String
-> AuthSettings
AuthSettings {
asMinPasswdLen :: Int
asMinPasswdLen = 8
, asRememberCookieName :: ByteString
asRememberCookieName = "_remember"
, asRememberPeriod :: Maybe Int
asRememberPeriod = Int -> Maybe Int
forall a. a -> Maybe a
Just (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*7Int -> Int -> Int
forall a. Num a => a -> a -> a
*24Int -> Int -> Int
forall a. Num a => a -> a -> a
*60Int -> Int -> Int
forall a. Num a => a -> a -> a
*60)
, asLockout :: Maybe (Int, NominalDiffTime)
asLockout = Maybe (Int, NominalDiffTime)
forall a. Maybe a
Nothing
, asSiteKey :: String
asSiteKey = "site_key.txt"
}
authSettingsFromConfig :: Initializer b v AuthSettings
authSettingsFromConfig :: Initializer b v AuthSettings
authSettingsFromConfig = do
Config
config <- Initializer b v Config
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig
Maybe Int
minPasswordLen <- IO (Maybe Int) -> Initializer b v (Maybe Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> Initializer b v (Maybe Int))
-> IO (Maybe Int) -> Initializer b v (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO (Maybe Int)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config "minPasswordLen"
let pw :: AuthSettings -> AuthSettings
pw = (AuthSettings -> AuthSettings)
-> (Int -> AuthSettings -> AuthSettings)
-> Maybe Int
-> AuthSettings
-> AuthSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthSettings -> AuthSettings
forall a. a -> a
id (\x :: Int
x s :: AuthSettings
s -> AuthSettings
s { asMinPasswdLen :: Int
asMinPasswdLen = Int
x }) Maybe Int
minPasswordLen
Maybe ByteString
rememberCookie <- IO (Maybe ByteString) -> Initializer b v (Maybe ByteString)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe ByteString) -> Initializer b v (Maybe ByteString))
-> IO (Maybe ByteString) -> Initializer b v (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO (Maybe ByteString)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config "rememberCookie"
let rc :: AuthSettings -> AuthSettings
rc = (AuthSettings -> AuthSettings)
-> (ByteString -> AuthSettings -> AuthSettings)
-> Maybe ByteString
-> AuthSettings
-> AuthSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthSettings -> AuthSettings
forall a. a -> a
id (\x :: ByteString
x s :: AuthSettings
s -> AuthSettings
s { asRememberCookieName :: ByteString
asRememberCookieName = ByteString
x }) Maybe ByteString
rememberCookie
Maybe Int
rememberPeriod <- IO (Maybe Int) -> Initializer b v (Maybe Int)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Int) -> Initializer b v (Maybe Int))
-> IO (Maybe Int) -> Initializer b v (Maybe Int)
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO (Maybe Int)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config "rememberPeriod"
let rp :: AuthSettings -> AuthSettings
rp = (AuthSettings -> AuthSettings)
-> (Int -> AuthSettings -> AuthSettings)
-> Maybe Int
-> AuthSettings
-> AuthSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthSettings -> AuthSettings
forall a. a -> a
id (\x :: Int
x s :: AuthSettings
s -> AuthSettings
s { asRememberPeriod :: Maybe Int
asRememberPeriod = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
x }) Maybe Int
rememberPeriod
Maybe (Int, Integer)
lockout <- IO (Maybe (Int, Integer)) -> Initializer b v (Maybe (Int, Integer))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Int, Integer))
-> Initializer b v (Maybe (Int, Integer)))
-> IO (Maybe (Int, Integer))
-> Initializer b v (Maybe (Int, Integer))
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO (Maybe (Int, Integer))
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config "lockout"
let lo :: AuthSettings -> AuthSettings
lo = (AuthSettings -> AuthSettings)
-> ((Int, Integer) -> AuthSettings -> AuthSettings)
-> Maybe (Int, Integer)
-> AuthSettings
-> AuthSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthSettings -> AuthSettings
forall a. a -> a
id (\x :: (Int, Integer)
x s :: AuthSettings
s -> AuthSettings
s { asLockout :: Maybe (Int, NominalDiffTime)
asLockout = (Int, NominalDiffTime) -> Maybe (Int, NominalDiffTime)
forall a. a -> Maybe a
Just ((Integer -> NominalDiffTime)
-> (Int, Integer) -> (Int, NominalDiffTime)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second Integer -> NominalDiffTime
forall a. Num a => Integer -> a
fromInteger (Int, Integer)
x) })
Maybe (Int, Integer)
lockout
Maybe String
siteKey <- IO (Maybe String) -> Initializer b v (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> Initializer b v (Maybe String))
-> IO (Maybe String) -> Initializer b v (Maybe String)
forall a b. (a -> b) -> a -> b
$ Config -> Text -> IO (Maybe String)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config "siteKey"
let sk :: AuthSettings -> AuthSettings
sk = (AuthSettings -> AuthSettings)
-> (String -> AuthSettings -> AuthSettings)
-> Maybe String
-> AuthSettings
-> AuthSettings
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AuthSettings -> AuthSettings
forall a. a -> a
id (\x :: String
x s :: AuthSettings
s -> AuthSettings
s { asSiteKey :: String
asSiteKey = String
x }) Maybe String
siteKey
AuthSettings -> Initializer b v AuthSettings
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthSettings -> Initializer b v AuthSettings)
-> AuthSettings -> Initializer b v AuthSettings
forall a b. (a -> b) -> a -> b
$ (AuthSettings -> AuthSettings
pw (AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
rc (AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
rp (AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
lo (AuthSettings -> AuthSettings)
-> (AuthSettings -> AuthSettings) -> AuthSettings -> AuthSettings
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
sk) AuthSettings
defAuthSettings
instance ToJSON AuthUser where
toJSON :: AuthUser -> Value
toJSON u :: AuthUser
u = [Pair] -> Value
object
[ "uid" Text -> Maybe UserId -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UserId
userId AuthUser
u
, "login" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Text
userLogin AuthUser
u
, "email" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe Text
userEmail AuthUser
u
, "pw" Text -> Maybe Password -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe Password
userPassword AuthUser
u
, "activated_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userActivatedAt AuthUser
u
, "suspended_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userSuspendedAt AuthUser
u
, "remember_token" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe Text
userRememberToken AuthUser
u
, "login_count" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Int
userLoginCount AuthUser
u
, "failed_login_count" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Int
userFailedLoginCount AuthUser
u
, "locked_until" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userLockedOutUntil AuthUser
u
, "current_login_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userCurrentLoginAt AuthUser
u
, "last_login_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userLastLoginAt AuthUser
u
, "current_ip" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (AuthUser -> Maybe ByteString
userCurrentLoginIp AuthUser
u)
, "last_ip" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (AuthUser -> Maybe ByteString
userLastLoginIp AuthUser
u)
, "created_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userCreatedAt AuthUser
u
, "updated_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userUpdatedAt AuthUser
u
, "reset_token" Text -> Maybe Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe Text
userResetToken AuthUser
u
, "reset_requested_at" Text -> Maybe UTCTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> Maybe UTCTime
userResetRequestedAt AuthUser
u
, "roles" Text -> [Role] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> [Role]
userRoles AuthUser
u
, "meta" Text -> HashMap Text Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= AuthUser -> HashMap Text Value
userMeta AuthUser
u
]
instance FromJSON AuthUser where
parseJSON :: Value -> Parser AuthUser
parseJSON (Object v :: HashMap Text Value
v) = 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
(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)
-> Parser (Maybe UserId)
-> Parser
(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)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UserId)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "uid"
Parser
(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)
-> Parser Text
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser Text
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "login"
Parser
(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)
-> Parser (Maybe Text)
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Text)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "email"
Parser
(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)
-> Parser (Maybe Password)
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Password)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "pw"
Parser
(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)
-> Parser (Maybe UTCTime)
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "activated_at"
Parser
(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)
-> Parser (Maybe UTCTime)
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "suspended_at"
Parser
(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)
-> Parser (Maybe Text)
-> Parser
(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)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Text)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "remember_token"
Parser
(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)
-> Parser Int
-> Parser
(Int
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser Int
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "login_count"
Parser
(Int
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser Int
-> Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser Int
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "failed_login_count"
Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "locked_until"
Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser
(Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "current_login_at"
Parser
(Maybe UTCTime
-> Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser
(Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "last_login_at"
Parser
(Maybe ByteString
-> Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe ByteString)
-> Parser
(Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Text -> Maybe ByteString)
-> Parser (Maybe Text) -> Parser (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8) (HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Text)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "current_ip")
Parser
(Maybe ByteString
-> Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe ByteString)
-> Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Text -> Maybe ByteString)
-> Parser (Maybe Text) -> Parser (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> ByteString) -> Maybe Text -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8) (HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Text)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "last_ip")
Parser
(Maybe UTCTime
-> Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser
(Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "created_at"
Parser
(Maybe UTCTime
-> Maybe Text
-> Maybe UTCTime
-> [Role]
-> HashMap Text Value
-> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser
(Maybe Text
-> Maybe UTCTime -> [Role] -> HashMap Text Value -> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "updated_at"
Parser
(Maybe Text
-> Maybe UTCTime -> [Role] -> HashMap Text Value -> AuthUser)
-> Parser (Maybe Text)
-> Parser
(Maybe UTCTime -> [Role] -> HashMap Text Value -> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe Text)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "reset_token"
Parser (Maybe UTCTime -> [Role] -> HashMap Text Value -> AuthUser)
-> Parser (Maybe UTCTime)
-> Parser ([Role] -> HashMap Text Value -> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe UTCTime)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "reset_requested_at"
Parser ([Role] -> HashMap Text Value -> AuthUser)
-> Parser [Role] -> Parser (HashMap Text Value -> AuthUser)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (Maybe [Role])
forall a.
FromJSON a =>
HashMap Text Value -> Text -> Parser (Maybe a)
.:? "roles" Parser (Maybe [Role]) -> [Role] -> Parser [Role]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []
Parser (HashMap Text Value -> AuthUser)
-> Parser (HashMap Text Value) -> Parser AuthUser
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> HashMap Text Value
v HashMap Text Value -> Text -> Parser (HashMap Text Value)
forall a. FromJSON a => HashMap Text Value -> Text -> Parser a
.: "meta"
parseJSON _ = String -> Parser AuthUser
forall a. HasCallStack => String -> a
error "Unexpected JSON input"
instance ToJSON Password where
toJSON :: Password -> Value
toJSON (Encrypted x :: ByteString
x) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
x
toJSON (ClearText _) =
String -> Value
forall a. HasCallStack => String -> a
error "ClearText passwords can't be serialized into JSON"
instance FromJSON Password where
parseJSON :: Value -> Parser Password
parseJSON = (Text -> Password) -> Parser Text -> Parser Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Password
Encrypted (ByteString -> Password)
-> (Text -> ByteString) -> Text -> Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) (Parser Text -> Parser Password)
-> (Value -> Parser Text) -> Value -> Parser Password
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON
instance ToJSON Role where
toJSON :: Role -> Value
toJSON (Role x :: ByteString
x) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
x
instance FromJSON Role where
parseJSON :: Value -> Parser Role
parseJSON = (Text -> Role) -> Parser Text -> Parser Role
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Role
Role (ByteString -> Role) -> (Text -> ByteString) -> Text -> Role
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) (Parser Text -> Parser Role)
-> (Value -> Parser Text) -> Value -> Parser Role
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
parseJSON