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