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