{-# 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


------------------------------------------------------------------------------
-- | Password is clear when supplied by the user and encrypted later when
-- returned from the db.
data Password = ClearText ByteString
              | Encrypted ByteString
  deriving (ReadPrec [Password]
ReadPrec Password
Int -> ReadS Password
ReadS [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
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
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
Ord, Password -> Password -> Bool
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)


------------------------------------------------------------------------------
-- | Default strength level to pass into makePassword.
defaultStrength :: Int
defaultStrength :: Int
defaultStrength = Int
12


-------------------------------------------------------------------------------
-- | The underlying encryption function, in case you need it for
-- external processing.
encrypt :: ByteString -> IO ByteString
encrypt :: ByteString -> IO ByteString
encrypt = forall a b c. (a -> b -> c) -> b -> a -> c
flip ByteString -> Int -> IO ByteString
makePassword Int
defaultStrength


-------------------------------------------------------------------------------
-- | The underlying verify function, in case you need it for external
-- processing.
verify 
    :: ByteString               -- ^ Cleartext
    -> ByteString               -- ^ Encrypted reference
    -> Bool
verify :: ByteString -> ByteString -> Bool
verify = ByteString -> ByteString -> Bool
verifyPassword 


------------------------------------------------------------------------------
-- | Turn a 'ClearText' password into an 'Encrypted' password, ready to
-- be stuffed into a database.
encryptPassword :: Password -> IO Password
encryptPassword :: Password -> IO Password
encryptPassword p :: Password
p@(Encrypted {}) = forall (m :: * -> *) a. Monad m => a -> m a
return Password
p
encryptPassword (ClearText ByteString
p)    = ByteString -> Password
Encrypted 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 ByteString
pw) (Encrypted ByteString
pw') = ByteString -> ByteString -> Bool
verify ByteString
pw ByteString
pw'
checkPassword (ClearText ByteString
pw) (ClearText ByteString
pw') = ByteString
pw forall a. Eq a => a -> a -> Bool
== ByteString
pw'
checkPassword (Encrypted ByteString
pw) (Encrypted ByteString
pw') = ByteString
pw forall a. Eq a => a -> a -> Bool
== ByteString
pw'
checkPassword Password
_ Password
_ =
  forall a. HasCallStack => String -> a
error String
"checkPassword failed. Make sure you pass ClearText passwords"


------------------------------------------------------------------------------
-- | Authentication failures indicate what went wrong during authentication.
-- They may provide useful information to the developer, although it is
-- generally not advisable to show the user the exact details about why login
-- failed.
data AuthFailure = AuthError String
                 | BackendError
                 | DuplicateLogin
                 | EncryptedPassword
                 | IncorrectPassword
                 | LockedOut UTCTime    -- ^ Locked out until given time
                 | PasswordMissing
                 | UsernameMissing
                 | UserNotFound
  deriving (ReadPrec [AuthFailure]
ReadPrec AuthFailure
Int -> ReadS AuthFailure
ReadS [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
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
Ord, AuthFailure -> AuthFailure -> Bool
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 String
s) = String
s
        show (AuthFailure
BackendError) = String
"Failed to store data in the backend."
        show (AuthFailure
DuplicateLogin) = String
"This login already exists in the backend."
        show (AuthFailure
EncryptedPassword) = String
"Cannot login with encrypted password."
        show (AuthFailure
IncorrectPassword) = String
"The password provided was not valid."
        show (LockedOut UTCTime
time) = String
"The login is locked out until " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UTCTime
time
        show (AuthFailure
PasswordMissing) = String
"No password provided."
        show (AuthFailure
UsernameMissing) = String
"No username provided."
        show (AuthFailure
UserNotFound) = String
"User not found in the backend."


------------------------------------------------------------------------------
-- | Internal representation of a 'User'. By convention, we demand that the
-- application is able to directly fetch a 'User' using this identifier.
--
-- Think of this type as a secure, authenticated user. You should normally
-- never see this type unless a user has been authenticated.
newtype UserId = UserId { UserId -> Text
unUid :: Text }
  deriving ( ReadPrec [UserId]
ReadPrec UserId
Int -> ReadS UserId
ReadS [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
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
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
Ord, UserId -> UserId -> Bool
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
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
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, Eq UserId
Int -> UserId -> Int
UserId -> Int
forall a. Eq 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

------------------------------------------------------------------------------
-- | This will be replaced by a role-based permission system.
data Role = Role ByteString
  deriving (ReadPrec [Role]
ReadPrec Role
Int -> ReadS Role
ReadS [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
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
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
Ord, Role -> Role -> Bool
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)


------------------------------------------------------------------------------
-- | Type representing the concept of a User in your application.
data AuthUser = AuthUser
    { AuthUser -> Maybe UserId
userId               :: Maybe UserId
    , AuthUser -> Text
userLogin            :: Text

    -- We have to have an email field for password reset functionality, but we
    -- don't want to force users to log in with their email address.
    , 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
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
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)


------------------------------------------------------------------------------
-- | Default AuthUser that has all empty values.
defAuthUser :: AuthUser
defAuthUser :: AuthUser
defAuthUser = AuthUser
    { userId :: Maybe UserId
userId               = forall a. Maybe a
Nothing
    , userLogin :: Text
userLogin            = Text
""
    , userEmail :: Maybe Text
userEmail            = forall a. Maybe a
Nothing
    , userPassword :: Maybe Password
userPassword         = forall a. Maybe a
Nothing
    , userActivatedAt :: Maybe UTCTime
userActivatedAt      = forall a. Maybe a
Nothing
    , userSuspendedAt :: Maybe UTCTime
userSuspendedAt      = forall a. Maybe a
Nothing
    , userRememberToken :: Maybe Text
userRememberToken    = forall a. Maybe a
Nothing
    , userLoginCount :: Int
userLoginCount       = Int
0
    , userFailedLoginCount :: Int
userFailedLoginCount = Int
0
    , userLockedOutUntil :: Maybe UTCTime
userLockedOutUntil   = forall a. Maybe a
Nothing
    , userCurrentLoginAt :: Maybe UTCTime
userCurrentLoginAt   = forall a. Maybe a
Nothing
    , userLastLoginAt :: Maybe UTCTime
userLastLoginAt      = forall a. Maybe a
Nothing
    , userCurrentLoginIp :: Maybe ByteString
userCurrentLoginIp   = forall a. Maybe a
Nothing
    , userLastLoginIp :: Maybe ByteString
userLastLoginIp      = forall a. Maybe a
Nothing
    , userCreatedAt :: Maybe UTCTime
userCreatedAt        = forall a. Maybe a
Nothing
    , userUpdatedAt :: Maybe UTCTime
userUpdatedAt        = forall a. Maybe a
Nothing
    , userResetToken :: Maybe Text
userResetToken       = forall a. Maybe a
Nothing
    , userResetRequestedAt :: Maybe UTCTime
userResetRequestedAt = forall a. Maybe a
Nothing
    , userRoles :: [Role]
userRoles            = []
    , userMeta :: HashMap Text Value
userMeta             = forall k v. HashMap k v
HM.empty
    }


------------------------------------------------------------------------------
-- | Set a new password for the given user. Given password should be
-- clear-text; it will be encrypted into a 'Encrypted'.
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword :: AuthUser -> ByteString -> IO AuthUser
setPassword AuthUser
au ByteString
pass = do
    Password
pw <- ByteString -> Password
Encrypted forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Int -> IO ByteString
makePassword ByteString
pass Int
defaultStrength
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! AuthUser
au { userPassword :: Maybe Password
userPassword = forall a. a -> Maybe a
Just Password
pw }


------------------------------------------------------------------------------
-- | Authentication settings defined at initialization time
data AuthSettings = AuthSettings {
    AuthSettings -> Int
asMinPasswdLen       :: Int
      -- ^ Currently not used/checked

  , AuthSettings -> ByteString
asRememberCookieName :: ByteString
      -- ^ Name of the desired remember cookie

  , AuthSettings -> Maybe Int
asRememberPeriod     :: Maybe Int
      -- ^ How long to remember when the option is used in rest of the API.
    -- 'Nothing' means remember until end of session.

  , AuthSettings -> Maybe (Int, NominalDiffTime)
asLockout            :: Maybe (Int, NominalDiffTime)
      -- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration])

  , AuthSettings -> String
asSiteKey            :: FilePath
      -- ^ Location of app's encryption key
}


------------------------------------------------------------------------------
-- | Default settings for Auth.
--
-- > asMinPasswdLen = 8
-- > asRememberCookieName = "_remember"
-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks
-- > asLockout = Nothing
-- > asSiteKey = "site_key.txt"
defAuthSettings :: AuthSettings
defAuthSettings :: AuthSettings
defAuthSettings = AuthSettings {
    asMinPasswdLen :: Int
asMinPasswdLen       = Int
8
  , asRememberCookieName :: ByteString
asRememberCookieName = ByteString
"_remember"
  , asRememberPeriod :: Maybe Int
asRememberPeriod     = forall a. a -> Maybe a
Just (Int
2forall a. Num a => a -> a -> a
*Int
7forall a. Num a => a -> a -> a
*Int
24forall a. Num a => a -> a -> a
*Int
60forall a. Num a => a -> a -> a
*Int
60)
  , asLockout :: Maybe (Int, NominalDiffTime)
asLockout            = forall a. Maybe a
Nothing
  , asSiteKey :: String
asSiteKey            = String
"site_key.txt"
}


------------------------------------------------------------------------------
-- | Function to get auth settings from a config file.  This function can be
-- used by the authors of auth snaplet backends in the initializer to let the
-- user configure the auth snaplet from a config file.  All options are
-- optional and default to what's in defAuthSettings if not supplied.
-- Here's what the default options would look like in the config file:
--
-- > minPasswordLen = 8
-- > rememberCookie = "_remember"
-- > rememberPeriod = 1209600 # 2 weeks
-- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds
-- > siteKey = "site_key.txt"
authSettingsFromConfig :: Initializer b v AuthSettings
authSettingsFromConfig :: forall b v. Initializer b v AuthSettings
authSettingsFromConfig = do
    Config
config <- forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig
    Maybe Int
minPasswordLen <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"minPasswordLen"
    let pw :: AuthSettings -> AuthSettings
pw = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Int
x AuthSettings
s -> AuthSettings
s { asMinPasswdLen :: Int
asMinPasswdLen = Int
x }) Maybe Int
minPasswordLen
    Maybe ByteString
rememberCookie <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"rememberCookie"
    let rc :: AuthSettings -> AuthSettings
rc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\ByteString
x AuthSettings
s -> AuthSettings
s { asRememberCookieName :: ByteString
asRememberCookieName = ByteString
x }) Maybe ByteString
rememberCookie
    Maybe Int
rememberPeriod <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"rememberPeriod"
    let rp :: AuthSettings -> AuthSettings
rp = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\Int
x AuthSettings
s -> AuthSettings
s { asRememberPeriod :: Maybe Int
asRememberPeriod = forall a. a -> Maybe a
Just Int
x }) Maybe Int
rememberPeriod
    Maybe (Int, Integer)
lockout <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"lockout"
    let lo :: AuthSettings -> AuthSettings
lo = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\(Int, Integer)
x AuthSettings
s -> AuthSettings
s { asLockout :: Maybe (Int, NominalDiffTime)
asLockout = forall a. a -> Maybe a
Just (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second forall a. Num a => Integer -> a
fromInteger (Int, Integer)
x) })
                   Maybe (Int, Integer)
lockout
    Maybe String
siteKey <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"siteKey"
    let sk :: AuthSettings -> AuthSettings
sk = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\String
x AuthSettings
s -> AuthSettings
s { asSiteKey :: String
asSiteKey = String
x }) Maybe String
siteKey
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (AuthSettings -> AuthSettings
pw forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
rc forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
rp forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
lo forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthSettings -> AuthSettings
sk) AuthSettings
defAuthSettings


                             --------------------
                             -- JSON Instances --
                             --------------------

------------------------------------------------------------------------------
instance ToJSON AuthUser where
  toJSON :: AuthUser -> Value
toJSON AuthUser
u = [Pair] -> Value
object
    [ Key
"uid"                forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UserId
userId                AuthUser
u
    , Key
"login"              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Text
userLogin             AuthUser
u
    , Key
"email"              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe Text
userEmail             AuthUser
u
    , Key
"pw"                 forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe Password
userPassword          AuthUser
u
    , Key
"activated_at"       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userActivatedAt       AuthUser
u
    , Key
"suspended_at"       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userSuspendedAt       AuthUser
u
    , Key
"remember_token"     forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe Text
userRememberToken     AuthUser
u
    , Key
"login_count"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Int
userLoginCount        AuthUser
u
    , Key
"failed_login_count" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Int
userFailedLoginCount  AuthUser
u
    , Key
"locked_until"       forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userLockedOutUntil    AuthUser
u
    , Key
"current_login_at"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userCurrentLoginAt    AuthUser
u
    , Key
"last_login_at"      forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userLastLoginAt       AuthUser
u
    , Key
"current_ip"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (AuthUser -> Maybe ByteString
userCurrentLoginIp AuthUser
u)
    , Key
"last_ip"            forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (AuthUser -> Maybe ByteString
userLastLoginIp AuthUser
u)
    , Key
"created_at"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userCreatedAt         AuthUser
u
    , Key
"updated_at"         forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userUpdatedAt         AuthUser
u
    , Key
"reset_token"        forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe Text
userResetToken        AuthUser
u
    , Key
"reset_requested_at" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> Maybe UTCTime
userResetRequestedAt  AuthUser
u
    , Key
"roles"              forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> [Role]
userRoles             AuthUser
u
    , Key
"meta"               forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= AuthUser -> HashMap Text Value
userMeta              AuthUser
u
    ]


------------------------------------------------------------------------------
instance FromJSON AuthUser where
  parseJSON :: Value -> Parser AuthUser
parseJSON (Object Object
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
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"uid"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"login"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"pw"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"activated_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"suspended_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"remember_token"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"login_count"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"failed_login_count"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"locked_until"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"current_login_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"last_login_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8) (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"current_ip")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
encodeUtf8) (Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"last_ip")
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"created_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"updated_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reset_token"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"reset_requested_at"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"roles" forall a. Parser (Maybe a) -> a -> Parser a
.!= []
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"meta"
  parseJSON Value
_ = forall a. HasCallStack => String -> a
error String
"Unexpected JSON input"


------------------------------------------------------------------------------
instance ToJSON Password where
  toJSON :: Password -> Value
toJSON (Encrypted ByteString
x) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
x
  toJSON (ClearText ByteString
_) =
      forall a. HasCallStack => String -> a
error String
"ClearText passwords can't be serialized into JSON"


------------------------------------------------------------------------------
instance FromJSON Password where
  parseJSON :: Value -> Parser Password
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Password
Encrypted forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON


------------------------------------------------------------------------------
instance ToJSON Role where
  toJSON :: Role -> Value
toJSON (Role ByteString
x) = forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
x


------------------------------------------------------------------------------
instance FromJSON Role where
  parseJSON :: Value -> Parser Role
parseJSON = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Role
Role forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Parser a
parseJSON