src/Gargantext/Database/Schema/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 {-# LANGUAGE TemplateHaskell             #-}
  17 {-# LANGUAGE FlexibleInstances           #-}
  18 {-# LANGUAGE MultiParamTypeClasses       #-}
  19 {-# LANGUAGE FunctionalDependencies      #-}
  20 {-# LANGUAGE Arrows                      #-}
  21 {-# LANGUAGE NoImplicitPrelude           #-}
  22
  23 module Gargantext.Database.Schema.User where
  24
  25 import Control.Arrow (returnA)
  26 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  27 import Data.Eq(Eq(..))
  28 import Data.List (find)
  29 import Data.Maybe (Maybe)
  30 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  31 import Data.Text (Text)
  32 import Data.Time (UTCTime)
  33 import GHC.Show(Show(..))
  34 import Gargantext.Core.Types.Individu (Username)
  35 import Gargantext.Database.Utils
  36 import Gargantext.Prelude
  37 import Opaleye
  38
  39 ------------------------------------------------------------------------
  40 type UserId = Int
  41
  42
  43 data UserLight = UserLight { userLight_id   :: Int
  44                            , userLight_username :: Text
  45                            , userLight_email    :: Text
  46                            } deriving (Show)
  47
  48 toUserLight :: User -> UserLight
  49 toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
  50
  51 data UserPoly id pass llogin suser
  52               uname fname lname
  53               mail staff active djoined = User { user_id          :: id
  54                                                , user_password    :: pass
  55                                                , user_lastLogin   :: llogin
  56                                                , user_isSuperUser :: suser
  57
  58                                                , user_username    :: uname
  59                                                , user_firstName   :: fname
  60                                                , user_lastName    :: lname
  61                                                , user_email       :: mail
  62
  63                                                , user_isStaff     :: staff
  64                                                , user_isActive    :: active
  65                                                , user_dateJoined  :: djoined
  66                                                } deriving (Show)
  67
  68 type UserWrite = UserPoly (Maybe (Column PGInt4))        (Column PGText)
  69                           (Maybe (Column PGTimestamptz)) (Column PGBool)
  70                                  (Column PGText)         (Column PGText)
  71                                  (Column PGText)         (Column PGText)
  72                                  (Column PGBool)         (Column PGBool)
  73                                  (Column PGTimestamptz)
  74
  75 type UserRead  = UserPoly        (Column PGInt4)         (Column PGText)
  76                                  (Column PGTimestamptz)  (Column PGBool)
  77                                  (Column PGText)         (Column PGText)
  78                                  (Column PGText)         (Column PGText)
  79                                  (Column PGBool)         (Column PGBool)
  80                                  (Column PGTimestamptz)
  81
  82 type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  83
  84 $(makeAdaptorAndInstance "pUser"     ''UserPoly)
  85 $(makeLensesWith abbreviatedFields   ''UserPoly)
  86
  87
  88 userTable :: Table UserWrite UserRead
  89 userTable = Table "auth_user" (pUser User { user_id      = optional "id"
  90                                           , user_password    = required "password"
  91                                           , user_lastLogin   = optional "last_login"
  92                                           , user_isSuperUser = required "is_superuser"
  93                                           , user_username    = required "username"
  94                                           , user_firstName   = required "first_name"
  95                                           , user_lastName    = required "last_name"
  96                                           , user_email       = required "email"
  97                                           , user_isStaff     = required "is_staff"
  98                                           , user_isActive    = required "is_active"
  99                                           , user_dateJoined  = required "date_joined"
 100                                           }
 101                               )
 102
 103 ------------------------------------------------------------------
 104 queryUserTable :: Query UserRead
 105 queryUserTable = queryTable userTable
 106
 107 selectUsersLight :: Query UserRead
 108 selectUsersLight = proc () -> do
 109       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 110       restrict -< i .== 1
 111       --returnA -< User i p ll is un fn ln m iff ive dj
 112       returnA -< row
 113 ------------------------------------------------------------------
 114 -- | Select User with some parameters
 115 -- Not optimized version
 116 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 117 userWith f t xs = find (\x -> f x == t) xs
 118
 119 -- | Select User with Username
 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 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 127 userLightWithUsername t xs = userWith userLight_username t xs
 128
 129 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 130 userLightWithId t xs = userWith userLight_id t xs
 131
 132
 133 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 134   queryRunnerColumnDefault = fieldQueryRunnerColumn
 135
 136
 137 users :: Cmd [User]
 138 users = mkCmd $ \conn -> runQuery conn queryUserTable
 139
 140 usersLight :: Cmd [UserLight]
 141 usersLight = mkCmd $ \conn -> map toUserLight <$> runQuery conn queryUserTable
 142
 143
 144 getUser :: Username -> Cmd (Maybe UserLight)
 145 getUser u = mkCmd $ \c -> userLightWithUsername u <$> runCmd c usersLight
 146
 147
 148