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