{-|
Module      : Gargantext.Database.Action.User.New
Description :
Copyright   : (c) CNRS, 2017-Present
License     : AGPL + CECILL v3
Maintainer  : team@gargantext.org
Stability   : experimental
Portability : POSIX
-}


{-# OPTIONS_GHC -fno-warn-deprecations #-}


module Gargantext.Database.Action.User.New
  (
    -- * Creating users
    newUser
  , newUsers
    -- * Helper functions
  , guessUserName
    -- * Internal types and functions for testing
  , new_user
  , mkNewUser
  )
  where

import Control.Lens (view)
import Control.Monad.Random
import Data.List.NonEmpty qualified as NE
import Data.Text (splitOn)
import Data.Text qualified as Text
import Gargantext.Core.Config (HasConfig(..))
import Gargantext.Core.Config.Mail (MailConfig)
import Gargantext.Core.Mail
import Gargantext.Core.Mail.Types (HasMail, mailSettings)
import Gargantext.Core.Types.Individu
import Gargantext.Database.Action.Flow (getOrMkRoot)
import Gargantext.Database.Admin.Types.Node
import Gargantext.Database.Prelude
import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
import Gargantext.Database.Query.Table.User
import Gargantext.Prelude
import Gargantext.Prelude.Crypto.Pass.User (gargPass)

------------------------------------------------------------------------
-- | Creates a new 'User' from the input 'EmailAddress', which needs to
-- be valid (i.e. a valid username needs to be inferred via 'guessUsername').
newUser :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
        => EmailAddress
        -> m UserId
newUser emailAddress = do
  cfg <- view mailSettings
  pwd <- gargPass
  let nur = mkNewUser emailAddress (GargPassword pwd)
  new_user_id <- new_user nur
  withNotification (SendEmail True) cfg Invitation $ pure (new_user_id, nur)

------------------------------------------------------------------------
-- | A DB-specific action to create a single user.
-- This is an internal function and as such it /doesn't/ send out any email
-- notification, and thus lives in the 'DbCmd' effect stack. You may want to
-- use 'newUser' instead for standard Gargantext code.
new_user :: (HasNodeError err)
         => NewUser GargPassword
         -> DBCmdWithEnv env err UserId
new_user rq = do
  (uid NE.:| _) <- new_users (rq NE.:| [])
  pure uid

------------------------------------------------------------------------
-- | A DB-specific action to bulk-create users.
-- This is an internal function and as such it /doesn't/ send out any email
-- notification, and thus lives in the 'DbCmd' effect stack. You may want to
-- use 'newUsers' instead for standard Gargantext code.
new_users :: (HasNodeError err)
          => NonEmpty (NewUser GargPassword)
          -- ^ A list of users to create.
          -> DBCmdWithEnv env err (NonEmpty UserId)
new_users us = do
  us'   <- liftBase        $ mapM toUserHash us
  cfg   <- view hasConfig
  runDBTx $ do
    void  $ insertUsers      $ NE.map toUserWrite us'
    mapM (fmap fst . getOrMkRoot cfg) $ NE.map  (\u -> UserName   (_nu_username u)) us

------------------------------------------------------------------------
newUsers :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
         => NonEmpty EmailAddress
         -> m (NonEmpty UserId)
newUsers us = do
  config <- view $ mailSettings
  us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
  newUsers' config us'

------------------------------------------------------------------------
mkNewUser :: EmailAddress -> GargPassword -> NewUser GargPassword
mkNewUser emailAddress pass' =
  let  username = case guessUserName emailAddress of
        Just  (u', _m) -> u'
        Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
  in NewUser username (Text.toLower emailAddress) pass'

------------------------------------------------------------------------
-- | guessUserName
-- guess username and normalize it (Text.toLower)
guessUserName :: Text -> Maybe (Text,Text)
guessUserName n = case splitOn "@" n of
    [_u', ""] -> Nothing
    [u', m']  -> Just (Text.toLower u', m')
    _       -> Nothing

------------------------------------------------------------------------
newUsers' :: (HasNodeError err)
         => MailConfig -> NonEmpty (NewUser GargPassword) -> DBCmdWithEnv env err (NonEmpty UserId)
newUsers' mcfg us = do
  us' <- liftBase         $ mapM toUserHash  us
  cfg <- view hasConfig
  urs <- runDBTx $ do
    void $ insertUsers      $ NE.map  toUserWrite us'
    mapM (fmap fst . getOrMkRoot cfg) $ map  (\u -> UserName   (_nu_username u)) us
  _   <- mapM (\u -> mail mcfg (Invitation u)) us
  -- printDebug "newUsers'" us
  pure urs

------------------------------------------------------------------------
-- | Updates a user's password, notifying the user via email, if necessary.
updateUser :: HasNodeError err
            => SendEmail -> MailConfig -> NewUser GargPassword -> DBCmdExtra err Int64
updateUser (SendEmail send) cfg u = do
  u' <- liftBase     $ toUserHash   u
  n  <- runDBTx $ updateUserDB $ toUserWrite  u'
  when send $ mail cfg (PassUpdate u)
  pure n

------------------------------------------------------------------------
_updateUsersPassword :: (IsDBCmdExtra env err m, MonadRandom m, HasNodeError err, HasMail env)
         => [EmailAddress] -> m Int64
_updateUsersPassword us = do
  us' <- mapM (\ea -> mkNewUser ea . GargPassword <$> gargPass) us
  config <- view $ mailSettings
  _ <- mapM (\u -> updateUser (SendEmail True) config u) us'
  pure 1

------------------------------------------------------------------------
_rmUser :: HasNodeError err => User -> DBUpdate err Int64
_rmUser (UserName un) = deleteUsers [un]
_rmUser _ = nodeError NotImplYet

------------------------------------------------------------------------
-- TODO
_rmUsers :: HasNodeError err => [User] -> DBCmd err Int64
_rmUsers [] = pure 0
_rmUsers _  = undefined
