{-# LANGUAGE UndecidableInstances #-}

module Conduit.Features.Account.User.UpdateUser where

import Prelude hiding (put, pass)
import Conduit.App.Monad (AppM, runService)
import Conduit.DB.Core (MonadDB (..), mapDBError)
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.Features.Account.User.GetUser (AcquireUser, getUser)
import Conduit.Identity.Auth (AuthTokenGen (..), AuthedUser (..), withAuth)
import Conduit.Identity.Password (HashedPassword (..), PasswordGen (..), UnsafePassword (..))
import Conduit.Validation (NotBlank (..), parseJsonBody, (<?!<))
import Data.Aeson (FromJSON (..), withObject, (.:?))
import Database.Esqueleto.Experimental (set, update, val, valkey, where_, (=.), (==.))
import UnliftIO (MonadUnliftIO)
import Web.Scotty.Trans (ScottyT, json, put)

data UpdateUserAction = UpdateUserAction
  { UpdateUserAction -> Maybe Text
username :: Maybe Text
  , UpdateUserAction -> Maybe UnsafePassword
password :: Maybe UnsafePassword
  , UpdateUserAction -> Maybe Text
email    :: Maybe Text
  , UpdateUserAction -> Maybe Text
bio      :: Maybe Text
  , UpdateUserAction -> Maybe Text
image    :: Maybe Text
  }

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

handleUpdateUser :: ScottyT AppM ()
handleUpdateUser :: ScottyT AppM ()
handleUpdateUser = RoutePattern -> ActionT AppM () -> ScottyT AppM ()
forall (m :: * -> *).
MonadUnliftIO m =>
RoutePattern -> ActionT m () -> ScottyT m ()
put RoutePattern
"/api/user" (ActionT AppM () -> ScottyT AppM ())
-> ActionT AppM () -> ScottyT AppM ()
forall a b. (a -> b) -> a -> b
$ (AuthedUser -> ActionT AppM ()) -> ActionT AppM ()
forall (m :: * -> *) c.
(MonadIO m, MonadReader c m, Has JWTInfo c m) =>
(AuthedUser -> ActionT m ()) -> ActionT m ()
withAuth \AuthedUser
user -> do
  UpdateUserAction
action <- ActionT AppM UpdateUserAction
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
$ AuthedUser
-> UpdateUserAction -> AppM (Either AccountError UserAuth)
forall (m :: * -> *).
(PasswordGen m, AuthTokenGen m, AcquireUser m, ReadUsers m,
 UpdateUser m) =>
AuthedUser -> UpdateUserAction -> m (Either AccountError UserAuth)
updateUser AuthedUser
user UpdateUserAction
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

updateUser :: (PasswordGen m, AuthTokenGen m, AcquireUser m, ReadUsers m, UpdateUser m) => AuthedUser -> UpdateUserAction -> m (Either AccountError UserAuth)
updateUser :: forall (m :: * -> *).
(PasswordGen m, AuthTokenGen m, AcquireUser m, ReadUsers m,
 UpdateUser m) =>
AuthedUser -> UpdateUserAction -> m (Either AccountError UserAuth)
updateUser user :: AuthedUser
user@AuthedUser {Text
UserID
authedToken :: Text
authedUserID :: UserID
$sel:authedToken:AuthedUser :: AuthedUser -> Text
$sel:authedUserID:AuthedUser :: AuthedUser -> UserID
..} action :: UpdateUserAction
action@UpdateUserAction {Maybe Text
Maybe UnsafePassword
$sel:username:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:password:UpdateUserAction :: UpdateUserAction -> Maybe UnsafePassword
$sel:email:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:bio:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:image:UpdateUserAction :: UpdateUserAction -> Maybe Text
username :: Maybe Text
password :: Maybe UnsafePassword
email :: Maybe Text
bio :: Maybe Text
image :: Maybe 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
$ Maybe Text -> Maybe Text -> m (Either AccountError ())
forall (m :: * -> *).
ReadUsers m =>
Maybe Text -> Maybe Text -> m (Either AccountError ())
ensureUserCredsUnique Maybe Text
username Maybe Text
email
  Maybe HashedPassword
maybeNewPW <- (UnsafePassword -> ExceptT AccountError m HashedPassword)
-> Maybe UnsafePassword
-> ExceptT AccountError m (Maybe HashedPassword)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM (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)
-> (UnsafePassword -> m HashedPassword)
-> UnsafePassword
-> ExceptT AccountError m HashedPassword
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnsafePassword -> m HashedPassword
forall (m :: * -> *).
PasswordGen m =>
UnsafePassword -> m HashedPassword
hashPassword) Maybe UnsafePassword
password
  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
$ UserID -> ToUpdate -> m (Either AccountError ())
forall (m :: * -> *).
UpdateUser m =>
UserID -> ToUpdate -> m (Either AccountError ())
updateUserByID UserID
authedUserID (ToUpdate -> m (Either AccountError ()))
-> ToUpdate -> m (Either AccountError ())
forall a b. (a -> b) -> a -> b
$ UpdateUserAction -> Maybe HashedPassword -> ToUpdate
mkToUpdate UpdateUserAction
action Maybe HashedPassword
maybeNewPW
  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
$ AuthedUser -> m (Either AccountError UserAuth)
forall (m :: * -> *).
AcquireUser m =>
AuthedUser -> m (Either AccountError UserAuth)
getUser AuthedUser
user

mkToUpdate :: UpdateUserAction -> Maybe HashedPassword -> ToUpdate
mkToUpdate :: UpdateUserAction -> Maybe HashedPassword -> ToUpdate
mkToUpdate UpdateUserAction {Maybe Text
Maybe UnsafePassword
$sel:username:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:password:UpdateUserAction :: UpdateUserAction -> Maybe UnsafePassword
$sel:email:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:bio:UpdateUserAction :: UpdateUserAction -> Maybe Text
$sel:image:UpdateUserAction :: UpdateUserAction -> Maybe Text
username :: Maybe Text
password :: Maybe UnsafePassword
email :: Maybe Text
bio :: Maybe Text
image :: Maybe Text
..} Maybe HashedPassword
hashed = Maybe Text
-> Maybe HashedPassword
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ToUpdate
ToUpdate Maybe Text
username Maybe HashedPassword
hashed Maybe Text
email Maybe Text
bio Maybe Text
image

class (Monad m) => UpdateUser m where
  updateUserByID :: UserID -> ToUpdate -> m (Either AccountError ())

data ToUpdate = ToUpdate
  { ToUpdate -> Maybe Text
name  :: Maybe Text
  , ToUpdate -> Maybe HashedPassword
pass  :: Maybe HashedPassword
  , ToUpdate -> Maybe Text
email :: Maybe Text
  , ToUpdate -> Maybe Text
bio   :: Maybe Text
  , ToUpdate -> Maybe Text
image :: Maybe Text
  }

instance (Monad m, MonadUnliftIO m, MonadDB m) => UpdateUser m where
  updateUserByID :: UserID -> ToUpdate -> m (Either AccountError ())
  updateUserByID :: UserID -> ToUpdate -> m (Either AccountError ())
updateUserByID UserID
userID ToUpdate {Maybe Text
Maybe HashedPassword
$sel:name:ToUpdate :: ToUpdate -> Maybe Text
$sel:pass:ToUpdate :: ToUpdate -> Maybe HashedPassword
$sel:email:ToUpdate :: ToUpdate -> Maybe Text
$sel:bio:ToUpdate :: ToUpdate -> Maybe Text
$sel:image:ToUpdate :: ToUpdate -> Maybe Text
name :: Maybe Text
pass :: Maybe HashedPassword
email :: Maybe Text
bio :: Maybe Text
image :: Maybe Text
..} = Either DBError () -> Either AccountError ()
forall e a. FeatureError e => Either DBError a -> Either e a
mapDBError (Either DBError () -> Either AccountError ())
-> m (Either DBError ()) -> m (Either AccountError ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SqlPersistT m () -> m (Either DBError ())
forall a. SqlPersistT m a -> m (Either DBError a)
forall (m :: * -> *) a.
MonadDB m =>
SqlPersistT m a -> m (Either DBError a)
runDB do
    forall (m :: * -> *) val backend.
(MonadIO m, PersistEntity val,
 BackendCompatible SqlBackend (PersistEntityBackend val),
 SqlBackendCanWrite backend) =>
(SqlExpr (Entity val) -> SqlQuery ()) -> ReaderT backend m ()
update @_ @User ((SqlExpr (Entity User) -> SqlQuery ()) -> SqlPersistT m ())
-> (SqlExpr (Entity User) -> SqlQuery ()) -> SqlPersistT m ()
forall a b. (a -> b) -> a -> b
$ \SqlExpr (Entity User)
u -> do
      Maybe Text -> (Text -> SqlQuery ()) -> SqlQuery ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
name  \Text
new -> SqlExpr (Entity User)
-> [SqlExpr (Entity User) -> SqlExpr Update] -> SqlQuery ()
forall val.
PersistEntity val =>
SqlExpr (Entity val)
-> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()
set SqlExpr (Entity User)
u [ EntityField User Text
#username EntityField User Text
-> SqlExpr (Value Text) -> SqlExpr (Entity User) -> SqlExpr Update
forall val typ.
(PersistEntity val, PersistField typ) =>
EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Entity val) -> SqlExpr Update
=. Text -> SqlExpr (Value Text)
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val Text
new           ]
      Maybe HashedPassword
-> (HashedPassword -> SqlQuery ()) -> SqlQuery ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe HashedPassword
pass  \HashedPassword
new -> SqlExpr (Entity User)
-> [SqlExpr (Entity User) -> SqlExpr Update] -> SqlQuery ()
forall val.
PersistEntity val =>
SqlExpr (Entity val)
-> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()
set SqlExpr (Entity User)
u [ EntityField User Text
#password EntityField User Text
-> SqlExpr (Value Text) -> SqlExpr (Entity User) -> SqlExpr Update
forall val typ.
(PersistEntity val, PersistField typ) =>
EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Entity val) -> SqlExpr Update
=. Text -> SqlExpr (Value Text)
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val HashedPassword
new.getHashed ]
      Maybe Text -> (Text -> SqlQuery ()) -> SqlQuery ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
email \Text
new -> SqlExpr (Entity User)
-> [SqlExpr (Entity User) -> SqlExpr Update] -> SqlQuery ()
forall val.
PersistEntity val =>
SqlExpr (Entity val)
-> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()
set SqlExpr (Entity User)
u [ EntityField User Text
#email    EntityField User Text
-> SqlExpr (Value Text) -> SqlExpr (Entity User) -> SqlExpr Update
forall val typ.
(PersistEntity val, PersistField typ) =>
EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Entity val) -> SqlExpr Update
=. Text -> SqlExpr (Value Text)
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val Text
new           ]
      Maybe Text -> (Text -> SqlQuery ()) -> SqlQuery ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
bio   \Text
new -> SqlExpr (Entity User)
-> [SqlExpr (Entity User) -> SqlExpr Update] -> SqlQuery ()
forall val.
PersistEntity val =>
SqlExpr (Entity val)
-> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()
set SqlExpr (Entity User)
u [ EntityField User (Maybe Text)
#bio      EntityField User (Maybe Text)
-> SqlExpr (Value (Maybe Text))
-> SqlExpr (Entity User)
-> SqlExpr Update
forall val typ.
(PersistEntity val, PersistField typ) =>
EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Entity val) -> SqlExpr Update
=. Maybe Text -> SqlExpr (Value (Maybe Text))
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
new)    ]
      Maybe Text -> (Text -> SqlQuery ()) -> SqlQuery ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe Text
image \Text
new -> SqlExpr (Entity User)
-> [SqlExpr (Entity User) -> SqlExpr Update] -> SqlQuery ()
forall val.
PersistEntity val =>
SqlExpr (Entity val)
-> [SqlExpr (Entity val) -> SqlExpr Update] -> SqlQuery ()
set SqlExpr (Entity User)
u [ EntityField User Text
#image    EntityField User Text
-> SqlExpr (Value Text) -> SqlExpr (Entity User) -> SqlExpr Update
forall val typ.
(PersistEntity val, PersistField typ) =>
EntityField val typ
-> SqlExpr (Value typ) -> SqlExpr (Entity val) -> SqlExpr Update
=. Text -> SqlExpr (Value Text)
forall typ. PersistField typ => typ -> SqlExpr (Value typ)
val Text
new           ]
      SqlExpr (Value Bool) -> SqlQuery ()
where_ (SqlExpr (Entity User)
u.id SqlExpr (Value (Key User))
-> SqlExpr (Value (Key User)) -> SqlExpr (Value Bool)
forall typ.
PersistField typ =>
SqlExpr (Value typ) -> SqlExpr (Value typ) -> SqlExpr (Value Bool)
==. Int64 -> SqlExpr (Value (Key User))
forall entity.
(ToBackendKey SqlBackend entity, PersistField (Key entity)) =>
Int64 -> SqlExpr (Value (Key entity))
valkey UserID
userID.unID)