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