]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Action/User/New.hs
[FEAT] SocialList Map Text ScoresParent to Map Text Children
[gargantext.git] / 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