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