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 FlexibleInstances           #-}
  18 {-# LANGUAGE MultiParamTypeClasses       #-}
  19 {-# LANGUAGE FunctionalDependencies      #-}
  20 {-# LANGUAGE Arrows                      #-}
  21 {-# LANGUAGE NoImplicitPrelude           #-}
  22 {-# LANGUAGE OverloadedStrings           #-}
  23 {-# LANGUAGE RankNTypes                  #-}
  24
  25 module Gargantext.Database.Schema.User where
  26
  27 import Control.Arrow (returnA)
  28 import Control.Lens.TH (makeLensesWith, abbreviatedFields)
  29 import Data.Eq(Eq(..))
  30 import Data.List (find)
  31 import Data.Maybe (Maybe)
  32 import Data.Profunctor.Product.TH (makeAdaptorAndInstance)
  33 import Data.Text (Text)
  34 import Data.Time (UTCTime)
  35 import GHC.Show(Show(..))
  36 import Gargantext.Core.Types.Individu (Username, arbitraryUsername)
  37 import Gargantext.Database.Utils
  38 import Gargantext.Prelude
  39 import Opaleye
  40
  41 ------------------------------------------------------------------------
  42
  43 ------------------------------------------------------------------------
  44 type UserId = Int
  45
  46
  47 data UserLight = UserLight { userLight_id   :: Int
  48                            , userLight_username :: Text
  49                            , userLight_email    :: Text
  50                            } deriving (Show)
  51
  52 toUserLight :: User -> UserLight
  53 toUserLight (User id _ _ _ u _ _ e _ _ _ ) = UserLight id u e
  54
  55 data UserPoly id pass llogin suser
  56               uname fname lname
  57               mail staff active djoined = User { user_id          :: id
  58                                                , user_password    :: pass
  59                                                , user_lastLogin   :: llogin
  60                                                , user_isSuperUser :: suser
  61
  62                                                , user_username    :: uname
  63                                                , user_firstName   :: fname
  64                                                , user_lastName    :: lname
  65                                                , user_email       :: mail
  66
  67                                                , user_isStaff     :: staff
  68                                                , user_isActive    :: active
  69                                                , user_dateJoined  :: djoined
  70                                                } deriving (Show)
  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 User = UserPoly Int Text (Maybe UTCTime) Bool Text Text Text Text Bool Bool UTCTime
  87
  88 $(makeAdaptorAndInstance "pUser"     ''UserPoly)
  89 $(makeLensesWith abbreviatedFields   ''UserPoly)
  90
  91
  92 userTable :: Table UserWrite UserRead
  93 userTable = Table "auth_user" (pUser User { user_id      = optional "id"
  94                                           , user_password    = required "password"
  95                                           , user_lastLogin   = optional "last_login"
  96                                           , user_isSuperUser = required "is_superuser"
  97                                           , user_username    = required "username"
  98                                           , user_firstName   = required "first_name"
  99                                           , user_lastName    = required "last_name"
 100                                           , user_email       = required "email"
 101                                           , user_isStaff     = required "is_staff"
 102                                           , user_isActive    = required "is_active"
 103                                           , user_dateJoined  = optional "date_joined"
 104                                           }
 105                               )
 106
 107 -- TODO: on conflict, nice message
 108 insertUsers :: [UserWrite] -> Cmd err Int64
 109 insertUsers us = mkCmd $ \c -> runInsertMany c userTable us
 110
 111
 112 gargantextUser :: Username -> UserWrite
 113 gargantextUser u = User (Nothing) (pgStrictText "password")
 114                          (Nothing) (pgBool True) (pgStrictText u)
 115                          (pgStrictText "first_name")
 116                          (pgStrictText "last_name")
 117                          (pgStrictText "e@mail")
 118                          (pgBool True) (pgBool True) (Nothing)
 119
 120 insertUsersDemo :: Cmd err Int64
 121 insertUsersDemo = insertUsers $ map (\u -> gargantextUser u) arbitraryUsername
 122
 123
 124 ------------------------------------------------------------------
 125 queryUserTable :: Query UserRead
 126 queryUserTable = queryTable userTable
 127
 128 selectUsersLight :: Query UserRead
 129 selectUsersLight = proc () -> do
 130       row@(User i _p _ll _is _un _fn _ln _m _iff _ive _dj) <- queryUserTable -< ()
 131       restrict -< i .== 1
 132       --returnA -< User i p ll is un fn ln m iff ive dj
 133       returnA -< row
 134 ------------------------------------------------------------------
 135 -- | Select User with some parameters
 136 -- Not optimized version
 137 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
 138 userWith f t xs = find (\x -> f x == t) xs
 139
 140 -- | Select User with Username
 141 userWithUsername :: Text -> [User] -> Maybe User
 142 userWithUsername t xs = userWith user_username t xs
 143
 144 userWithId :: Int -> [User] -> Maybe User
 145 userWithId t xs = userWith user_id t xs
 146
 147 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
 148 userLightWithUsername t xs = userWith userLight_username t xs
 149
 150 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 151 userLightWithId t xs = userWith userLight_id t xs
 152
 153
 154 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 155   queryRunnerColumnDefault = fieldQueryRunnerColumn
 156
 157
 158 users :: Cmd err [User]
 159 users = runOpaQuery queryUserTable
 160
 161 usersLight :: Cmd err [UserLight]
 162 usersLight = map toUserLight <$> users
 163
 164 getUser :: Username -> Cmd err (Maybe UserLight)
 165 getUser u = userLightWithUsername u <$> usersLight
 166
 167