{-# LANGUAGE UndecidableInstances #-}

module Conduit.Features.Account.User.RegisterUser where

import Prelude hiding (pass)
import Conduit.App.Monad (AppM, runService)
import Conduit.DB.Core (MonadDB(..), mapDBResult, sqlKey2ID)
import Conduit.Features.Account.Common.EnsureUserCredsUnique (ReadUsers, ensureUserCredsUnique)
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(..))
import Conduit.Identity.Password (HashedPassword(..), PasswordGen(..), UnsafePassword(..))
import Conduit.Validation (NotBlank(..), parseJsonBody, (<!<))
import Data.Aeson (FromJSON(..), withObject, (.:))
import Database.Esqueleto.Experimental (insert)
import Network.HTTP.Types (status201)
import UnliftIO (MonadUnliftIO)
import Web.Scotty.Trans (ScottyT, json, post, status)

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

instance FromJSON RegisterUserAction where
  parseJSON :: Value -> Parser RegisterUserAction
parseJSON = String
-> (Object -> Parser RegisterUserAction)
-> Value
-> Parser RegisterUserAction
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RegisterUserAction" ((Object -> Parser RegisterUserAction)
 -> Value -> Parser RegisterUserAction)
-> (Object -> Parser RegisterUserAction)
-> Value
-> Parser RegisterUserAction
forall a b. (a -> b) -> a -> b
$ \Object
v -> Text -> UnsafePassword -> Text -> RegisterUserAction
RegisterUserAction
    (Text -> UnsafePassword -> Text -> RegisterUserAction)
-> Parser Text
-> Parser (UnsafePassword -> Text -> RegisterUserAction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser (Assurance NotBlank Text)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"username"  Parser (Assurance NotBlank Text) -> NotBlank -> Parser Text
forall prop on. Parser (Assurance prop on) -> prop -> Parser on
<!< NotBlank
NotBlank
    Parser (UnsafePassword -> Text -> RegisterUserAction)
-> Parser UnsafePassword -> Parser (Text -> RegisterUserAction)
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 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 -> RegisterUserAction)
-> Parser Text -> Parser RegisterUserAction
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

handleUserRegistration :: ScottyT AppM ()
handleUserRegistration :: ScottyT AppM ()
handleUserRegistration = RoutePattern -> ActionT AppM () -> ScottyT AppM ()
forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
post RoutePattern
"/api/users" do
  RegisterUserAction
action <- ActionT AppM RegisterUserAction
forall a (m :: * -> *).
(MonadUnliftIO m, FromJSON a) =>
ActionT m a
parseJsonBody
  UserAuth
user <- 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
$ RegisterUserAction -> AppM (Either AccountError UserAuth)
forall (m :: * -> *).
(PasswordGen m, CreateUser m, ReadUsers m, AuthTokenGen m) =>
RegisterUserAction -> m (Either AccountError UserAuth)
registerUser RegisterUserAction
action
  Status -> ActionT AppM ()
forall (m :: * -> *). MonadIO m => Status -> ActionT m ()
status Status
status201
  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
user

defaultImage :: Text
defaultImage :: Text
defaultImage = Text
"https://api.realworld.io/images/smiley-cyrus.jpeg"

registerUser :: (PasswordGen m, CreateUser m, ReadUsers m, AuthTokenGen m) => RegisterUserAction -> m (Either AccountError UserAuth)
registerUser :: forall (m :: * -> *).
(PasswordGen m, CreateUser m, ReadUsers m, AuthTokenGen m) =>
RegisterUserAction -> m (Either AccountError UserAuth)
registerUser RegisterUserAction {Text
UnsafePassword
$sel:username:RegisterUserAction :: RegisterUserAction -> Text
$sel:password:RegisterUserAction :: RegisterUserAction -> UnsafePassword
$sel:email:RegisterUserAction :: RegisterUserAction -> Text
username :: 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
  m (Either AccountError ()) -> ExceptT AccountError m ()
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AccountError ()) -> ExceptT AccountError m ())
-> m (Either AccountError ()) -> ExceptT AccountError m ()
forall a b. (a -> b) -> a -> b
$ Name -> Name -> m (Either AccountError ())
forall (m :: * -> *).
ReadUsers m =>
Name -> Name -> m (Either AccountError ())
ensureUserCredsUnique (Text -> Name
forall a. a -> Maybe a
Just Text
username) (Text -> Name
forall a. a -> Maybe a
Just Text
email)

  HashedPassword
hashedPass <- m HashedPassword -> ExceptT AccountError m HashedPassword
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 HashedPassword -> ExceptT AccountError m HashedPassword)
-> m HashedPassword -> ExceptT AccountError m HashedPassword
forall a b. (a -> b) -> a -> b
$ UnsafePassword -> m HashedPassword
forall (m :: * -> *).
PasswordGen m =>
UnsafePassword -> m HashedPassword
hashPassword UnsafePassword
password

  UserID
userID <- m (Either AccountError UserID) -> ExceptT AccountError m UserID
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either AccountError UserID) -> ExceptT AccountError m UserID)
-> m (Either AccountError UserID) -> ExceptT AccountError m UserID
forall a b. (a -> b) -> a -> b
$ UserInfo -> m (Either AccountError UserID)
forall (m :: * -> *).
CreateUser m =>
UserInfo -> m (Either AccountError UserID)
insertUser UserInfo
    { $sel:name:UserInfo :: Text
name  = Text
username
    , $sel:pass:UserInfo :: HashedPassword
pass  = HashedPassword
hashedPass
    , $sel:email:UserInfo :: Text
email = Text
email
    }

  Text
token <- m Text -> ExceptT AccountError m Text
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 Text -> ExceptT AccountError m Text)
-> m Text -> ExceptT AccountError m Text
forall a b. (a -> b) -> a -> b
$ UserID -> m Text
forall (m :: * -> *). AuthTokenGen m => UserID -> m Text
mkAuthToken UserID
userID

  UserAuth -> ExceptT AccountError m UserAuth
forall a. a -> ExceptT AccountError m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UserAuth
    { $sel:token:UserAuth :: Text
token = Text
token
    , $sel:name:UserAuth :: Text
name  = Text
username
    , $sel:email:UserAuth :: Text
email = Text
email
    , $sel:bio:UserAuth :: Name
bio   = Name
forall a. Maybe a
Nothing
    , $sel:image:UserAuth :: Text
image = Text
defaultImage
    }

class (Monad m) => CreateUser m where
  insertUser :: UserInfo -> m (Either AccountError UserID)

data UserInfo = UserInfo
  { UserInfo -> Text
name  :: !Text
  , UserInfo -> HashedPassword
pass  :: !HashedPassword
  , UserInfo -> Text
email :: !Text
  }

instance (Monad m, MonadDB m, MonadUnliftIO m) => CreateUser m where
  insertUser :: UserInfo -> m (Either AccountError UserID)
  insertUser :: UserInfo -> m (Either AccountError UserID)
insertUser UserInfo {Text
HashedPassword
$sel:name:UserInfo :: UserInfo -> Text
$sel:pass:UserInfo :: UserInfo -> HashedPassword
$sel:email:UserInfo :: UserInfo -> Text
name :: Text
pass :: HashedPassword
email :: Text
..} = (Key User -> UserID)
-> Either DBError (Key User) -> Either AccountError UserID
forall e a b.
FeatureError e =>
(a -> b) -> Either DBError a -> Either e b
mapDBResult Key User -> UserID
forall t id. SqlKey t id => Key t -> id
sqlKey2ID (Either DBError (Key User) -> Either AccountError UserID)
-> m (Either DBError (Key User)) -> m (Either AccountError UserID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlPersistT m (Key User) -> m (Either DBError (Key User))
forall a. SqlPersistT m a -> m (Either DBError a)
forall (m :: * -> *) a.
MonadDB m =>
SqlPersistT m a -> m (Either DBError a)
runDB do
    User -> SqlPersistT m (Key User)
forall backend record (m :: * -> *).
(PersistStoreWrite backend, MonadIO m,
 PersistRecordBackend record backend, SafeToInsert record) =>
record -> ReaderT backend m (Key record)
forall record (m :: * -> *).
(MonadIO m, PersistRecordBackend record SqlBackend,
 SafeToInsert record) =>
record -> ReaderT SqlBackend m (Key record)
insert (Text -> Text -> Text -> Name -> Text -> User
User Text
name HashedPassword
pass.getHashed Text
email Name
forall a. Monoid a => a
mempty Text
defaultImage)