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