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 {-# LANGUAGE OverloadedStrings           #-}
  23 {-# LANGUAGE RankNTypes                  #-}
  24
  25 module Gargantext.Database.Schema.User where
  26
  27 import Control.Arrow (returnA)
  28 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  29 import Data.Eq(Eq(..))
  30 import Data.List (find)
  31 import Data.Maybe (Maybe)
  32 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  33 import Data.Text (Text)
  34 import Data.Time (UTCTime)
  35 import GHC.Show(Show(..))
  36 import Gargantext.Core.Types.Individu (Username, arbitraryUsername)
  37 import Gargantext.Database.Utils
  38 import Gargantext.Prelude
  39 import Opaleye
  40
  41 ------------------------------------------------------------------------
  42
  43 ------------------------------------------------------------------------
  44 type UserId = Int
  45
  46 data UserLight = UserLight { userLight_id   :: Int
  47                            , userLight_username :: Text
  48                            , userLight_email    :: Text
  49                            } deriving (Show)
  50
  51 toUserLight :: User -> UserLight
  52 toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
  53
  54 data UserPoly id pass llogin suser
  55               uname fname lname
  56               mail staff active djoined = User { user_id          :: id
  57                                                , user_password    :: pass
  58                                                , user_lastLogin   :: llogin
  59                                                , user_isSuperUser :: suser
  60
  61                                                , user_username    :: uname
  62                                                , user_firstName   :: fname
  63                                                , user_lastName    :: lname
  64                                                , user_email       :: mail
  65
  66                                                , user_isStaff     :: staff
  67                                                , user_isActive    :: active
  68                                                , user_dateJoined  :: djoined
  69                                                } deriving (Show)
  70
  71 type UserWrite = UserPoly (Maybe (Column PGInt4))        (Column PGText)
  72                           (Maybe (Column PGTimestamptz)) (Column PGBool)
  73                                  (Column PGText)         (Column PGText)
  74                                  (Column PGText)         (Column PGText)
  75                                  (Column PGBool)         (Column PGBool)
  76                                  (Maybe (Column PGTimestamptz))
  77
  78 type UserRead  = UserPoly        (Column PGInt4)         (Column PGText)
  79                                  (Column PGTimestamptz)  (Column PGBool)
  80                                  (Column PGText)         (Column PGText)
  81                                  (Column PGText)         (Column PGText)
  82                                  (Column PGBool)         (Column PGBool)
  83                                  (Column PGTimestamptz)
  84
  85 type UserReadNull = UserPoly     (Column (Nullable PGInt4))         (Column (Nullable PGText))
  86                                  (Column (Nullable PGTimestamptz))  (Column (Nullable PGBool))
  87                                  (Column (Nullable PGText))         (Column (Nullable PGText))
  88                                  (Column (Nullable PGText))         (Column (Nullable PGText))
  89                                  (Column (Nullable PGBool))         (Column (Nullable PGBool))
  90                                  (Column (Nullable PGTimestamptz))
  91
  92
  93
  94
  95 type User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  96
  97 $(makeAdaptorAndInstance "pUser"     ''UserPoly)
  98 $(makeLensesWith abbreviatedFields   ''UserPoly)
  99
 100
 101 userTable :: Table UserWrite UserRead
 102 userTable = Table "auth_user" (pUser User { user_id      = optional "id"
 103                                           , user_password    = required "password"
 104                                           , user_lastLogin   = optional "last_login"
 105                                           , user_isSuperUser = required "is_superuser"
 106                                           , user_username    = required "username"
 107                                           , user_firstName   = required "first_name"
 108                                           , user_lastName    = required "last_name"
 109                                           , user_email       = required "email"
 110                                           , user_isStaff     = required "is_staff"
 111                                           , user_isActive    = required "is_active"
 112                                           , user_dateJoined  = optional "date_joined"
 113                                           }
 114                               )
 115
 116 -- TODO: on conflict, nice message
 117 insertUsers :: [UserWrite] -> Cmd err Int64
 118 insertUsers us = mkCmd $ \c -> runInsertMany c userTable us
 119
 120
 121 gargantextUser :: Username -> UserWrite
 122 gargantextUser u = User (Nothing) (pgStrictText "password")
 123                          (Nothing) (pgBool True) (pgStrictText u)
 124                          (pgStrictText "first_name")
 125                          (pgStrictText "last_name")
 126                          (pgStrictText "e@mail")
 127                          (pgBool True) (pgBool True) (Nothing)
 128
 129 insertUsersDemo :: Cmd err Int64
 130 insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
 131
 132
 133 ------------------------------------------------------------------
 134 queryUserTable :: Query UserRead
 135 queryUserTable = queryTable userTable
 136
 137 selectUsersLight :: Query UserRead
 138 selectUsersLight = proc () -> do
 139       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 140       restrict -< i .== 1
 141       --returnA -< User i p ll is un fn ln m iff ive dj
 142       returnA -< row
 143 ------------------------------------------------------------------
 144 -- | Select User with some parameters
 145 -- Not optimized version
 146 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 147 userWith f t xs = find (\x -> f x == t) xs
 148
 149 -- | Select User with Username
 150 userWithUsername :: Text -> [User] -> Maybe User
 151 userWithUsername t xs = userWith user_username t xs
 152
 153 userWithId :: Int -> [User] -> Maybe User
 154 userWithId t xs = userWith user_id t xs
 155
 156 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 157 userLightWithUsername t xs = userWith userLight_username t xs
 158
 159 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 160 userLightWithId t xs = userWith userLight_id t xs
 161
 162
 163 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 164   queryRunnerColumnDefault = fieldQueryRunnerColumn
 165
 166
 167 users :: Cmd err [User]
 168 users = runOpaQuery queryUserTable
 169
 170 usersLight :: Cmd err [UserLight]
 171 usersLight = map toUserLight <$> users
 172
 173 getUser :: Username -> Cmd err (Maybe UserLight)
 174 getUser u = userLightWithUsername u <$> usersLight
 175
 176