src/Data/Gargantext/Database/User.hs

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