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