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 import Gargantext.Database.Private (infoGargandb)
  26
  27 -- Functions only
  28 import Data.List (find)
  29
  30
  31 data UserLight = UserLight { userLight_id   :: Int
  32                            , userLight_username :: Text
  33                            , userLight_email    :: Text
  34                            } deriving (Show)
  35
  36 toUserLight :: User -> UserLight
  37 toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
  38
  39 data UserPoly id pass llogin suser
  40               uname fname lname
  41               mail staff active djoined = User { user_id          :: id
  42                                                , user_password    :: pass
  43                                                , user_lastLogin   :: llogin
  44                                                , user_isSuperUser :: suser
  45
  46                                                , user_username    :: uname
  47                                                , user_firstName   :: fname
  48                                                , user_lastName    :: lname
  49                                                , user_email       :: mail
  50
  51                                                , user_isStaff     :: staff
  52                                                , user_isActive    :: active
  53                                                , user_dateJoined  :: djoined
  54                                                } deriving (Show)
  55
  56 type UserWrite = UserPoly (Maybe (Column PGInt4))        (Column PGText)
  57                           (Maybe (Column PGTimestamptz)) (Column PGBool)
  58                                  (Column PGText)         (Column PGText)
  59                                  (Column PGText)         (Column PGText)
  60                                  (Column PGBool)         (Column PGBool)
  61                                  (Column PGTimestamptz)
  62
  63 type UserRead  = UserPoly        (Column PGInt4)         (Column PGText)
  64                                  (Column PGTimestamptz)  (Column PGBool)
  65                                  (Column PGText)         (Column PGText)
  66                                  (Column PGText)         (Column PGText)
  67                                  (Column PGBool)         (Column PGBool)
  68                                  (Column PGTimestamptz)
  69
  70 type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  71
  72 $(makeAdaptorAndInstance "pUser"     ''UserPoly)
  73 $(makeLensesWith abbreviatedFields   ''UserPoly)
  74
  75
  76 userTable :: Table UserWrite UserRead
  77 userTable = Table "auth_user" (pUser User { user_id      = optional "id"
  78                                           , user_password    = required "password"
  79                                           , user_lastLogin   = optional "last_login"
  80                                           , user_isSuperUser = required "is_superuser"
  81                                           , user_username    = required "username"
  82                                           , user_firstName   = required "first_name"
  83                                           , user_lastName    = required "last_name"
  84                                           , user_email       = required "email"
  85                                           , user_isStaff     = required "is_staff"
  86                                           , user_isActive    = required "is_active"
  87                                           , user_dateJoined  = required "date_joined"
  88                                           }
  89                               )
  90
  91
  92 queryUserTable :: Query UserRead
  93 queryUserTable = queryTable userTable
  94
  95
  96 selectUsersLight :: Query UserRead
  97 selectUsersLight = proc () -> do
  98       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
  99       restrict -< i .== 1
 100       --returnA -< User i p ll is un fn ln m iff ive dj
 101       returnA -< row
 102
 103
 104 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 105 userWith f t xs = find (\x -> f x == t) xs
 106
 107 userWithUsername :: Text -> [User] -> Maybe User
 108 userWithUsername t xs = userWith user_username t xs
 109
 110 userWithId :: Int -> [User] -> Maybe User
 111 userWithId t xs = userWith user_id t xs
 112
 113 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 114   queryRunnerColumnDefault = fieldQueryRunnerColumn
 115
 116
 117 users :: IO [User]
 118 users = do
 119     conn <- PGS.connect infoGargandb
 120     runQuery conn queryUserTable
 121
 122 usersLight :: IO [UserLight]
 123 usersLight = do
 124     conn <- PGS.connect infoGargandb
 125     map toUserLight <$> runQuery conn queryUserTable