src/Gargantext/Database/User.hs

   1 {-|
   2 Module      : Gargantext.Database.user
   3 Description : User Database management tools
   4 Copyright   : (c) CNRS, 2017-Present
   5 License     : AGPL + CECILL v3
   6 Maintainer  : team@gargantext.org
   7 Stability   : experimental
   8 Portability : POSIX
   9
  10 Functions to deal with users, database side.
  11 -}
  12
  13 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  14 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  15
  16
  17 {-# LANGUAGE TemplateHaskell             #-}
  18 {-# LANGUAGE FlexibleInstances           #-}
  19 {-# LANGUAGE MultiParamTypeClasses       #-}
  20 {-# LANGUAGE FunctionalDependencies      #-}
  21 {-# LANGUAGE Arrows                      #-}
  22 {-# LANGUAGE NoImplicitPrelude           #-}
  23
  24 module Gargantext.Database.User where
  25
  26 import GHC.Show(Show(..))
  27 import Data.Eq(Eq(..))
  28 import Data.Time (UTCTime)
  29 import Data.Text (Text)
  30 import Data.Maybe (Maybe)
  31 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  32 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  33 import Control.Arrow (returnA)
  34 import qualified Database.PostgreSQL.Simple as PGS
  35
  36 import Opaleye
  37
  38 -- Functions only
  39 import Data.List (find)
  40
  41 import Gargantext.Prelude
  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 selectUsersLight :: Query UserRead
 109 selectUsersLight = proc () -> do
 110       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 111       restrict -< i .== 1
 112       --returnA -< User i p ll is un fn ln m iff ive dj
 113       returnA -< row
 114 ------------------------------------------------------------------
 115 -- | Select User with some parameters
 116 -- Not optimized version
 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 -- | Select User with Username
 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 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 128 userLightWithUsername t xs = userWith userLight_username t xs
 129
 130 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 131 userLightWithId t xs = userWith userLight_id t xs
 132
 133
 134 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 135   queryRunnerColumnDefault = fieldQueryRunnerColumn
 136
 137
 138 users :: PGS.Connection -> IO [User]
 139 users conn = runQuery conn queryUserTable
 140
 141 usersLight :: PGS.Connection -> IO [UserLight]
 142 usersLight conn = map toUserLight <$> runQuery conn queryUserTable
 143
 144 type Username = Text
 145
 146 user :: PGS.Connection -> Username -> IO (Maybe UserLight)
 147 user c u = userLightWithUsername u <$> usersLight c
 148