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