src/Gargantext/Database/User.hs

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