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