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 -> runInsert_ c insert
 119   where
 120     insert = Insert userTable us rCount Nothing
 121
 122
 123 gargantextUser :: Username -> UserWrite
 124 gargantextUser u = User (Nothing) (pgStrictText "password")
 125                          (Nothing) (pgBool True) (pgStrictText u)
 126                          (pgStrictText "first_name")
 127                          (pgStrictText "last_name")
 128                          (pgStrictText "e@mail")
 129                          (pgBool True) (pgBool True) (Nothing)
 130
 131 insertUsersDemo :: Cmd err Int64
 132 insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
 133
 134
 135 ------------------------------------------------------------------
 136 queryUserTable :: Query UserRead
 137 queryUserTable = queryTable userTable
 138
 139 selectUsersLight :: Query UserRead
 140 selectUsersLight = proc () -> do
 141       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 142       restrict -< i .== 1
 143       --returnA -< User i p ll is un fn ln m iff ive dj
 144       returnA -< row
 145 ------------------------------------------------------------------
 146 -- | Select User with some parameters
 147 -- Not optimized version
 148 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 149 userWith f t xs = find (\x -> f x == t) xs
 150
 151 -- | Select User with Username
 152 userWithUsername :: Text -> [User] -> Maybe User
 153 userWithUsername t xs = userWith user_username t xs
 154
 155 userWithId :: Int -> [User] -> Maybe User
 156 userWithId t xs = userWith user_id t xs
 157
 158 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 159 userLightWithUsername t xs = userWith userLight_username t xs
 160
 161 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 162 userLightWithId t xs = userWith userLight_id t xs
 163
 164
 165 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 166   queryRunnerColumnDefault = fieldQueryRunnerColumn
 167
 168
 169 users :: Cmd err [User]
 170 users = runOpaQuery queryUserTable
 171
 172 usersLight :: Cmd err [UserLight]
 173 usersLight = map toUserLight <$> users
 174
 175 getUser :: Username -> Cmd err (Maybe UserLight)
 176 getUser u = userLightWithUsername u <$> usersLight
 177
 178