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