]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/Query/Table/User.hs
Merge branch 'dev' into 86-dev-graphql
[gargantext.git] / src / Gargantext / Database / Query / Table / User.hs
1 {-|
2 Module : Gargantext.Database.Query.Table.User
3 Description : User Database management tools
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Functions to deal with users, database side.
11 -}
12
13
14 {-# OPTIONS_GHC -fno-warn-orphans #-}
15
16 {-# LANGUAGE TemplateHaskell #-}
17 {-# LANGUAGE FunctionalDependencies #-}
18 {-# LANGUAGE Arrows #-}
19
20 module Gargantext.Database.Query.Table.User
21 ( insertUsers
22 , toUserWrite
23 , deleteUsers
24 , updateUserDB
25 , queryUserTable
26 , getUserHyperdata
27 , getUsersWithHyperdata
28 , getUser
29 , insertNewUsers
30 , selectUsersLightWith
31 , userWithUsername
32 , userWithId
33 , userLightWithId
34 , getUsersWith
35 , getUsersWithId
36 , module Gargantext.Database.Schema.User
37 )
38 where
39
40 import Control.Arrow (returnA)
41 import Control.Lens ((^.))
42 import Data.List (find)
43 import Data.Text (Text)
44 import Data.Time (UTCTime)
45 import Gargantext.Core.Types.Individu
46 import qualified Gargantext.Prelude.Crypto.Auth as Auth
47 import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
48 import Gargantext.Database.Prelude
49 import Gargantext.Database.Schema.Node (node_hyperdata, node_id, queryNodeTable)
50 import Gargantext.Database.Schema.User
51 import Gargantext.Prelude
52 import Opaleye
53
54 ------------------------------------------------------------------------
55 -- TODO: on conflict, nice message
56 insertUsers :: [UserWrite] -> Cmd err Int64
57 insertUsers us = mkCmd $ \c -> runInsert_ c insert
58 where
59 insert = Insert userTable us rCount Nothing
60
61 deleteUsers :: [Username] -> Cmd err Int64
62 deleteUsers us = mkCmd $ \c -> runDelete_ c
63 $ Delete userTable
64 (\user -> in_ (map sqlStrictText us) (user_username user))
65 rCount
66
67 -- Updates email or password only (for now)
68 updateUserDB :: UserWrite -> Cmd err Int64
69 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
70 where
71 updateUserQuery :: UserWrite -> Update Int64
72 updateUserQuery us' = Update
73 { uTable = userTable
74 , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
75 -> UserDB _id p' ll su un fn ln em' is ia dj
76 )
77 , uWhere = (\row -> user_username row .== un')
78 , uReturning = rCount
79 }
80 where
81 UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
82
83 -----------------------------------------------------------------------
84 toUserWrite :: NewUser HashPassword -> UserWrite
85 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
86 UserDB (Nothing) (sqlStrictText p)
87 (Nothing) (pgBool True) (sqlStrictText u)
88 (sqlStrictText "first_name")
89 (sqlStrictText "last_name")
90 (sqlStrictText m)
91 (pgBool True)
92 (pgBool True) Nothing
93
94 ------------------------------------------------------------------
95 getUsersWith :: Username -> Cmd err [UserLight]
96 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
97
98 selectUsersLightWith :: Username -> Query UserRead
99 selectUsersLightWith u = proc () -> do
100 row <- queryUserTable -< ()
101 restrict -< user_username row .== sqlStrictText u
102 returnA -< row
103
104 ----------------------------------------------------------
105 getUsersWithId :: Int -> Cmd err [UserLight]
106 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
107 where
108 selectUsersLightWithId :: Int -> Query UserRead
109 selectUsersLightWithId i' = proc () -> do
110 row <- queryUserTable -< ()
111 restrict -< user_id row .== sqlInt4 i'
112 returnA -< row
113
114
115 queryUserTable :: Query UserRead
116 queryUserTable = selectTable userTable
117
118 ----------------------------------------------------------------------
119 getUserHyperdata :: Int -> Cmd err [HyperdataUser]
120 getUserHyperdata i = do
121 runOpaQuery (selectUserHyperdataWithId i)
122 where
123 selectUserHyperdataWithId :: Int -> Query (Column PGJsonb)
124 selectUserHyperdataWithId i' = proc () -> do
125 row <- queryNodeTable -< ()
126 restrict -< row^.node_id .== (sqlInt4 i')
127 returnA -< row^.node_hyperdata
128
129 getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
130 getUsersWithHyperdata i = do
131 u <- getUsersWithId i
132 h <- getUserHyperdata i
133 pure $ zip u h
134 ------------------------------------------------------------------
135 -- | Select User with some parameters
136 -- Not optimized version
137 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
138 userWith f t xs = find (\x -> f x == t) xs
139
140 -- | Select User with Username
141 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
142 userWithUsername t xs = userWith user_username t xs
143
144 userWithId :: Int -> [UserDB] -> Maybe UserDB
145 userWithId t xs = userWith user_id t xs
146
147 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
148 userLightWithUsername t xs = userWith userLight_username t xs
149
150 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
151 userLightWithId t xs = userWith userLight_id t xs
152 ----------------------------------------------------------------------
153 users :: Cmd err [UserDB]
154 users = runOpaQuery queryUserTable
155
156 usersLight :: Cmd err [UserLight]
157 usersLight = map toUserLight <$> users
158
159 getUser :: Username -> Cmd err (Maybe UserLight)
160 getUser u = userLightWithUsername u <$> usersLight
161
162 ----------------------------------------------------------------------
163 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
164 insertNewUsers newUsers = do
165 users' <- liftBase $ mapM toUserHash newUsers
166 insertUsers $ map toUserWrite users'
167
168 ----------------------------------------------------------------------
169 instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
170 defaultFromField = fieldQueryRunnerColumn