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 import qualified Data.List as List
  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 = case guessUserName n of
  46         Just  (u', _m) -> u'
  47         Nothing        -> panic "[G.D.A.U.N.newUserQuick]: Email invalid"
  48   pure (NewUser u n (GargPassword pass))
  49
  50 ------------------------------------------------------------------------
  51 isEmail :: Text -> Bool
  52 isEmail = ((==) 2) . List.length . (splitOn "@")
  53
  54 guessUserName :: Text -> Maybe (Text,Text)
  55 guessUserName n = case splitOn "@" n of
  56     [u',m'] -> if m' /= "" then Just (u',m')
  57                            else Nothing
  58     _       -> Nothing
  59 ------------------------------------------------------------------------
  60 newUser' :: HasNodeError err
  61         => Text -> NewUser GargPassword -> Cmd err Int64
  62 newUser' address u = newUsers' address [u]
  63
  64 newUsers' :: HasNodeError err
  65          => Text -> [NewUser GargPassword] -> Cmd err Int64
  66 newUsers' address us = do
  67   us' <- liftBase         $ mapM toUserHash us
  68   r   <- insertUsers      $ map toUserWrite us'
  69   _   <- mapM getOrMkRoot $ map (\u -> UserName (_nu_username u)) us
  70   _   <- liftBase         $ mapM (mail Invitation address) us
  71   pure r
  72 ------------------------------------------------------------------------
  73
  74 data SendEmail = SendEmail Bool
  75
  76 updateUser :: HasNodeError err
  77            => SendEmail -> Text -> NewUser GargPassword -> Cmd err Int64
  78 updateUser (SendEmail send) address u = do
  79   u' <- liftBase     $ toUserHash   u
  80   n  <- updateUserDB $ toUserWrite  u'
  81   _  <- case send of
  82      True  -> liftBase     $ mail Update address u
  83      False -> pure ()
  84   pure n
  85
  86 ------------------------------------------------------------------------
  87 data Mail = Invitation
  88           | Update
  89
  90
  91 -- TODO gargantext.ini config
  92 mail :: Mail -> Text -> NewUser GargPassword -> IO ()
  93 mail mtype address nu@(NewUser u m _) = gargMail (GargMail m (Just u) subject body)
  94   where
  95     subject = "[Your Garg Account]"
  96     body    = bodyWith mtype address nu
  97
  98 bodyWith :: Mail -> Text -> NewUser GargPassword -> Text
  99 bodyWith Invitation add nu = logInstructions    add nu
 100 bodyWith Update     add nu = updateInstructions add nu
 101
 102
 103 -- TODO put this in a configurable file (path in gargantext.ini)
 104 logInstructions :: Text -> NewUser GargPassword -> Text
 105 logInstructions address (NewUser u _ (GargPassword p)) =
 106   unlines [ "Hello"
 107           , "You have been invited to test the new GarganText platform!"
 108           , ""
 109           , "You can log in to: " <> address
 110           , "Your username is: "  <> u
 111           , "Your password is: "  <> p
 112           , ""
 113           , "Please read the full terms of use on:"
 114           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 115           , ""
 116           , "Your feedback will be valuable for further development"
 117           , "of the platform, do not hesitate to contact us and"
 118           , "to contribute on our forum:"
 119           , "     https://discourse.iscpif.fr/c/gargantext"
 120           , ""
 121           , "With our best regards,"
 122           , "-- "
 123           , "The Gargantext Team (CNRS)"
 124           ]
 125
 126 updateInstructions :: Text -> NewUser GargPassword -> Text
 127 updateInstructions address (NewUser u _ (GargPassword p)) =
 128   unlines [ "Hello"
 129           , "Your account have been updated on the GarganText platform!"
 130           , ""
 131           , "You can log in to: " <> address
 132           , "Your username is: "  <> u
 133           , "Your password is: "  <> p
 134           , ""
 135           , "As reminder, please read the full terms of use on:"
 136           , "https://gitlab.iscpif.fr/humanities/tofu/tree/master"
 137           , ""
 138           , "Your feedback is always valuable for further development"
 139           , "of the platform, do not hesitate to contact us and"
 140           , "to contribute on our forum:"
 141           , "     https://discourse.iscpif.fr/c/gargantext"
 142           , ""
 143           , "With our best regards,"
 144           , "-- "
 145           , "The Gargantext Team (CNRS)"
 146           ]
 147
 148
 149 ------------------------------------------------------------------------
 150 rmUser :: HasNodeError err => User -> Cmd err Int64
 151 rmUser (UserName un) = deleteUsers [un]
 152 rmUser _ = nodeError NotImplYet
 153
 154 -- TODO
 155 rmUsers :: HasNodeError err => [User] -> Cmd err Int64
 156 rmUsers [] = pure 0
 157 rmUsers _  = undefined