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-name-shadowing #-}
  12 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  13
  14 module Gargantext.Database.Action.User.New
  15   where
  16
  17 import Control.Lens (view)
  18 import Control.Monad.Random
  19 import Data.Text (Text, unlines, splitOn)
  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 Gargantext.Prelude.Mail (gargMail, GargMail(..))
  29
  30
  31 ------------------------------------------------------------------------
  32 type EmailAddress = Text
  33 ------------------------------------------------------------------------
  34 newUsers :: (CmdM env err m, MonadRandom m, HasNodeError err)
  35          => [EmailAddress] -> m Int64
  36 newUsers us = do
  37   us' <- mapM newUserQuick us
  38   url <- view $ config . gc_url
  39   newUsers' url us'
  40 ------------------------------------------------------------------------
  41 newUserQuick :: (MonadRandom m)
  42              => Text -> m (NewUser GargPassword)
  43 newUserQuick n = do
  44   pass <- gargPass
  45   let (u,_m) = guessUserName n
  46   pure (NewUser u n (GargPassword pass))
  47
  48 guessUserName :: Text -> (Text,Text)
  49 guessUserName n = case splitOn "@" n of
  50     [u',m'] -> if m' /= "" then (u',m')
  51                            else panic "Email Invalid"
  52     _  -> panic "Email invalid"
  53 ------------------------------------------------------------------------
  54 newUser' :: HasNodeError err
  55         => Text -> NewUser GargPassword -> Cmd err Int64
  56 newUser' address u = newUsers' address [u]
  57
  58 newUsers' :: HasNodeError err
  59          => Text -> [NewUser GargPassword] -> Cmd err Int64
  60 newUsers' address us = do
  61   us' <- liftBase    $ mapM toUserHash us
  62   r   <- insertUsers $ map toUserWrite us'
  63   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
  64   _   <- liftBase    $ mapM (mail Invitation address) us
  65   pure r
  66 ------------------------------------------------------------------------
  67 updateUser :: HasNodeError err
  68            => Text -> NewUser GargPassword -> Cmd err Int64
  69 updateUser address u = do
  70   u' <- liftBase   $ toUserHash   u
  71   n  <- updateUserDB $ toUserWrite  u'
  72   _  <- liftBase   $ mail Update address u
  73   pure n
  74
  75 ------------------------------------------------------------------------
  76 data Mail = Invitation
  77           | Update
  78
  79
  80 -- TODO gargantext.ini config
  81 mail :: Mail -> Text -> NewUser GargPassword -> IO ()
  82 mail mtype address nu@(NewUser u m _) = gargMail (GargMail m (Just u) subject body)
  83   where
  84     subject = "[Your Garg Account]"
  85     body    = bodyWith mtype address nu
  86
  87 bodyWith :: Mail -> Text -> NewUser GargPassword -> Text
  88 bodyWith Invitation add nu = logInstructions    add nu
  89 bodyWith Update     add nu = updateInstructions add nu
  90
  91
  92 -- TODO put this in a configurable file (path in gargantext.ini)
  93 logInstructions :: Text -> NewUser GargPassword -> Text
  94 logInstructions address (NewUser u _ (GargPassword p)) =
  95   unlines [ "Hello"
  96           , "You have been invited to test the new GarganText platform!"
  97           , ""
  98           , "You can log in to: " <> address
  99           , "Your username is: "  <> u
 100           , "Your password is: "  <> p
 101           , ""
 102           , "Please read the full terms of use on:"
 103           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 104           , ""
 105           , "Your feedback will be valuable for further development"
 106           , "of the platform, do not hesitate to contact us and"
 107           , "to contribute on our forum:"
 108           , "     https://discourse.iscpif.fr/c/gargantext"
 109           , ""
 110           , "With our best regards,"
 111           , "-- "
 112           , "The Gargantext Team (CNRS)"
 113           ]
 114
 115 updateInstructions :: Text -> NewUser GargPassword -> Text
 116 updateInstructions address (NewUser u _ (GargPassword p)) =
 117   unlines [ "Hello"
 118           , "Your account have been updated on the GarganText platform!"
 119           , ""
 120           , "You can log in to: " <> address
 121           , "Your username is: "  <> u
 122           , "Your password is: "  <> p
 123           , ""
 124           , "As reminder, please read the full terms of use on:"
 125           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 126           , ""
 127           , "Your feedback is always valuable for further development"
 128           , "of the platform, do not hesitate to contact us and"
 129           , "to contribute on our forum:"
 130           , "     https://discourse.iscpif.fr/c/gargantext"
 131           , ""
 132           , "With our best regards,"
 133           , "-- "
 134           , "The Gargantext Team (CNRS)"
 135           ]
 136
 137
 138 ------------------------------------------------------------------------
 139 rmUser :: HasNodeError err => User -> Cmd err Int64
 140 rmUser (UserName un) = deleteUsers [un]
 141 rmUser _ = nodeError NotImplYet
 142
 143 -- TODO
 144 rmUsers :: HasNodeError err => [User] -> Cmd err Int64
 145 rmUsers [] = pure 0
 146 rmUsers _  = undefined