]> Git — Sourcephile - gargantext.git/blob - src/Gargantext/Database/User.hs
[FEAT] Syntactic convention (proposition to be discussed).
[gargantext.git] / src / Gargantext / Database / User.hs
1 {-|
2 Module : Gargantext.Database.user
3 Description :
4 Copyright : (c) CNRS, 2017-Present
5 License : AGPL + CECILL v3
6 Maintainer : team@gargantext.org
7 Stability : experimental
8 Portability : POSIX
9
10 Here is a longer description of this module, containing some
11 commentary with @some markup@.
12 -}
13
14 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
15 {-# OPTIONS_GHC -fno-warn-orphans #-}
16
17
18 {-# LANGUAGE TemplateHaskell #-}
19 {-# LANGUAGE FlexibleInstances #-}
20 {-# LANGUAGE MultiParamTypeClasses #-}
21 {-# LANGUAGE FunctionalDependencies #-}
22 {-# LANGUAGE Arrows #-}
23 {-# LANGUAGE NoImplicitPrelude #-}
24
25 module Gargantext.Database.User where
26
27 import Gargantext.Prelude
28 import GHC.Show(Show(..))
29 import Data.Eq(Eq(..))
30 import Data.Time (UTCTime)
31 import Data.Text (Text)
32 import Data.Maybe (Maybe)
33 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
34 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
35 import Control.Arrow (returnA)
36 import qualified Database.PostgreSQL.Simple as PGS
37
38 import Opaleye
39
40 -- Functions only
41 import Data.List (find)
42
43
44 data UserLight = UserLight { userLight_id :: Int
45 , userLight_username :: Text
46 , userLight_email :: Text
47 } deriving (Show)
48
49 toUserLight :: User -> UserLight
50 toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
51
52 data UserPoly id pass llogin suser
53 uname fname lname
54 mail staff active djoined = User { user_id :: id
55 , user_password :: pass
56 , user_lastLogin :: llogin
57 , user_isSuperUser :: suser
58
59 , user_username :: uname
60 , user_firstName :: fname
61 , user_lastName :: lname
62 , user_email :: mail
63
64 , user_isStaff :: staff
65 , user_isActive :: active
66 , user_dateJoined :: djoined
67 } deriving (Show)
68
69 type UserWrite = UserPoly (Maybe (Column PGInt4)) (Column PGText)
70 (Maybe (Column PGTimestamptz)) (Column PGBool)
71 (Column PGText) (Column PGText)
72 (Column PGText) (Column PGText)
73 (Column PGBool) (Column PGBool)
74 (Column PGTimestamptz)
75
76 type UserRead = UserPoly (Column PGInt4) (Column PGText)
77 (Column PGTimestamptz) (Column PGBool)
78 (Column PGText) (Column PGText)
79 (Column PGText) (Column PGText)
80 (Column PGBool) (Column PGBool)
81 (Column PGTimestamptz)
82
83 type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
84
85 $(makeAdaptorAndInstance "pUser" ''UserPoly)
86 $(makeLensesWith abbreviatedFields ''UserPoly)
87
88
89 userTable :: Table UserWrite UserRead
90 userTable = Table "auth_user" (pUser User { user_id = optional "id"
91 , user_password = required "password"
92 , user_lastLogin = optional "last_login"
93 , user_isSuperUser = required "is_superuser"
94 , user_username = required "username"
95 , user_firstName = required "first_name"
96 , user_lastName = required "last_name"
97 , user_email = required "email"
98 , user_isStaff = required "is_staff"
99 , user_isActive = required "is_active"
100 , user_dateJoined = required "date_joined"
101 }
102 )
103
104
105 queryUserTable :: Query UserRead
106 queryUserTable = queryTable userTable
107
108
109 selectUsersLight :: Query UserRead
110 selectUsersLight = proc () -> do
111 row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
112 restrict -< i .== 1
113 --returnA -< User i p ll is un fn ln m iff ive dj
114 returnA -< row
115
116
117 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
118 userWith f t xs = find (\x -> f x == t) xs
119
120 userWithUsername :: Text -> [User] -> Maybe User
121 userWithUsername t xs = userWith user_username t xs
122
123 userWithId :: Int -> [User] -> Maybe User
124 userWithId t xs = userWith user_id t xs
125
126 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
127 queryRunnerColumnDefault = fieldQueryRunnerColumn
128
129
130 users :: PGS.Connection -> IO [User]
131 users conn = runQuery conn queryUserTable
132
133 usersLight :: PGS.Connection -> IO [UserLight]
134 usersLight conn = map toUserLight <$> runQuery conn queryUserTable