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)
  24 import Data.Text (Text)
  25 import Data.Time (UTCTime)
  26 import Gargantext.Prelude
  27 import GHC.Generics (Generic)
  28 import Database.PostgreSQL.Simple.FromField (FromField, fromField)
  29 import Data.Aeson.TH (deriveJSON)
  30 import Gargantext.Database.Prelude (fromField')
  31 import Gargantext.Core.Utils.Prefix (unPrefix)
  32
  33 -- FIXME PLZ : the import below leads to an error, why ?
  34 -- import Gargantext.Database.Schema.Prelude hiding (makeLensesWith, abbreviatedFields, makeAdaptorAndInstance)
  35
  36 -- When FIXED : Imports to remove:
  37 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  38 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  39 import Opaleye hiding (FromField)
  40
  41 ------------------------------------------------------------------------
  42 data UserLight = UserLight { userLight_id       :: !Int
  43                            , userLight_username :: !Text
  44                            , userLight_email    :: !Text
  45                            , userLight_password :: !Text
  46                            } deriving (Show, Generic, GQLType)
  47
  48 toUserLight :: UserDB -> UserLight
  49 toUserLight (UserDB id p _ _ u _ _ e _ _ _ ) = UserLight id u e p
  50
  51
  52 data UserPoly id pass llogin suser
  53               uname fname lname
  54               mail staff active djoined =
  55     UserDB { 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, Generic)
  69
  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 type UserDB = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  93
  94 $(makeAdaptorAndInstance "pUserDB"   ''UserPoly)
  95 $(makeLensesWith abbreviatedFields   ''UserPoly)
  96
  97 userTable :: Table UserWrite UserRead
  98 userTable = Table "auth_user"
  99   (pUserDB UserDB { user_id      = optionalTableField "id"
 100                   , user_password    = requiredTableField "password"
 101                   , user_lastLogin   = optionalTableField "last_login"
 102                   , user_isSuperUser = requiredTableField "is_superuser"
 103                   , user_username    = requiredTableField "username"
 104                   , user_firstName   = requiredTableField "first_name"
 105                   , user_lastName    = requiredTableField "last_name"
 106                   , user_email       = requiredTableField "email"
 107                   , user_isStaff     = requiredTableField "is_staff"
 108                   , user_isActive    = requiredTableField "is_active"
 109                   , user_dateJoined  = optionalTableField "date_joined"
 110                   }
 111       )
 112
 113 instance FromField UserLight where
 114   fromField = fromField'
 115
 116 instance FromField UserDB where
 117   fromField = fromField'
 118
 119 $(deriveJSON (unPrefix "userLight_") ''UserLight)
 120 $(deriveJSON (unPrefix "user_") ''UserPoly)