{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
module Web.Users.Types
    ( -- * The core type class
      UserStorageBackend (..)
      -- * User representation
    , User(..), Password(..), makePassword, hidePassword
    , PasswordPlain(..), verifyPassword
    , UserField(..)
      -- * Token types
    , PasswordResetToken(..), ActivationToken(..), SessionId(..)
      -- * Error types
    , CreateUserError(..), UpdateUserError(..)
    , TokenError(..)
      -- * Helper typed
    , SortBy(..)
    )
where

import Crypto.BCrypt
import Data.Aeson
import Data.Int
import Data.Maybe
import Data.String
import Data.Time.Clock
import Data.Typeable
import Web.PathPieces
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified System.IO.Unsafe as U

-- | Errors that happen on storage level during user creation
data CreateUserError
   = InvalidPassword
   | UsernameAlreadyTaken
   | EmailAlreadyTaken
   | UsernameAndEmailAlreadyTaken
   deriving (Int -> CreateUserError -> ShowS
[CreateUserError] -> ShowS
CreateUserError -> String
(Int -> CreateUserError -> ShowS)
-> (CreateUserError -> String)
-> ([CreateUserError] -> ShowS)
-> Show CreateUserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CreateUserError -> ShowS
showsPrec :: Int -> CreateUserError -> ShowS
$cshow :: CreateUserError -> String
show :: CreateUserError -> String
$cshowList :: [CreateUserError] -> ShowS
showList :: [CreateUserError] -> ShowS
Show, CreateUserError -> CreateUserError -> Bool
(CreateUserError -> CreateUserError -> Bool)
-> (CreateUserError -> CreateUserError -> Bool)
-> Eq CreateUserError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CreateUserError -> CreateUserError -> Bool
== :: CreateUserError -> CreateUserError -> Bool
$c/= :: CreateUserError -> CreateUserError -> Bool
/= :: CreateUserError -> CreateUserError -> Bool
Eq)

-- | Errors that happen on storage level during user updating
data UpdateUserError
   = UsernameAlreadyExists
   | EmailAlreadyExists
   | UserDoesntExist
   deriving (Int -> UpdateUserError -> ShowS
[UpdateUserError] -> ShowS
UpdateUserError -> String
(Int -> UpdateUserError -> ShowS)
-> (UpdateUserError -> String)
-> ([UpdateUserError] -> ShowS)
-> Show UpdateUserError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpdateUserError -> ShowS
showsPrec :: Int -> UpdateUserError -> ShowS
$cshow :: UpdateUserError -> String
show :: UpdateUserError -> String
$cshowList :: [UpdateUserError] -> ShowS
showList :: [UpdateUserError] -> ShowS
Show, UpdateUserError -> UpdateUserError -> Bool
(UpdateUserError -> UpdateUserError -> Bool)
-> (UpdateUserError -> UpdateUserError -> Bool)
-> Eq UpdateUserError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpdateUserError -> UpdateUserError -> Bool
== :: UpdateUserError -> UpdateUserError -> Bool
$c/= :: UpdateUserError -> UpdateUserError -> Bool
/= :: UpdateUserError -> UpdateUserError -> Bool
Eq)

-- | Errors that happen on storage level during token actions
data TokenError
   = TokenInvalid
   deriving (Int -> TokenError -> ShowS
[TokenError] -> ShowS
TokenError -> String
(Int -> TokenError -> ShowS)
-> (TokenError -> String)
-> ([TokenError] -> ShowS)
-> Show TokenError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TokenError -> ShowS
showsPrec :: Int -> TokenError -> ShowS
$cshow :: TokenError -> String
show :: TokenError -> String
$cshowList :: [TokenError] -> ShowS
showList :: [TokenError] -> ShowS
Show, TokenError -> TokenError -> Bool
(TokenError -> TokenError -> Bool)
-> (TokenError -> TokenError -> Bool) -> Eq TokenError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TokenError -> TokenError -> Bool
== :: TokenError -> TokenError -> Bool
$c/= :: TokenError -> TokenError -> Bool
/= :: TokenError -> TokenError -> Bool
Eq)

-- | Sorting direction
data SortBy t
   = SortAsc t
   | SortDesc t

-- | Backend constraints
type IsUserBackend b =
  ( Show (UserId b)
  , Eq (UserId b)
  , ToJSON (UserId b)
  , FromJSON (UserId b)
  , Typeable (UserId b)
  , PathPiece (UserId b)
  )

-- | An abstract backend for managing users. A backend library should implement the interface and
-- an end user should build applications on top of this interface.
class IsUserBackend b => UserStorageBackend b where
    -- | The storage backends userid
    type UserId b :: *
    -- | Initialise the backend. Call once on application launch to for
    -- example create missing database tables
    initUserBackend :: b -> IO ()
    -- | Destory the backend. WARNING: This is only for testing! It deletes all tables and data.
    destroyUserBackend :: b -> IO ()
    -- | This cleans up invalid sessions and other tokens. Call periodically as needed.
    housekeepBackend :: b -> IO ()
    -- | Retrieve a user id from the database
    getUserIdByName :: b -> T.Text -> IO (Maybe (UserId b))
    -- | Retrieve a user from the database
    getUserById :: b -> UserId b -> IO (Maybe User)
    -- | List all users unlimited, or limited, sorted by a 'UserField'
    listUsers :: b -> Maybe (Int64, Int64) -> SortBy UserField -> IO [(UserId b, User)]
    -- | Count all users
    countUsers :: b -> IO Int64
    -- | Create a user
    createUser :: b -> User -> IO (Either CreateUserError (UserId b))
    -- | Modify a user
    updateUser :: b -> UserId b -> (User -> User) -> IO (Either UpdateUserError ())
    -- | Delete a user
    deleteUser :: b -> UserId b -> IO ()
    -- | Authentificate a user using username/email and password. The 'NominalDiffTime' describes the session duration
    authUser :: b -> T.Text -> PasswordPlain -> NominalDiffTime -> IO (Maybe SessionId)
    -- | Authentificate a user and execute a single action.
    withAuthUser :: b -> T.Text -> (User -> Bool) -> (UserId b -> IO r) -> IO (Maybe r)
    -- | Verify a 'SessionId'. The session duration can be extended by 'NominalDiffTime'
    verifySession :: b -> SessionId -> NominalDiffTime -> IO (Maybe (UserId b))
    -- | Force create a session for a user. This is useful for support/admin login.
    -- If the user does not exist, this will fail.
    createSession :: b -> UserId b -> NominalDiffTime -> IO (Maybe SessionId)
    -- | Destroy a session
    destroySession :: b -> SessionId -> IO ()
    -- | Request a 'PasswordResetToken' for a given user, valid for 'NominalDiffTime'
    requestPasswordReset :: b -> UserId b -> NominalDiffTime -> IO PasswordResetToken
    -- | Check if a 'PasswordResetToken' is still valid and retrieve the owner of it
    verifyPasswordResetToken :: b -> PasswordResetToken -> IO (Maybe User)
    -- | Apply a new password to the owner of 'PasswordResetToken' iff the token is still valid
    applyNewPassword :: b -> PasswordResetToken -> Password -> IO (Either TokenError ())
    -- | Request an 'ActivationToken' for a given user, valid for 'NominalDiffTime'
    requestActivationToken :: b -> UserId b -> NominalDiffTime -> IO ActivationToken
    -- | Activate the owner of 'ActivationToken' iff the token is still valid
    activateUser :: b -> ActivationToken -> IO (Either TokenError ())

-- | A password reset token to send out to users via email or sms
newtype PasswordResetToken
    = PasswordResetToken { PasswordResetToken -> Text
unPasswordResetToken :: T.Text }
    deriving (Int -> PasswordResetToken -> ShowS
[PasswordResetToken] -> ShowS
PasswordResetToken -> String
(Int -> PasswordResetToken -> ShowS)
-> (PasswordResetToken -> String)
-> ([PasswordResetToken] -> ShowS)
-> Show PasswordResetToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PasswordResetToken -> ShowS
showsPrec :: Int -> PasswordResetToken -> ShowS
$cshow :: PasswordResetToken -> String
show :: PasswordResetToken -> String
$cshowList :: [PasswordResetToken] -> ShowS
showList :: [PasswordResetToken] -> ShowS
Show, PasswordResetToken -> PasswordResetToken -> Bool
(PasswordResetToken -> PasswordResetToken -> Bool)
-> (PasswordResetToken -> PasswordResetToken -> Bool)
-> Eq PasswordResetToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PasswordResetToken -> PasswordResetToken -> Bool
== :: PasswordResetToken -> PasswordResetToken -> Bool
$c/= :: PasswordResetToken -> PasswordResetToken -> Bool
/= :: PasswordResetToken -> PasswordResetToken -> Bool
Eq, [PasswordResetToken] -> Value
[PasswordResetToken] -> Encoding
PasswordResetToken -> Bool
PasswordResetToken -> Value
PasswordResetToken -> Encoding
(PasswordResetToken -> Value)
-> (PasswordResetToken -> Encoding)
-> ([PasswordResetToken] -> Value)
-> ([PasswordResetToken] -> Encoding)
-> (PasswordResetToken -> Bool)
-> ToJSON PasswordResetToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: PasswordResetToken -> Value
toJSON :: PasswordResetToken -> Value
$ctoEncoding :: PasswordResetToken -> Encoding
toEncoding :: PasswordResetToken -> Encoding
$ctoJSONList :: [PasswordResetToken] -> Value
toJSONList :: [PasswordResetToken] -> Value
$ctoEncodingList :: [PasswordResetToken] -> Encoding
toEncodingList :: [PasswordResetToken] -> Encoding
$comitField :: PasswordResetToken -> Bool
omitField :: PasswordResetToken -> Bool
ToJSON, Maybe PasswordResetToken
Value -> Parser [PasswordResetToken]
Value -> Parser PasswordResetToken
(Value -> Parser PasswordResetToken)
-> (Value -> Parser [PasswordResetToken])
-> Maybe PasswordResetToken
-> FromJSON PasswordResetToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PasswordResetToken
parseJSON :: Value -> Parser PasswordResetToken
$cparseJSONList :: Value -> Parser [PasswordResetToken]
parseJSONList :: Value -> Parser [PasswordResetToken]
$comittedField :: Maybe PasswordResetToken
omittedField :: Maybe PasswordResetToken
FromJSON, Typeable, Text -> Maybe PasswordResetToken
PasswordResetToken -> Text
(Text -> Maybe PasswordResetToken)
-> (PasswordResetToken -> Text) -> PathPiece PasswordResetToken
forall s. (Text -> Maybe s) -> (s -> Text) -> PathPiece s
$cfromPathPiece :: Text -> Maybe PasswordResetToken
fromPathPiece :: Text -> Maybe PasswordResetToken
$ctoPathPiece :: PasswordResetToken -> Text
toPathPiece :: PasswordResetToken -> Text
PathPiece)

-- | An activation token to send out to users via email or sms
newtype ActivationToken
    = ActivationToken { ActivationToken -> Text
unActivationToken :: T.Text }
    deriving (Int -> ActivationToken -> ShowS
[ActivationToken] -> ShowS
ActivationToken -> String
(Int -> ActivationToken -> ShowS)
-> (ActivationToken -> String)
-> ([ActivationToken] -> ShowS)
-> Show ActivationToken
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ActivationToken -> ShowS
showsPrec :: Int -> ActivationToken -> ShowS
$cshow :: ActivationToken -> String
show :: ActivationToken -> String
$cshowList :: [ActivationToken] -> ShowS
showList :: [ActivationToken] -> ShowS
Show, ActivationToken -> ActivationToken -> Bool
(ActivationToken -> ActivationToken -> Bool)
-> (ActivationToken -> ActivationToken -> Bool)
-> Eq ActivationToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ActivationToken -> ActivationToken -> Bool
== :: ActivationToken -> ActivationToken -> Bool
$c/= :: ActivationToken -> ActivationToken -> Bool
/= :: ActivationToken -> ActivationToken -> Bool
Eq, [ActivationToken] -> Value
[ActivationToken] -> Encoding
ActivationToken -> Bool
ActivationToken -> Value
ActivationToken -> Encoding
(ActivationToken -> Value)
-> (ActivationToken -> Encoding)
-> ([ActivationToken] -> Value)
-> ([ActivationToken] -> Encoding)
-> (ActivationToken -> Bool)
-> ToJSON ActivationToken
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: ActivationToken -> Value
toJSON :: ActivationToken -> Value
$ctoEncoding :: ActivationToken -> Encoding
toEncoding :: ActivationToken -> Encoding
$ctoJSONList :: [ActivationToken] -> Value
toJSONList :: [ActivationToken] -> Value
$ctoEncodingList :: [ActivationToken] -> Encoding
toEncodingList :: [ActivationToken] -> Encoding
$comitField :: ActivationToken -> Bool
omitField :: ActivationToken -> Bool
ToJSON, Maybe ActivationToken
Value -> Parser [ActivationToken]
Value -> Parser ActivationToken
(Value -> Parser ActivationToken)
-> (Value -> Parser [ActivationToken])
-> Maybe ActivationToken
-> FromJSON ActivationToken
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser ActivationToken
parseJSON :: Value -> Parser ActivationToken
$cparseJSONList :: Value -> Parser [ActivationToken]
parseJSONList :: Value -> Parser [ActivationToken]
$comittedField :: Maybe ActivationToken
omittedField :: Maybe ActivationToken
FromJSON, Typeable, Text -> Maybe ActivationToken
ActivationToken -> Text
(Text -> Maybe ActivationToken)
-> (ActivationToken -> Text) -> PathPiece ActivationToken
forall s. (Text -> Maybe s) -> (s -> Text) -> PathPiece s
$cfromPathPiece :: Text -> Maybe ActivationToken
fromPathPiece :: Text -> Maybe ActivationToken
$ctoPathPiece :: ActivationToken -> Text
toPathPiece :: ActivationToken -> Text
PathPiece)

-- | A session id for identifying user sessions
newtype SessionId
    = SessionId { SessionId -> Text
unSessionId :: T.Text }
    deriving (Int -> SessionId -> ShowS
[SessionId] -> ShowS
SessionId -> String
(Int -> SessionId -> ShowS)
-> (SessionId -> String)
-> ([SessionId] -> ShowS)
-> Show SessionId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SessionId -> ShowS
showsPrec :: Int -> SessionId -> ShowS
$cshow :: SessionId -> String
show :: SessionId -> String
$cshowList :: [SessionId] -> ShowS
showList :: [SessionId] -> ShowS
Show, SessionId -> SessionId -> Bool
(SessionId -> SessionId -> Bool)
-> (SessionId -> SessionId -> Bool) -> Eq SessionId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SessionId -> SessionId -> Bool
== :: SessionId -> SessionId -> Bool
$c/= :: SessionId -> SessionId -> Bool
/= :: SessionId -> SessionId -> Bool
Eq, [SessionId] -> Value
[SessionId] -> Encoding
SessionId -> Bool
SessionId -> Value
SessionId -> Encoding
(SessionId -> Value)
-> (SessionId -> Encoding)
-> ([SessionId] -> Value)
-> ([SessionId] -> Encoding)
-> (SessionId -> Bool)
-> ToJSON SessionId
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SessionId -> Value
toJSON :: SessionId -> Value
$ctoEncoding :: SessionId -> Encoding
toEncoding :: SessionId -> Encoding
$ctoJSONList :: [SessionId] -> Value
toJSONList :: [SessionId] -> Value
$ctoEncodingList :: [SessionId] -> Encoding
toEncodingList :: [SessionId] -> Encoding
$comitField :: SessionId -> Bool
omitField :: SessionId -> Bool
ToJSON, Maybe SessionId
Value -> Parser [SessionId]
Value -> Parser SessionId
(Value -> Parser SessionId)
-> (Value -> Parser [SessionId])
-> Maybe SessionId
-> FromJSON SessionId
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser SessionId
parseJSON :: Value -> Parser SessionId
$cparseJSONList :: Value -> Parser [SessionId]
parseJSONList :: Value -> Parser [SessionId]
$comittedField :: Maybe SessionId
omittedField :: Maybe SessionId
FromJSON, Typeable, Text -> Maybe SessionId
SessionId -> Text
(Text -> Maybe SessionId)
-> (SessionId -> Text) -> PathPiece SessionId
forall s. (Text -> Maybe s) -> (s -> Text) -> PathPiece s
$cfromPathPiece :: Text -> Maybe SessionId
fromPathPiece :: Text -> Maybe SessionId
$ctoPathPiece :: SessionId -> Text
toPathPiece :: SessionId -> Text
PathPiece)

-- | Construct a password from plaintext by hashing it
makePassword :: PasswordPlain -> Password
makePassword :: PasswordPlain -> Password
makePassword (PasswordPlain Text
plainText) =
    let hash :: Text
hash =
            ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> ByteString
forall {a}. Maybe a -> a
fromJustPass (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ IO (Maybe ByteString) -> Maybe ByteString
forall a. IO a -> a
U.unsafePerformIO (IO (Maybe ByteString) -> Maybe ByteString)
-> IO (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$
            HashingPolicy -> ByteString -> IO (Maybe ByteString)
hashPasswordUsingPolicy HashingPolicy
policy (Text -> ByteString
T.encodeUtf8 Text
plainText)
    in Text -> Password
PasswordHash Text
hash
    where
      policy :: HashingPolicy
policy =
          HashingPolicy
          { preferredHashCost :: Int
preferredHashCost = Int
8
          , preferredHashAlgorithm :: ByteString
preferredHashAlgorithm = ByteString
"$2b$"
          }
      fromJustPass :: Maybe a -> a
fromJustPass =
          a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error String
"makePassword failed. This is probably a bcrypt library error")

-- | Check a plaintext password against a password
verifyPassword :: PasswordPlain -> Password -> Bool
verifyPassword :: PasswordPlain -> Password -> Bool
verifyPassword (PasswordPlain Text
plainText) Password
pwd =
    case Password
pwd of
      Password
PasswordHidden -> Bool
False
      PasswordHash Text
hash ->
          ByteString -> ByteString -> Bool
validatePassword (Text -> ByteString
T.encodeUtf8 Text
hash) (Text -> ByteString
T.encodeUtf8 Text
plainText)

-- | Plaintext passsword. Used for authentification.
newtype PasswordPlain
    = PasswordPlain { PasswordPlain -> Text
unPasswordPlain :: T.Text }
      deriving (Int -> PasswordPlain -> ShowS
[PasswordPlain] -> ShowS
PasswordPlain -> String
(Int -> PasswordPlain -> ShowS)
-> (PasswordPlain -> String)
-> ([PasswordPlain] -> ShowS)
-> Show PasswordPlain
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PasswordPlain -> ShowS
showsPrec :: Int -> PasswordPlain -> ShowS
$cshow :: PasswordPlain -> String
show :: PasswordPlain -> String
$cshowList :: [PasswordPlain] -> ShowS
showList :: [PasswordPlain] -> ShowS
Show, PasswordPlain -> PasswordPlain -> Bool
(PasswordPlain -> PasswordPlain -> Bool)
-> (PasswordPlain -> PasswordPlain -> Bool) -> Eq PasswordPlain
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PasswordPlain -> PasswordPlain -> Bool
== :: PasswordPlain -> PasswordPlain -> Bool
$c/= :: PasswordPlain -> PasswordPlain -> Bool
/= :: PasswordPlain -> PasswordPlain -> Bool
Eq, Typeable, String -> PasswordPlain
(String -> PasswordPlain) -> IsString PasswordPlain
forall a. (String -> a) -> IsString a
$cfromString :: String -> PasswordPlain
fromString :: String -> PasswordPlain
IsString)

-- | Password representation. When updating or creating a user, use 'makePassword' to create one.
-- The implementation details of this type are ONLY for use in backend implementations.
data Password
   = PasswordHash !T.Text
   | PasswordHidden
    deriving (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
$cshowsPrec :: Int -> Password -> ShowS
showsPrec :: Int -> Password -> ShowS
$cshow :: Password -> String
show :: Password -> String
$cshowList :: [Password] -> ShowS
showList :: [Password] -> ShowS
Show, Password -> Password -> Bool
(Password -> Password -> Bool)
-> (Password -> Password -> Bool) -> Eq Password
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Password -> Password -> Bool
== :: Password -> Password -> Bool
$c/= :: Password -> Password -> Bool
/= :: Password -> Password -> Bool
Eq, Typeable)

-- | Strip the password from the user type.
hidePassword :: User -> User
hidePassword :: User -> User
hidePassword User
user =
    User
user { u_password = PasswordHidden }

-- | Fields of user datatype
data UserField
   = UserFieldId
   | UserFieldName
   | UserFieldEmail
   | UserFieldPassword
   | UserFieldActive
     deriving (Int -> UserField -> ShowS
[UserField] -> ShowS
UserField -> String
(Int -> UserField -> ShowS)
-> (UserField -> String)
-> ([UserField] -> ShowS)
-> Show UserField
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UserField -> ShowS
showsPrec :: Int -> UserField -> ShowS
$cshow :: UserField -> String
show :: UserField -> String
$cshowList :: [UserField] -> ShowS
showList :: [UserField] -> ShowS
Show, UserField -> UserField -> Bool
(UserField -> UserField -> Bool)
-> (UserField -> UserField -> Bool) -> Eq UserField
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UserField -> UserField -> Bool
== :: UserField -> UserField -> Bool
$c/= :: UserField -> UserField -> Bool
/= :: UserField -> UserField -> Bool
Eq)

-- | Core user datatype
data User
   = User
   { User -> Text
u_name :: !T.Text
   , User -> Text
u_email :: !T.Text
   , User -> Password
u_password :: !Password
   , User -> Bool
u_active :: !Bool
   } deriving (Int -> User -> ShowS
[User] -> ShowS
User -> String
(Int -> User -> ShowS)
-> (User -> String) -> ([User] -> ShowS) -> Show User
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> User -> ShowS
showsPrec :: Int -> User -> ShowS
$cshow :: User -> String
show :: User -> String
$cshowList :: [User] -> ShowS
showList :: [User] -> ShowS
Show, User -> User -> Bool
(User -> User -> Bool) -> (User -> User -> Bool) -> Eq User
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: User -> User -> Bool
== :: User -> User -> Bool
$c/= :: User -> User -> Bool
/= :: User -> User -> Bool
Eq, Typeable)

instance ToJSON User where
    toJSON :: User -> Value
toJSON (User Text
name Text
email Password
_ Bool
active) =
        [Pair] -> Value
object
        [ Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
name
        , Key
"email" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
email
        , Key
"active" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Bool
active
        ]

instance FromJSON User where
    parseJSON :: Value -> Parser User
parseJSON =
        String -> (Object -> Parser User) -> Value -> Parser User
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"User" ((Object -> Parser User) -> Value -> Parser User)
-> (Object -> Parser User) -> Value -> Parser User
forall a b. (a -> b) -> a -> b
$ \Object
obj ->
            Text -> Text -> Password -> Bool -> User
User (Text -> Text -> Password -> Bool -> User)
-> Parser Text -> Parser (Text -> Password -> Bool -> User)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
                 Parser (Text -> Password -> Bool -> User)
-> Parser Text -> Parser (Password -> Bool -> User)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"
                 Parser (Password -> Bool -> User)
-> Parser Password -> Parser (Bool -> User)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Text -> Password
parsePassword (Maybe Text -> Password) -> Parser (Maybe Text) -> Parser Password
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"password"))
                 Parser (Bool -> User) -> Parser Bool -> Parser User
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"active"
        where
          parsePassword :: Maybe Text -> Password
parsePassword Maybe Text
maybePass =
              case Maybe Text
maybePass of
                Maybe Text
Nothing -> Password
PasswordHidden
                Just Text
pwd -> PasswordPlain -> Password
makePassword (Text -> PasswordPlain
PasswordPlain Text
pwd)