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