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