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 Gargantext.Core.Mail
  20 import Gargantext.Core.Mail.Types (HasMail, mailSettings)
  21 import Gargantext.Core.Types.Individu
  22 import Gargantext.Database.Action.Flow (getOrMkRoot)
  23 import Gargantext.Database.Prelude
  24 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
  25 import Gargantext.Database.Query.Table.User
  26 import Gargantext.Prelude
  27 import Gargantext.Prelude.Crypto.Pass.User (gargPass)
  28 import Gargantext.Prelude.Mail.Types (MailConfig)
  29 import qualified Data.Text as Text
  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 ------------------------------------------------------------------------
  40
  41 updateUsersPassword :: (CmdM env err m, MonadRandom m, HasNodeError err, HasMail env)
  42          => [EmailAddress] -> m Int64
  43 updateUsersPassword us = do
  44   us' <- mapM newUserQuick us
  45   config <- view $ mailSettings
  46   _ <- mapM (\u -> updateUser (SendEmail True) config u) us'
  47   pure 1
  48
  49 ------------------------------------------------------------------------
  50 ------------------------------------------------------------------------
  51 newUserQuick :: (MonadRandom m)
  52              => Text -> m (NewUser GargPassword)
  53 newUserQuick n = do
  54   pass <- gargPass
  55   let n' = Text.toLower n
  56   let u = case guessUserName n of
  57         Just  (u', _m) -> u'
  58         Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
  59   pure (NewUser u n' (GargPassword pass))
  60 ------------------------------------------------------------------------
  61
  62 ------------------------------------------------------------------------
  63 -- | guessUserName
  64 -- guess username and normalize it (Text.toLower)
  65 guessUserName :: Text -> Maybe (Text,Text)
  66 guessUserName n = case splitOn "@" n of
  67     [u',m'] -> if m' /= "" then Just (Text.toLower u',m')
  68                            else Nothing
  69     _       -> Nothing
  70 ------------------------------------------------------------------------
  71 newUser' :: HasNodeError err
  72         => MailConfig -> NewUser GargPassword -> Cmd err Int64
  73 newUser' cfg u = newUsers' cfg [u]
  74
  75 newUsers' :: HasNodeError err
  76          => MailConfig -> [NewUser GargPassword] -> Cmd err Int64
  77 newUsers' cfg us = do
  78   us' <- liftBase         $ mapM toUserHash  us
  79   r   <- insertUsers      $ map  toUserWrite us'
  80   _   <- mapM getOrMkRoot $ map  (\u -> UserName   (_nu_username u)) us
  81   _   <- mapM (\u -> mail cfg (Invitation u)) us
  82   printDebug "newUsers'" us
  83   pure r
  84 ------------------------------------------------------------------------
  85 updateUser :: HasNodeError err
  86            => SendEmail -> MailConfig -> NewUser GargPassword -> Cmd err Int64
  87 updateUser (SendEmail send) cfg u = do
  88   u' <- liftBase     $ toUserHash   u
  89   n  <- updateUserDB $ toUserWrite  u'
  90   _  <- case send of
  91      True  -> mail cfg (PassUpdate u)
  92      False -> pure ()
  93   pure n
  94
  95 ------------------------------------------------------------------------
  96 rmUser :: HasNodeError err => User -> Cmd err Int64
  97 rmUser (UserName un) = deleteUsers [un]
  98 rmUser _ = nodeError NotImplYet
  99
 100 -- TODO
 101 rmUsers :: HasNodeError err => [User] -> Cmd err Int64
 102 rmUsers [] = pure 0
 103 rmUsers _  = undefined