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 FlexibleContexts            #-}
  18 {-# LANGUAGE FlexibleInstances           #-}
  19 {-# LANGUAGE MultiParamTypeClasses       #-}
  20 {-# LANGUAGE FunctionalDependencies      #-}
  21 {-# LANGUAGE Arrows                      #-}
  22 {-# LANGUAGE NoImplicitPrelude           #-}
  23 {-# LANGUAGE OverloadedStrings           #-}
  24 {-# LANGUAGE RankNTypes                  #-}
  25
  26 module Gargantext.Database.Schema.User where
  27
  28 import Control.Arrow (returnA)
  29 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  30 import Data.Eq(Eq(..))
  31 import Data.List (find)
  32 import Data.Maybe (Maybe)
  33 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  34 import Data.Text (Text)
  35 import Data.Time (UTCTime)
  36 import GHC.Show(Show(..))
  37 import Gargantext.Core.Types.Individu (Username, arbitraryUsername, User(..), UserId)
  38 import Gargantext.Database.Types.Errors
  39 import Gargantext.Database.Utils
  40 import Gargantext.Prelude
  41 import Opaleye
  42
  43 ------------------------------------------------------------------------
  44 ------------------------------------------------------------------------
  45
  46 data UserLight = UserLight { userLight_id   :: Int
  47                            , userLight_username :: Text
  48                            , userLight_email    :: Text
  49                            } deriving (Show)
  50
  51 toUserLight :: UserDB -> UserLight
  52 toUserLight (UserDB id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
  53
  54 data UserPoly id pass llogin suser
  55               uname fname lname
  56               mail staff active djoined = UserDB { 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 UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  96
  97 $(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
  98 $(makeLensesWith abbreviatedFields   ''UserPoly)
  99
 100
 101 userTable :: Table UserWrite UserRead
 102 userTable = Table "auth_user" (pUserDB UserDB { 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 = UserDB (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 queryUserTable :: Query UserRead
 136 queryUserTable = queryTable userTable
 137
 138 selectUsersLight :: Query UserRead
 139 selectUsersLight = proc () -> do
 140       row@(UserDB i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 141       restrict -< i .== 1
 142       --returnA -< User i p ll is un fn ln m iff ive dj
 143       returnA -< row
 144 ------------------------------------------------------------------
 145 -- | Select User with some parameters
 146 -- Not optimized version
 147 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 148 userWith f t xs = find (\x -> f x == t) xs
 149
 150 -- | Select User with Username
 151 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
 152 userWithUsername t xs = userWith user_username t xs
 153
 154 userWithId :: Int -> [UserDB] -> Maybe UserDB
 155 userWithId t xs = userWith user_id t xs
 156
 157 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 158 userLightWithUsername t xs = userWith userLight_username t xs
 159
 160 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 161 userLightWithId t xs = userWith userLight_id t xs
 162
 163
 164 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 165   queryRunnerColumnDefault = fieldQueryRunnerColumn
 166
 167
 168 users :: Cmd err [UserDB]
 169 users = runOpaQuery queryUserTable
 170
 171 usersLight :: Cmd err [UserLight]
 172 usersLight = map toUserLight <$> users
 173
 174 getUser :: Username -> Cmd err (Maybe UserLight)
 175 getUser u = userLightWithUsername u <$> usersLight
 176
 177
 178 getUserId :: HasNodeError err
 179           => User
 180           -> Cmd err UserId
 181 getUserId (UserDBId uid) = pure uid
 182 getUserId (UserName u  ) = do
 183   muser <- getUser u
 184   case muser of
 185     Just user -> pure $ userLight_id user
 186     Nothing   -> nodeError NoUserFound
 187
 188