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