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                            , userLight_forgot_password_uuid :: !(Maybe Text)
  49                            } deriving (Show, Generic)
  50 instance GQLType UserLight where
  51   typeOptions _ = GAGU.unPrefix "userLight_"
  52
  53 toUserLight :: UserDB -> UserLight
  54 toUserLight (UserDB { user_id
  55                     , user_password
  56                     , user_username
  57                     , user_email }) = UserLight { userLight_id = user_id
  58                                                 , userLight_username = user_username
  59                                                 , userLight_email = user_email
  60                                                 , userLight_password = toGargPassword user_password
  61                                                 , userLight_forgot_password_uuid = Nothing }
  62
  63
  64 data UserPoly id pass llogin suser
  65               uname fname lname
  66               mail staff active djoined
  67               fpuuid =
  68     UserDB { user_id                   :: !id
  69            , user_password             :: !pass
  70            , user_lastLogin            :: !llogin
  71            , user_isSuperUser          :: !suser
  72
  73            , user_username             :: !uname
  74            , user_firstName            :: !fname
  75            , user_lastName             :: !lname
  76            , user_email                :: !mail
  77
  78            , user_isStaff              :: !staff
  79            , user_isActive             :: !active
  80            , user_dateJoined           :: !djoined
  81
  82            , user_forgot_password_uuid :: !fpuuid
  83            } deriving (Show, Generic)
  84
  85
  86 type UserWrite = UserPoly (Maybe (Column SqlInt4))        (Column SqlText)
  87                           (Maybe (Column SqlTimestamptz)) (Column SqlBool)
  88                                  (Column SqlText)         (Column SqlText)
  89                                  (Column SqlText)         (Column SqlText)
  90                                  (Column SqlBool)         (Column SqlBool)
  91                                  (Maybe (Column SqlTimestamptz))
  92                                  (Maybe (Column SqlText))
  93
  94 type UserRead  = UserPoly        (Column SqlInt4)         (Column SqlText)
  95                                  (Column SqlTimestamptz)  (Column SqlBool)
  96                                  (Column SqlText)         (Column SqlText)
  97                                  (Column SqlText)         (Column SqlText)
  98                                  (Column SqlBool)         (Column SqlBool)
  99                                  (Column SqlTimestamptz)
 100                                  (Column SqlText)
 101
 102 type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime (Maybe Text)
 103
 104 $(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
 105 $(makeLensesWith abbreviatedFields   ''UserPoly)
 106
 107 userTable :: Table UserWrite UserRead
 108 userTable = Table "auth_user"
 109   (pUserDB UserDB { user_id                   = optionalTableField "id"
 110                   , user_password             = requiredTableField "password"
 111                   , user_lastLogin            = optionalTableField "last_login"
 112                   , user_isSuperUser          = requiredTableField "is_superuser"
 113                   , user_username             = requiredTableField "username"
 114                   , user_firstName            = requiredTableField "first_name"
 115                   , user_lastName             = requiredTableField "last_name"
 116                   , user_email                = requiredTableField "email"
 117                   , user_isStaff              = requiredTableField "is_staff"
 118                   , user_isActive             = requiredTableField "is_active"
 119                   , user_dateJoined           = optionalTableField "date_joined"
 120                   , user_forgot_password_uuid = optionalTableField "forgot_password_uuid"
 121                   }
 122       )
 123
 124 instance FromField UserLight where
 125   fromField = fromField'
 126
 127 instance FromField UserDB where
 128   fromField = fromField'
 129
 130 $(deriveJSON (unPrefix "userLight_") ''UserLight)
 131 $(deriveJSON (unPrefix "user_") ''UserPoly)