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