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
  14 {-# OPTIONS_GHC -fno-warn-orphans        #-}
  15
  16 {-# LANGUAGE DeriveAnyClass              #-}
  17 {-# LANGUAGE FunctionalDependencies      #-}
  18 {-# LANGUAGE Arrows                      #-}
  19 {-# LANGUAGE TemplateHaskell             #-}
  20
  21 module Gargantext.Database.Schema.User where
  22
  23 import Data.Morpheus.Types (GQLType(typeOptions))
  24 import Data.Text (Text)
  25 import Data.Time (UTCTime)
  26 import qualified Gargantext.API.GraphQL.Utils as GAGU
  27 import Gargantext.Core.Utils.Prefix (unPrefix)
  28 import Gargantext.Core.Types.Individu (GargPassword, toGargPassword)
  29 import Gargantext.Database.Prelude (fromField')
  30 import Gargantext.Prelude
  31 import GHC.Generics (Generic)
  32 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  33 import Data.Aeson.TH (deriveJSON)
  34
  35 -- FIXME PLZ : the import below leads to an error, why ?
  36 -- import Gargantext.Database.Schema.Prelude hiding (makeLensesWith, abbreviatedFields, makeAdaptorAndInstance)
  37
  38 -- When FIXED : Imports to remove:
  39 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  40 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  41 import Opaleye hiding (FromField)
  42 import Opaleye.Internal.Table (Table(..))
  43 ------------------------------------------------------------------------
  44 data UserLight = UserLight { userLight_id       :: !Int
  45                            , userLight_username :: !Text
  46                            , userLight_email    :: !Text
  47                            , userLight_password :: !GargPassword
  48                            } deriving (Show, Generic)
  49
  50 instance GQLType UserLight where
  51   typeOptions _ = GAGU.unPrefix "userLight_"
  52
  53 toUserLight :: UserDB -> UserLight
  54 toUserLight (UserDB id p _ _ u _ _ e _ _ _ ) = UserLight id u e (toGargPassword p)
  55
  56
  57 data UserPoly id pass llogin suser
  58               uname fname lname
  59               mail staff active djoined =
  60     UserDB { user_id          :: !id
  61            , user_password    :: !pass
  62            , user_lastLogin   :: !llogin
  63            , user_isSuperUser :: !suser
  64
  65            , user_username    :: !uname
  66            , user_firstName   :: !fname
  67            , user_lastName    :: !lname
  68            , user_email       :: !mail
  69
  70            , user_isStaff     :: !staff
  71            , user_isActive    :: !active
  72            , user_dateJoined  :: !djoined
  73            } deriving (Show, Generic)
  74
  75
  76 type UserWrite = UserPoly (Maybe (Column SqlInt4))        (Column SqlText)
  77                           (Maybe (Column SqlTimestamptz)) (Column SqlBool)
  78                                  (Column SqlText)         (Column SqlText)
  79                                  (Column SqlText)         (Column SqlText)
  80                                  (Column SqlBool)         (Column SqlBool)
  81                                  (Maybe (Column SqlTimestamptz))
  82
  83 type UserRead  = UserPoly        (Column SqlInt4)         (Column SqlText)
  84                                  (Column SqlTimestamptz)  (Column SqlBool)
  85                                  (Column SqlText)         (Column SqlText)
  86                                  (Column SqlText)         (Column SqlText)
  87                                  (Column SqlBool)         (Column SqlBool)
  88                                  (Column SqlTimestamptz)
  89
  90 type UserReadNull = UserPoly     (Column (Nullable SqlInt4))         (Column (Nullable SqlText))
  91                                  (Column (Nullable SqlTimestamptz))  (Column (Nullable SqlBool))
  92                                  (Column (Nullable SqlText))         (Column (Nullable SqlText))
  93                                  (Column (Nullable SqlText))         (Column (Nullable SqlText))
  94                                  (Column (Nullable SqlBool))         (Column (Nullable SqlBool))
  95                                  (Column (Nullable SqlTimestamptz))
  96
  97 type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  98
  99 $(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
 100 $(makeLensesWith abbreviatedFields   ''UserPoly)
 101
 102 userTable :: Table UserWrite UserRead
 103 userTable = Table "auth_user"
 104   (pUserDB UserDB { user_id      = optionalTableField "id"
 105                   , user_password    = requiredTableField "password"
 106                   , user_lastLogin   = optionalTableField "last_login"
 107                   , user_isSuperUser = requiredTableField "is_superuser"
 108                   , user_username    = requiredTableField "username"
 109                   , user_firstName   = requiredTableField "first_name"
 110                   , user_lastName    = requiredTableField "last_name"
 111                   , user_email       = requiredTableField "email"
 112                   , user_isStaff     = requiredTableField "is_staff"
 113                   , user_isActive    = requiredTableField "is_active"
 114                   , user_dateJoined  = optionalTableField "date_joined"
 115                   }
 116       )
 117
 118 instance FromField UserLight where
 119   fromField = fromField'
 120
 121 instance FromField UserDB where
 122   fromField = fromField'
 123
 124 $(deriveJSON (unPrefix "userLight_") ''UserLight)
 125 $(deriveJSON (unPrefix "user_") ''UserPoly)