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