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