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
{-|
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
, getUser
, insertNewUsers
, selectUsersLightWith
, userWithUsername
, userWithId
, userLightWithId
, getUsersWith
, getUsersWithId
, module Gargantext.Database.Schema.User
)
where
import Control.Arrow (returnA)
import Data.List (find)
import Data.Text (Text)
import Data.Time (UTCTime)
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Schema.User
import Gargantext.Database.Prelude
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 _id _p ll su un fn ln _em is ia dj)
-> UserDB _id p' ll su un fn ln em' is ia dj
)
, uWhere = (\row -> user_username row .== un')
, uReturning = rCount
}
where
UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
-----------------------------------------------------------------------
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite (NewUser u m (Auth.PasswordHash p)) =
UserDB (Nothing) (sqlStrictText p)
(Nothing) (pgBool True) (sqlStrictText u)
(sqlStrictText "first_name")
(sqlStrictText "last_name")
(sqlStrictText m)
(pgBool True)
(pgBool True) Nothing
------------------------------------------------------------------
getUsersWith :: Username -> Cmd err [UserLight]
getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
selectUsersLightWith :: Username -> Query UserRead
selectUsersLightWith u = proc () -> do
row <- queryUserTable -< ()
restrict -< user_username row .== sqlStrictText u
returnA -< row
----------------------------------------------------------
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
where
selectUsersLightWithId :: Int -> Query UserRead
selectUsersLightWithId i' = proc () -> do
row <- queryUserTable -< ()
restrict -< user_id row .== sqlInt4 i'
returnA -< row
queryUserTable :: Query UserRead
queryUserTable = selectTable userTable
------------------------------------------------------------------
-- | 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 PGTimestamptz (Maybe UTCTime) where
defaultFromField = fieldQueryRunnerColumn