src/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 Gargantext.Database.User where
  11
  12 import Prelude
  13 import 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 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