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
{-|
Module : Gargantext.Database.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-name-shadowing #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Gargantext.Database.User where
import Control.Arrow (returnA)
import Control.Lens.TH (makeLensesWith, abbreviatedFields)
import Data.Eq(Eq(..))
import Data.List (find)
import Data.Maybe (Maybe)
import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Show(Show(..))
import Opaleye
import qualified Database.PostgreSQL.Simple as PGS
import Gargantext.Prelude
import Gargantext.Database.Node (Cmd(..), mkCmd, runCmd)
data UserLight = UserLight { userLight_id :: Int
, userLight_username :: Text
, userLight_email :: Text
} deriving (Show)
toUserLight :: User -> UserLight
toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
data UserPoly id pass llogin suser
uname fname lname
mail staff active djoined = User { user_id :: id
, user_password :: pass
, user_lastLogin :: llogin
, user_isSuperUser :: suser
, user_username :: uname
, user_firstName :: fname
, user_lastName :: lname
, user_email :: mail
, user_isStaff :: staff
, user_isActive :: active
, user_dateJoined :: djoined
} deriving (Show)
type UserWrite = UserPoly (Maybe (Column PGInt4)) (Column PGText)
(Maybe (Column PGTimestamptz)) (Column PGBool)
(Column PGText) (Column PGText)
(Column PGText) (Column PGText)
(Column PGBool) (Column PGBool)
(Column PGTimestamptz)
type UserRead = UserPoly (Column PGInt4) (Column PGText)
(Column PGTimestamptz) (Column PGBool)
(Column PGText) (Column PGText)
(Column PGText) (Column PGText)
(Column PGBool) (Column PGBool)
(Column PGTimestamptz)
type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
$(makeAdaptorAndInstance "pUser" ''UserPoly)
$(makeLensesWith abbreviatedFields ''UserPoly)
userTable :: Table UserWrite UserRead
userTable = Table "auth_user" (pUser User { user_id = optional "id"
, user_password = required "password"
, user_lastLogin = optional "last_login"
, user_isSuperUser = required "is_superuser"
, user_username = required "username"
, user_firstName = required "first_name"
, user_lastName = required "last_name"
, user_email = required "email"
, user_isStaff = required "is_staff"
, user_isActive = required "is_active"
, user_dateJoined = required "date_joined"
}
)
------------------------------------------------------------------
queryUserTable :: Query UserRead
queryUserTable = queryTable userTable
selectUsersLight :: Query UserRead
selectUsersLight = proc () -> do
row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
restrict -< i .== 1
--returnA -< User i p ll is un fn ln m iff ive dj
returnA -< row
------------------------------------------------------------------
-- | 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 -> [User] -> Maybe User
userWithUsername t xs = userWith user_username t xs
userWithId :: Int -> [User] -> Maybe User
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
instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
queryRunnerColumnDefault = fieldQueryRunnerColumn
users :: Cmd [User]
users = mkCmd $ \conn -> runQuery conn queryUserTable
usersLight :: Cmd [UserLight]
usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
type Username = Text
getUser :: Username -> Cmd (Maybe UserLight)
getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight