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
10 Functions to deal with users, database side.
14 {-# OPTIONS_GHC -fno-warn-orphans #-}
16 {-# LANGUAGE TemplateHaskell #-}
17 {-# LANGUAGE FunctionalDependencies #-}
18 {-# LANGUAGE Arrows #-}
20 module Gargantext.Database.Query.Table.User
28 , selectUsersLightWith
34 , module Gargantext.Database.Schema.User
38 import Control.Arrow (returnA)
39 import Data.List (find)
40 import Data.Text (Text)
41 import Data.Time (UTCTime)
42 import Gargantext.Core.Types.Individu
43 import qualified Gargantext.Prelude.Crypto.Auth as Auth
44 import Gargantext.Database.Schema.User
45 import Gargantext.Database.Prelude
46 import Gargantext.Prelude
49 ------------------------------------------------------------------------
50 -- TODO: on conflict, nice message
51 insertUsers :: [UserWrite] -> Cmd err Int64
52 insertUsers us = mkCmd $ \c -> runInsert_ c insert
54 insert = Insert userTable us rCount Nothing
56 deleteUsers :: [Username] -> Cmd err Int64
57 deleteUsers us = mkCmd $ \c -> runDelete_ c
59 (\user -> in_ (map sqlStrictText us) (user_username user))
62 -- Updates email or password only (for now)
63 updateUserDB :: UserWrite -> Cmd err Int64
64 updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
66 updateUserQuery :: UserWrite -> Update Int64
67 updateUserQuery us' = Update
69 , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
70 -> UserDB _id p' ll su un fn ln em' is ia dj
72 , uWhere = (\row -> user_username row .== un')
76 UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
78 -----------------------------------------------------------------------
79 toUserWrite :: NewUser HashPassword -> UserWrite
80 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
81 UserDB (Nothing) (sqlStrictText p)
82 (Nothing) (pgBool True) (sqlStrictText u)
83 (sqlStrictText "first_name")
84 (sqlStrictText "last_name")
89 ------------------------------------------------------------------
90 getUsersWith :: Username -> Cmd err [UserLight]
91 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
93 selectUsersLightWith :: Username -> Query UserRead
94 selectUsersLightWith u = proc () -> do
95 row <- queryUserTable -< ()
96 restrict -< user_username row .== sqlStrictText u
99 ----------------------------------------------------------
100 getUsersWithId :: Int -> Cmd err [UserLight]
101 getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
103 selectUsersLightWithId :: Int -> Query UserRead
104 selectUsersLightWithId i' = proc () -> do
105 row <- queryUserTable -< ()
106 restrict -< user_id row .== sqlInt4 i'
110 queryUserTable :: Query UserRead
111 queryUserTable = selectTable userTable
113 ------------------------------------------------------------------
114 -- | Select User with some parameters
115 -- Not optimized version
116 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
117 userWith f t xs = find (\x -> f x == t) xs
119 -- | Select User with Username
120 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
121 userWithUsername t xs = userWith user_username t xs
123 userWithId :: Int -> [UserDB] -> Maybe UserDB
124 userWithId t xs = userWith user_id t xs
126 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
127 userLightWithUsername t xs = userWith userLight_username t xs
129 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
130 userLightWithId t xs = userWith userLight_id t xs
132 ----------------------------------------------------------------------
133 users :: Cmd err [UserDB]
134 users = runOpaQuery queryUserTable
136 usersLight :: Cmd err [UserLight]
137 usersLight = map toUserLight <$> users
139 getUser :: Username -> Cmd err (Maybe UserLight)
140 getUser u = userLightWithUsername u <$> usersLight
142 ----------------------------------------------------------------------
143 insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
144 insertNewUsers newUsers = do
145 users' <- liftBase $ mapM toUserHash newUsers
146 insertUsers $ map toUserWrite users'
148 ----------------------------------------------------------------------
149 instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
150 defaultFromField = fieldQueryRunnerColumn