src/Gargantext/Database/Action/User.hs

   1 {-|
   2 Module      : Gargantext.Database.Action.User
   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
  15   where
  16
  17 -- import Data.Maybe (catMaybes)
  18 import Data.Text (Text, unlines)
  19 import Gargantext.Database.Query.Table.User
  20 import Gargantext.Core.Types.Individu
  21 import Gargantext.Database.Prelude
  22 import Gargantext.Prelude
  23 import Gargantext.Prelude.Mail (gargMail, GargMail(..))
  24 import Gargantext.Database.Query.Table.Node.Error (HasNodeError(..), nodeError, NodeError(..))
  25 import Gargantext.Database.Action.Flow (getOrMkRoot)
  26
  27 ------------------------------------------------------------------------
  28 mkUser :: HasNodeError err => Text -> NewUser GargPassword -> Cmd err Int64
  29 mkUser address u = mkUsers address [u]
  30
  31 mkUsers :: HasNodeError err => Text -> [NewUser GargPassword] -> Cmd err Int64
  32 mkUsers address us = do
  33   us' <- liftBase    $ mapM toUserHash us
  34   r   <- insertUsers $ map toUserWrite us'
  35   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
  36   _   <- liftBase    $ mapM (mail Invitation address) us
  37   pure r
  38 ------------------------------------------------------------------------
  39 updateUser :: HasNodeError err => Text -> NewUser GargPassword -> Cmd err Int64
  40 updateUser address u = do
  41   u' <- liftBase   $ toUserHash   u
  42   n  <- updateUserDB $ toUserWrite  u'
  43   _  <- liftBase   $ mail Update address u
  44   pure n
  45
  46 ------------------------------------------------------------------------
  47 data Mail = Invitation
  48           | Update
  49
  50
  51 -- TODO gargantext.ini config
  52 mail :: Mail -> Text -> NewUser GargPassword -> IO ()
  53 mail mtype address nu@(NewUser u m _) = gargMail (GargMail m (Just u) subject body)
  54   where
  55     subject = "[Your Garg Account]"
  56     body    = bodyWith mtype address nu
  57
  58 bodyWith :: Mail -> Text -> NewUser GargPassword -> Text
  59 bodyWith Invitation add nu = logInstructions    add nu
  60 bodyWith Update     add nu = updateInstructions add nu
  61
  62
  63 -- TODO put this in a configurable file (path in gargantext.ini)
  64 logInstructions :: Text -> NewUser GargPassword -> Text
  65 logInstructions address (NewUser u _ (GargPassword p)) =
  66   unlines [ "Hello"
  67           , "You have been invited to test the new GarganText platform!"
  68           , ""
  69           , "You can log on to: "  <> address
  70           , "Your login is: "      <> u
  71           , "Your password is: "   <> p
  72           , ""
  73           , "Please read the full terms of use on:"
  74           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
  75           , ""
  76           , "Your feedback will be valuable for further development"
  77           , "of the platform, do not hesitate to contact us and"
  78           , "to contribute on our forum:"
  79           , "     https://discourse.iscpif.fr/c/gargantext"
  80           , ""
  81           , "With our best regards,"
  82           , "-- "
  83           , "The Gargantext Team (CNRS)"
  84           ]
  85
  86 updateInstructions :: Text -> NewUser GargPassword -> Text
  87 updateInstructions address (NewUser u _ (GargPassword p)) =
  88   unlines [ "Hello"
  89           , "Your account have been updated on the GarganText platform!"
  90           , ""
  91           , "You can log on to: "  <> address
  92           , "Your login is: "      <> u
  93           , "Your password is: "   <> p
  94           , ""
  95           , "As reminder, please read the full terms of use on:"
  96           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
  97           , ""
  98           , "Your feedback is always valuable for further development"
  99           , "of the platform, do not hesitate to contact us and"
 100           , "to contribute on our forum:"
 101           , "     https://discourse.iscpif.fr/c/gargantext"
 102           , ""
 103           , "With our best regards,"
 104           , "-- "
 105           , "The Gargantext Team (CNRS)"
 106           ]
 107
 108
 109
 110 ------------------------------------------------------------------------
 111 rmUser :: HasNodeError err => User -> Cmd err Int64
 112 rmUser (UserName un) = deleteUsers [un]
 113 rmUser _ = nodeError NotImplYet
 114
 115 -- TODO
 116 rmUsers :: HasNodeError err => [User] -> Cmd err Int64
 117 rmUsers [] = pure 0
 118 rmUsers _  = undefined