src/Gargantext/Database/Action/User/New.hs

   1 {-|
   2 Module      : Gargantext.Database.Action.User.New
   3 Description :
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9 -}
  10
  11 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  12
  13 module Gargantext.Database.Action.User.New
  14   where
  15
  16 import Control.Lens (view)
  17 import Control.Monad.Random
  18 import Data.Text (Text, splitOn)
  19 import qualified Data.Text as Text
  20 import Gargantext.Core.Mail
  21 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
  22 import Gargantext.Core.Types.Individu
  23 import Gargantext.Database.Action.Flow (getOrMkRoot)
  24 import Gargantext.Database.Prelude
  25 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
  26 import Gargantext.Database.Query.Table.User
  27 import Gargantext.Prelude
  28 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
  29 import Gargantext.Prelude.Mail.Types (MailConfig)
  30 ------------------------------------------------------------------------
  31 ------------------------------------------------------------------------
  32 newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
  33          => [EmailAddress] -> m Int64
  34 newUsers us = do
  35   us' <- mapM newUserQuick us
  36   config <- view $ mailSettings
  37   newUsers' config us'
  38 ------------------------------------------------------------------------
  39 newUserQuick :: (MonadRandom m)
  40              => Text -> m (NewUser GargPassword)
  41 newUserQuick n = do
  42   pass <- gargPass
  43   let u = case guessUserName n of
  44         Just  (u', _m) -> u'
  45         Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
  46   pure (NewUser u n (GargPassword pass))
  47
  48 ------------------------------------------------------------------------
  49 -- | guessUserName
  50 -- guess username and normalize it (Text.toLower)
  51 guessUserName :: Text -> Maybe (Text,Text)
  52 guessUserName n = case splitOn "@" n of
  53     [u',m'] -> if m' /= "" then Just (Text.toLower u',m')
  54                            else Nothing
  55     _       -> Nothing
  56 ------------------------------------------------------------------------
  57 newUser' :: HasNodeError err
  58         => MailConfig -> NewUser GargPassword -> Cmd err Int64
  59 newUser' cfg u = newUsers' cfg [u]
  60
  61 newUsers' :: HasNodeError err
  62          => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
  63 newUsers' cfg us = do
  64   us' <- liftBase         $ mapM toUserHash  us
  65   r   <- insertUsers      $ map  toUserWrite us'
  66   _   <- mapM getOrMkRoot $ map  (\u -> UserName   (_nu_username u)) us
  67   _   <- liftBase         $ mapM (\u -> mail cfg (Invitation u)) us
  68   printDebug "newUsers'" us
  69   pure r
  70 ------------------------------------------------------------------------
  71
  72 updateUser :: HasNodeError err
  73            => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
  74 updateUser (SendEmail send) cfg u = do
  75   u' <- liftBase     $ toUserHash   u
  76   n  <- updateUserDB $ toUserWrite  u'
  77   _  <- case send of
  78      True  -> liftBase     $ mail cfg (PassUpdate u)
  79      False -> pure ()
  80   pure n
  81
  82 ------------------------------------------------------------------------
  83 rmUser :: HasNodeError err => User -> Cmd err Int64
  84 rmUser (UserName un) = deleteUsers [un]
  85 rmUser _ = nodeError NotImplYet
  86
  87 -- TODO
  88 rmUsers :: HasNodeError err => [User] -> Cmd err Int64
  89 rmUsers [] = pure 0
  90 rmUsers _  = undefined