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