{-# LANGUAGE UndecidableInstances #-}

module Conduit.Features.Account.User.LoginUser where

import Conduit.App.Monad (AppM, runService)
import Conduit.DB.Core (MonadDB(..), mapMaybeDBResult, sqlKey2ID)
import Conduit.DB.Utils (suchThat)
import Conduit.Features.Account.DB (User(..))
import Conduit.Features.Account.Errors (AccountError(..))
import Conduit.Features.Account.Types (UserAuth(..), UserID, inUserObj)
import Conduit.Identity.Auth (AuthTokenGen (mkAuthToken))
import Conduit.Identity.Password (HashedPassword(..), UnsafePassword(..), testPassword)
import Conduit.Validation (NotBlank(..), parseJsonBody, (<!<))
import Data.Aeson (FromJSON(..), withObject, (.:))
import Database.Esqueleto.Experimental (Entity(..), from, selectOne, val, (==.))
import Database.Esqueleto.Experimental.From (table)
import UnliftIO (MonadUnliftIO)
import Web.Scotty.Trans (ScottyT, json, post)

data LoginUserAction = LoginUserAction
  { LoginUserAction -> UnsafePassword
password :: UnsafePassword
  , LoginUserAction -> Text
email    :: Text
  }

instance FromJSON LoginUserAction where
  parseJSON :: Value -> Parser LoginUserAction
parseJSON = String
-> (Object -> Parser LoginUserAction)
-> Value
-> Parser LoginUserAction
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"LoginUserAction" ((Object -> Parser LoginUserAction)
 -> Value -> Parser LoginUserAction)
-> (Object -> Parser LoginUserAction)
-> Value
-> Parser LoginUserAction
forall a b. (a -> b) -> a -> b
$ \Object
v -> UnsafePassword -> Text -> LoginUserAction
LoginUserAction
    (UnsafePassword -> Text -> LoginUserAction)
-> Parser UnsafePassword -> Parser (Text -> LoginUserAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Assurance NotBlank UnsafePassword)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"password" Parser (Assurance NotBlank UnsafePassword)
-> NotBlank -> Parser UnsafePassword
forall prop on. Parser (Assurance prop on) -> prop -> Parser on
<!< NotBlank
NotBlank
    Parser (Text -> LoginUserAction)
-> Parser Text -> Parser LoginUserAction
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser (Assurance NotBlank Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"email"    Parser (Assurance NotBlank Text) -> NotBlank -> Parser Text
forall prop on. Parser (Assurance prop on) -> prop -> Parser on
<!< NotBlank
NotBlank

handleUserLogin :: ScottyT AppM ()
handleUserLogin :: ScottyT AppM ()
handleUserLogin = RoutePattern -> ActionT AppM () -> ScottyT AppM ()
forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
post RoutePattern
"/api/users/login" do
  LoginUserAction
action <- ActionT AppM LoginUserAction
forall a (m :: * -> *).
(MonadUnliftIO m, FromJSON a) =>
ActionT m a
parseJsonBody
  UserAuth
userAuth <- AppM (Either AccountError UserAuth) -> ActionT AppM UserAuth
forall e a. FeatureError e => AppM (Either e a) -> ActionT AppM a
runService (AppM (Either AccountError UserAuth) -> ActionT AppM UserAuth)
-> AppM (Either AccountError UserAuth) -> ActionT AppM UserAuth
forall a b. (a -> b) -> a -> b
$ LoginUserAction -> AppM (Either AccountError UserAuth)
forall (m :: * -> *).
(MonadIO m, AcquireUser m, AuthTokenGen m) =>
LoginUserAction -> m (Either AccountError UserAuth)
tryLoginUser LoginUserAction
action
  InObj UserAuth -> ActionT AppM ()
forall a (m :: * -> *). (ToJSON a, MonadIO m) => a -> ActionT m ()
json (InObj UserAuth -> ActionT AppM ())
-> InObj UserAuth -> ActionT AppM ()
forall a b. (a -> b) -> a -> b
$ UserAuth -> InObj UserAuth
forall obj. obj -> InObj obj
inUserObj UserAuth
userAuth

tryLoginUser :: (MonadIO m, AcquireUser m, AuthTokenGen m) => LoginUserAction -> m (Either AccountError UserAuth)
tryLoginUser :: forall (m :: * -> *).
(MonadIO m, AcquireUser m, AuthTokenGen m) =>
LoginUserAction -> m (Either AccountError UserAuth)
tryLoginUser LoginUserAction {Text
UnsafePassword
$sel:password:LoginUserAction :: LoginUserAction -> UnsafePassword
$sel:email:LoginUserAction :: LoginUserAction -> Text
password :: UnsafePassword
email :: Text
..} = ExceptT AccountError m UserAuth -> m (Either AccountError UserAuth)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
  UserInfo
user <- m (Either AccountError UserInfo) -> ExceptT AccountError m UserInfo
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AccountError UserInfo)
 -> ExceptT AccountError m UserInfo)
-> m (Either AccountError UserInfo)
-> ExceptT AccountError m UserInfo
forall a b. (a -> b) -> a -> b
$ Text -> m (Either AccountError UserInfo)
forall (m :: * -> *).
AcquireUser m =>
Text -> m (Either AccountError UserInfo)
findUserByEmail Text
email

  let isValidPassword :: Bool
isValidPassword = UnsafePassword -> HashedPassword -> Bool
testPassword UnsafePassword
password UserInfo
user.pass

  Either AccountError UserAuth
either' <- m (Either AccountError UserAuth)
-> ExceptT AccountError m (Either AccountError UserAuth)
forall (m :: * -> *) a. Monad m => m a -> ExceptT AccountError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Either AccountError UserAuth)
 -> ExceptT AccountError m (Either AccountError UserAuth))
-> m (Either AccountError UserAuth)
-> ExceptT AccountError m (Either AccountError UserAuth)
forall a b. (a -> b) -> a -> b
$ if Bool
isValidPassword
    then UserAuth -> Either AccountError UserAuth
forall a b. b -> Either a b
Right (UserAuth -> Either AccountError UserAuth)
-> m UserAuth -> m (Either AccountError UserAuth)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UserInfo -> m UserAuth
forall (m :: * -> *). AuthTokenGen m => UserInfo -> m UserAuth
createUserAuth UserInfo
user
    else Either AccountError UserAuth -> m (Either AccountError UserAuth)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either AccountError UserAuth -> m (Either AccountError UserAuth))
-> (AccountError -> Either AccountError UserAuth)
-> AccountError
-> m (Either AccountError UserAuth)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AccountError -> Either AccountError UserAuth
forall a b. a -> Either a b
Left (AccountError -> m (Either AccountError UserAuth))
-> AccountError -> m (Either AccountError UserAuth)
forall a b. (a -> b) -> a -> b
$ AccountError
BadLoginCredsEx

  m (Either AccountError UserAuth) -> ExceptT AccountError m UserAuth
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AccountError UserAuth)
 -> ExceptT AccountError m UserAuth)
-> m (Either AccountError UserAuth)
-> ExceptT AccountError m UserAuth
forall a b. (a -> b) -> a -> b
$ Either AccountError UserAuth -> m (Either AccountError UserAuth)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either AccountError UserAuth
either'

createUserAuth :: (AuthTokenGen m) => UserInfo -> m UserAuth
createUserAuth :: forall (m :: * -> *). AuthTokenGen m => UserInfo -> m UserAuth
createUserAuth UserInfo
userInfo = do
  Text
token <- UserID -> m Text
forall (m :: * -> *). AuthTokenGen m => UserID -> m Text
mkAuthToken UserInfo
userInfo.userID

  UserAuth -> m UserAuth
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserAuth
    { $sel:token:UserAuth :: Text
token = Text
token
    , $sel:email:UserAuth :: Text
email = UserInfo
userInfo.email
    , $sel:name:UserAuth :: Text
name  = UserInfo
userInfo.name
    , $sel:bio:UserAuth :: Maybe Text
bio   = UserInfo
userInfo.bio
    , $sel:image:UserAuth :: Text
image = UserInfo
userInfo.image
    }

class (Monad m) => AcquireUser m where
  findUserByEmail :: Text -> m (Either AccountError UserInfo)

data UserInfo = UserInfo
  { UserInfo -> UserID
userID    :: !UserID
  , UserInfo -> Text
name  :: !Text
  , UserInfo -> Text
email :: !Text
  , UserInfo -> HashedPassword
pass  :: !HashedPassword
  , UserInfo -> Maybe Text
bio   :: !(Maybe Text)
  , UserInfo -> Text
image :: !Text
  }

instance (Monad m, MonadUnliftIO m, MonadDB m) => AcquireUser m where
  findUserByEmail :: Text -> m (Either AccountError UserInfo)
  findUserByEmail :: Text -> m (Either AccountError UserInfo)
findUserByEmail Text
email = AccountError
-> (Entity User -> UserInfo)
-> Either DBError (Maybe (Entity User))
-> Either AccountError UserInfo
forall e a b.
FeatureError e =>
e -> (a -> b) -> Either DBError (Maybe a) -> Either e b
mapMaybeDBResult AccountError
UserNotFoundEx Entity User -> UserInfo
mkUserInfo (Either DBError (Maybe (Entity User))
 -> Either AccountError UserInfo)
-> m (Either DBError (Maybe (Entity User)))
-> m (Either AccountError UserInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlPersistT m (Maybe (Entity User))
-> m (Either DBError (Maybe (Entity User)))
forall a. SqlPersistT m a -> m (Either DBError a)
forall (m :: * -> *) a.
MonadDB m =>
SqlPersistT m a -> m (Either DBError a)
runDB do
    SqlQuery (SqlExpr (Entity User))
-> SqlPersistT m (Maybe (Entity User))
forall a r (m :: * -> *) backend.
(SqlSelect a r, MonadIO m, SqlBackendCanRead backend) =>
SqlQuery a -> ReaderT backend m (Maybe r)
selectOne (SqlQuery (SqlExpr (Entity User))
 -> SqlPersistT m (Maybe (Entity User)))
-> SqlQuery (SqlExpr (Entity User))
-> SqlPersistT m (Maybe (Entity User))
forall a b. (a -> b) -> a -> b
$ do
      From (SqlExpr (Entity User)) -> SqlQuery (SqlExpr (Entity User))
forall a a'. ToFrom a a' => a -> SqlQuery a'
from From (SqlExpr (Entity User))
forall ent. PersistEntity ent => From (SqlExpr (Entity ent))
table SqlQuery (SqlExpr (Entity User))
-> (SqlExpr (Entity User) -> SqlExpr (Value Bool))
-> SqlQuery (SqlExpr (Entity User))
forall a. SqlQuery a -> (a -> SqlExpr (Value Bool)) -> SqlQuery a
`suchThat` \SqlExpr (Entity User)
u ->
         SqlExpr (Entity User)
u.email SqlExpr (Value Text)
-> SqlExpr (Value Text) -> SqlExpr (Value Bool)
forall typ.
PersistField typ =>
SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)
==. Text -> SqlExpr (Value Text)
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val Text
email

mkUserInfo :: Entity User -> UserInfo
mkUserInfo :: Entity User -> UserInfo
mkUserInfo (Entity Key User
userID User
user) = UserInfo
  { $sel:userID:UserInfo :: UserID
userID = Key User -> UserID
forall t id. SqlKey t id => Key t -> id
sqlKey2ID Key User
userID
  , $sel:name:UserInfo :: Text
name  = User
user.userUsername
  , $sel:pass:UserInfo :: HashedPassword
pass  = User
user.userPassword Text -> (Text -> HashedPassword) -> HashedPassword
forall a b. a -> (a -> b) -> b
& Text -> HashedPassword
HashedPassword
  , $sel:email:UserInfo :: Text
email = User
user.userEmail
  , $sel:bio:UserInfo :: Maybe Text
bio   = User
user.userBio
  , $sel:image:UserInfo :: Text
image = User
user.userImage
  }