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

module Gargantext.Database.Action.User.New
  where

import Control.Lens (view)
import Control.Monad.Random
import Data.Text (Text, splitOn)
import qualified Data.Text as Text
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.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)
import Gargantext.Prelude.Mail.Types (MailConfig)
------------------------------------------------------------------------
------------------------------------------------------------------------
newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
         => [EmailAddress] -> m Int64
newUsers :: [EmailAddress] -> m Int64
newUsers [EmailAddress]
us = do
  [NewUser GargPassword]
us' <- (EmailAddress -> m (NewUser GargPassword))
-> [EmailAddress] -> m [NewUser GargPassword]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM EmailAddress -> m (NewUser GargPassword)
forall (m :: * -> *).
MonadRandom m =>
EmailAddress -> m (NewUser GargPassword)
newUserQuick [EmailAddress]
us
  MailConfig
config <- Getting MailConfig env MailConfig -> m MailConfig
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Getting MailConfig env MailConfig -> m MailConfig)
-> Getting MailConfig env MailConfig -> m MailConfig
forall a b. (a -> b) -> a -> b
$ Getting MailConfig env MailConfig
forall env. HasMail env => Getter env MailConfig
mailSettings
  MailConfig -> [NewUser GargPassword] -> Cmd err Int64
forall err.
HasNodeError err =>
MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' MailConfig
config [NewUser GargPassword]
us'
------------------------------------------------------------------------
newUserQuick :: (MonadRandom m)
             => Text -> m (NewUser GargPassword)
newUserQuick :: EmailAddress -> m (NewUser GargPassword)
newUserQuick EmailAddress
n = do
  EmailAddress
pass <- m EmailAddress
forall (m :: * -> *). MonadRandom m => m EmailAddress
gargPass
  let u :: EmailAddress
u = case EmailAddress -> Maybe (EmailAddress, EmailAddress)
guessUserName EmailAddress
n of
        Just  (EmailAddress
u', EmailAddress
_m) -> EmailAddress
u'
        Maybe (EmailAddress, EmailAddress)
Nothing        -> EmailAddress -> EmailAddress
forall a. HasCallStack => EmailAddress -> a
panic EmailAddress
"[G.D.A.U.N.newUserQuick]: Email invalid"
  NewUser GargPassword -> m (NewUser GargPassword)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EmailAddress
-> EmailAddress -> GargPassword -> NewUser GargPassword
forall a. EmailAddress -> EmailAddress -> a -> NewUser a
NewUser EmailAddress
u EmailAddress
n (EmailAddress -> GargPassword
GargPassword EmailAddress
pass))

------------------------------------------------------------------------
-- | guessUserName
-- guess username and normalize it (Text.toLower)
guessUserName :: Text -> Maybe (Text,Text)
guessUserName :: EmailAddress -> Maybe (EmailAddress, EmailAddress)
guessUserName EmailAddress
n = case EmailAddress -> EmailAddress -> [EmailAddress]
splitOn EmailAddress
"@" EmailAddress
n of
    [EmailAddress
u',EmailAddress
m'] -> if EmailAddress
m' EmailAddress -> EmailAddress -> Bool
forall a. Eq a => a -> a -> Bool
/= EmailAddress
"" then (EmailAddress, EmailAddress) -> Maybe (EmailAddress, EmailAddress)
forall a. a -> Maybe a
Just (EmailAddress -> EmailAddress
Text.toLower EmailAddress
u',EmailAddress
m')
                           else Maybe (EmailAddress, EmailAddress)
forall a. Maybe a
Nothing
    [EmailAddress]
_       -> Maybe (EmailAddress, EmailAddress)
forall a. Maybe a
Nothing
------------------------------------------------------------------------
newUser' :: HasNodeError err
        => MailConfig -> NewUser GargPassword -> Cmd err Int64
newUser' :: MailConfig -> NewUser GargPassword -> Cmd err Int64
newUser' MailConfig
cfg NewUser GargPassword
u = MailConfig -> [NewUser GargPassword] -> Cmd err Int64
forall err.
HasNodeError err =>
MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' MailConfig
cfg [NewUser GargPassword
u]

newUsers' :: HasNodeError err
         => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' :: MailConfig -> [NewUser GargPassword] -> Cmd err Int64
newUsers' MailConfig
cfg [NewUser GargPassword]
us = do
  [NewUser HashPassword]
us' <- IO [NewUser HashPassword] -> m [NewUser HashPassword]
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase         (IO [NewUser HashPassword] -> m [NewUser HashPassword])
-> IO [NewUser HashPassword] -> m [NewUser HashPassword]
forall a b. (a -> b) -> a -> b
$ (NewUser GargPassword -> IO (NewUser HashPassword))
-> [NewUser GargPassword] -> IO [NewUser HashPassword]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NewUser GargPassword -> IO (NewUser HashPassword)
forall (m :: * -> *).
MonadIO m =>
NewUser GargPassword -> m (NewUser HashPassword)
toUserHash  [NewUser GargPassword]
us
  Int64
r   <- [UserWrite] -> Cmd err Int64
forall err. [UserWrite] -> Cmd err Int64
insertUsers      ([UserWrite] -> Cmd err Int64) -> [UserWrite] -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ (NewUser HashPassword -> UserWrite)
-> [NewUser HashPassword] -> [UserWrite]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map  NewUser HashPassword -> UserWrite
toUserWrite [NewUser HashPassword]
us'
  [(UserId, RootId)]
_   <- (User -> m (UserId, RootId)) -> [User] -> m [(UserId, RootId)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM User -> m (UserId, RootId)
forall err. HasNodeError err => User -> Cmd err (UserId, RootId)
getOrMkRoot ([User] -> m [(UserId, RootId)]) -> [User] -> m [(UserId, RootId)]
forall a b. (a -> b) -> a -> b
$ (NewUser GargPassword -> User) -> [NewUser GargPassword] -> [User]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map  (\NewUser GargPassword
u -> EmailAddress -> User
UserName   (NewUser GargPassword -> EmailAddress
forall a. NewUser a -> EmailAddress
_nu_username NewUser GargPassword
u)) [NewUser GargPassword]
us
  [()]
_   <- (NewUser GargPassword -> m ()) -> [NewUser GargPassword] -> m [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\NewUser GargPassword
u -> MailConfig -> MailModel -> m ()
forall env err (m :: * -> *).
CmdM env err m =>
MailConfig -> MailModel -> m ()
mail MailConfig
cfg (NewUser GargPassword -> MailModel
Invitation NewUser GargPassword
u)) [NewUser GargPassword]
us
  [Char] -> [NewUser GargPassword] -> m ()
forall a (m :: * -> *).
(Show a, MonadBase IO m) =>
[Char] -> a -> m ()
printDebug [Char]
"newUsers'" [NewUser GargPassword]
us
  Int64 -> m Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
r
------------------------------------------------------------------------

updateUser :: HasNodeError err
           => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
updateUser :: SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
updateUser (SendEmail Bool
send) MailConfig
cfg NewUser GargPassword
u = do
  NewUser HashPassword
u' <- IO (NewUser HashPassword) -> m (NewUser HashPassword)
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase     (IO (NewUser HashPassword) -> m (NewUser HashPassword))
-> IO (NewUser HashPassword) -> m (NewUser HashPassword)
forall a b. (a -> b) -> a -> b
$ NewUser GargPassword -> IO (NewUser HashPassword)
forall (m :: * -> *).
MonadIO m =>
NewUser GargPassword -> m (NewUser HashPassword)
toUserHash   NewUser GargPassword
u
  Int64
n  <- UserWrite -> Cmd err Int64
forall err. UserWrite -> Cmd err Int64
updateUserDB (UserWrite -> Cmd err Int64) -> UserWrite -> Cmd err Int64
forall a b. (a -> b) -> a -> b
$ NewUser HashPassword -> UserWrite
toUserWrite  NewUser HashPassword
u'
  ()
_  <- case Bool
send of
     Bool
True  -> MailConfig -> MailModel -> m ()
forall env err (m :: * -> *).
CmdM env err m =>
MailConfig -> MailModel -> m ()
mail MailConfig
cfg (NewUser GargPassword -> MailModel
PassUpdate NewUser GargPassword
u)
     Bool
False -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Int64 -> m Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
n

------------------------------------------------------------------------
rmUser :: HasNodeError err => User -> Cmd err Int64
rmUser :: User -> Cmd err Int64
rmUser (UserName EmailAddress
un) = [EmailAddress] -> Cmd err Int64
forall err. [EmailAddress] -> Cmd err Int64
deleteUsers [EmailAddress
un]
rmUser User
_ = NodeError -> m Int64
forall e (m :: * -> *) a.
(MonadError e m, HasNodeError e) =>
NodeError -> m a
nodeError NodeError
NotImplYet

-- TODO
rmUsers :: HasNodeError err => [User] -> Cmd err Int64
rmUsers :: [User] -> Cmd err Int64
rmUsers [] = Int64 -> m Int64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int64
0
rmUsers [User]
_  = m Int64
forall a. HasCallStack => a
undefined