1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
{-|
Module : Gargantext.Database.Query.Table.User
Description : User Database management tools
Copyright : (c) CNRS, 2017-Present
License : AGPL + CECILL v3
Maintainer : team@gargantext.org
Stability : experimental
Portability : POSIX
Functions to deal with users, database side.
-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
module Gargantext.Database.Query.Table.User
( insertUsers
, toUserWrite
, deleteUsers
, updateUserDB
, queryUserTable
, getUserHyperdata
, getUsersWithHyperdata
, getUsersWithNodeHyperdata
, updateUserEmail
, updateUserPassword
, updateUserForgotPasswordUUID
, getUser
, insertNewUsers
, selectUsersLightWith
, userWithUsername
, userWithId
, userLightWithId
, getUsersWith
, getUsersWithEmail
, getUsersWithForgotPasswordUUID
, getUsersWithId
, module Gargantext.Database.Schema.User
)
where
import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Text (Text)
import Data.Time (UTCTime)
import qualified Data.UUID as UUID
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node)
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_user_id, node_typename)
import Gargantext.Database.Schema.User
import Gargantext.Prelude
import Opaleye
------------------------------------------------------------------------
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers us = mkCmd $ \c -> runInsert_ c insert
where
insert = Insert userTable us rCount Nothing
deleteUsers :: [Username] -> Cmd err Int64
deleteUsers us = mkCmd $ \c -> runDelete_ c
$ Delete userTable
(\user -> in_ (map sqlStrictText us) (user_username user))
rCount
-- Updates email or password only (for now)
updateUserDB :: UserWrite -> Cmd err Int64
updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
where
updateUserQuery :: UserWrite -> Update Int64
updateUserQuery us' = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. })
-> UserDB { user_password = p'
, user_email = em'
, .. }
)
, uWhere = (\row -> user_username row .== un')
, uReturning = rCount
}
where
UserDB { user_password = p'
, user_username = un'
, user_email = em' } = us'
-----------------------------------------------------------------------
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite (NewUser u m (Auth.PasswordHash p)) =
UserDB { user_id = Nothing
, user_password = sqlStrictText p
, user_lastLogin = Nothing
, user_isSuperUser = sqlBool True
, user_username = sqlStrictText u
, user_firstName = sqlStrictText "first_name"
, user_lastName = sqlStrictText "last_name"
, user_email = sqlStrictText m
, user_isStaff = sqlBool True
, user_isActive = sqlBool True
, user_dateJoined = Nothing
, user_forgot_password_uuid = Nothing }
------------------------------------------------------------------
getUsersWith :: Username -> Cmd err [UserLight]
getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
selectUsersLightWith :: Username -> Select UserRead
selectUsersLightWith u = proc () -> do
row <- queryUserTable -< ()
restrict -< user_username row .== sqlStrictText u
returnA -< row
getUsersWithEmail :: Text -> Cmd err [UserLight]
getUsersWithEmail e = map toUserLight <$> runOpaQuery (selectUsersLightWithEmail e)
selectUsersLightWithEmail :: Text -> Select UserRead
selectUsersLightWithEmail e = proc () -> do
row <- queryUserTable -< ()
restrict -< user_email row .== sqlStrictText e
returnA -< row
getUsersWithForgotPasswordUUID :: UUID.UUID -> Cmd err [UserLight]
getUsersWithForgotPasswordUUID uuid = map toUserLight <$> runOpaQuery (selectUsersLightWithForgotPasswordUUID uuid)
selectUsersLightWithForgotPasswordUUID :: UUID.UUID -> Select UserRead
selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
row <- queryUserTable -< ()
restrict -< user_forgot_password_uuid row .== sqlStrictText (UUID.toText uuid)
returnA -< row
----------------------------------------------------------
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
where
selectUsersLightWithId :: Int -> Select UserRead
selectUsersLightWithId i' = proc () -> do
row <- queryUserTable -< ()
restrict -< user_id row .== sqlInt4 i'
returnA -< row
queryUserTable :: Select UserRead
queryUserTable = selectTable userTable
----------------------------------------------------------------------
getUserHyperdata :: Int -> Cmd err [HyperdataUser]
getUserHyperdata i = do
runOpaQuery (selectUserHyperdataWithId i)
where
selectUserHyperdataWithId :: Int -> Select (Column SqlJsonb)
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== (sqlInt4 i')
restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
returnA -< row^.node_hyperdata
getUserNodeHyperdata :: Int -> Cmd err [Node HyperdataUser]
getUserNodeHyperdata i = do
runOpaQuery (selectUserHyperdataWithId i)
where
selectUserHyperdataWithId :: Int -> Select NodeRead
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== (sqlInt4 i')
restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
returnA -< row
getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata i = do
u <- getUsersWithId i
h <- getUserHyperdata i
-- printDebug "[getUsersWithHyperdata]" (u,h)
pure $ zip u h
getUsersWithNodeHyperdata :: Int -> Cmd err [(UserLight, Node HyperdataUser)]
getUsersWithNodeHyperdata i = do
u <- getUsersWithId i
h <- getUserNodeHyperdata i
-- printDebug "[getUsersWithHyperdata]" (u,h)
pure $ zip u h
updateUserEmail :: UserLight -> Cmd err Int64
updateUserEmail (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
where
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_email = sqlStrictText userLight_email, .. } )
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
updateUserPassword :: UserLight -> Cmd err Int64
updateUserPassword (UserLight { userLight_password = GargPassword password, .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
where
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
updateUserForgotPasswordUUID :: UserLight -> Cmd err Int64
updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c updateUserQuery
where
pass = sqlStrictText $ fromMaybe "" userLight_forgot_password_uuid
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uReturning = rCount }
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
userWith f t xs = find (\x -> f x == t) xs
-- | Select User with Username
userWithUsername :: Text -> [UserDB] -> Maybe UserDB
userWithUsername t xs = userWith user_username t xs
userWithId :: Int -> [UserDB] -> Maybe UserDB
userWithId t xs = userWith user_id t xs
userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
userLightWithUsername t xs = userWith userLight_username t xs
userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId t xs = userWith userLight_id t xs
----------------------------------------------------------------------
users :: Cmd err [UserDB]
users = runOpaQuery queryUserTable
usersLight :: Cmd err [UserLight]
usersLight = map toUserLight <$> users
getUser :: Username -> Cmd err (Maybe UserLight)
getUser u = userLightWithUsername u <$> usersLight
----------------------------------------------------------------------
insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
insertNewUsers newUsers = do
users' <- liftBase $ mapM toUserHash newUsers
insertUsers $ map toUserWrite users'
----------------------------------------------------------------------
instance DefaultFromField SqlTimestamptz (Maybe UTCTime) where
defaultFromField = fromPGSFromField