src/Gargantext/Database/User.hs

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