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