src/Gargantext/Database/Query/Table/User.hs

   1 {-|
   2 Module      : Gargantext.Database.Query.Table.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
  20 module Gargantext.Database.Query.Table.User
  21   ( insertUsers
  22   , queryUserTable
  23   , getUser
  24   , gargUserWith
  25   , insertUsersDemo
  26   , selectUsersLightWith
  27   , userWithUsername
  28   , userWithId
  29   , userLightWithId
  30   , getUsersWith
  31   , module Gargantext.Database.Schema.User
  32   )
  33   where
  34
  35 import Control.Arrow (returnA)
  36 import Data.Eq(Eq(..))
  37 import Data.List (find)
  38 import Data.Maybe (Maybe)
  39 import Data.Text (Text)
  40 import Data.Time (UTCTime)
  41 import Gargantext.Core.Types.Individu
  42 import qualified Gargantext.Core.Auth as Auth
  43 import Gargantext.Database.Schema.User
  44 import Gargantext.Database.Prelude
  45 import Gargantext.Prelude
  46 import Opaleye
  47
  48 ------------------------------------------------------------------------
  49
  50
  51 -- TODO: on conflict, nice message
  52 insertUsers :: [UserWrite] -> Cmd err Int64
  53 insertUsers us = mkCmd $ \c -> runInsert_ c insert
  54   where
  55     insert = Insert userTable us rCount Nothing
  56
  57 insertUsersDemo :: Cmd err Int64
  58 insertUsersDemo = do
  59   users <- liftBase arbitraryUsersHash
  60   insertUsers $ map (\(u,m,h) -> gargUserWith u m h) users
  61
  62 -----------------------------------------------------------------------
  63 gargUserWith :: Username -> Email -> Auth.PasswordHash Auth.Argon2 -> UserWrite
  64 gargUserWith u m (Auth.PasswordHash p) = UserDB (Nothing) (pgStrictText p)
  65                          (Nothing) (pgBool True) (pgStrictText u)
  66                          (pgStrictText "first_name")
  67                          (pgStrictText "last_name")
  68                          (pgStrictText m)
  69                          (pgBool True)
  70                          (pgBool True) Nothing
  71
  72 ------------------------------------------------------------------
  73 getUsersWith :: Username -> Cmd err [UserLight]
  74 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
  75
  76 selectUsersLightWith :: Username -> Query UserRead
  77 selectUsersLightWith u = proc () -> do
  78       row      <- queryUserTable -< ()
  79       restrict -< user_username row .== pgStrictText u
  80       returnA  -< row
  81
  82 queryUserTable :: Query UserRead
  83 queryUserTable = queryTable userTable
  84
  85 ------------------------------------------------------------------
  86 -- | Select User with some parameters
  87 -- Not optimized version
  88 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
  89 userWith f t xs = find (\x -> f x == t) xs
  90
  91 -- | Select User with Username
  92 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
  93 userWithUsername t xs = userWith user_username t xs
  94
  95 userWithId :: Int -> [UserDB] -> Maybe UserDB
  96 userWithId t xs = userWith user_id t xs
  97
  98 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
  99 userLightWithUsername t xs = userWith userLight_username t xs
 100
 101 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 102 userLightWithId t xs = userWith userLight_id t xs
 103
 104
 105 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 106   queryRunnerColumnDefault = fieldQueryRunnerColumn
 107
 108
 109 users :: Cmd err [UserDB]
 110 users = runOpaQuery queryUserTable
 111
 112 usersLight :: Cmd err [UserLight]
 113 usersLight = map toUserLight <$> users
 114
 115 getUser :: Username -> Cmd err (Maybe UserLight)
 116 getUser u = userLightWithUsername u <$> usersLight
 117