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   , insertUsersDemo
  25   , selectUsersLightWith
  26   , userWithUsername
  27   , userWithId
  28   , userLightWithId
  29   , getUsersWith
  30   , module Gargantext.Database.Schema.User
  31   )
  32   where
  33
  34 import Control.Arrow (returnA)
  35 import Data.Eq(Eq(..))
  36 import Data.List (find)
  37 import Data.Maybe (Maybe)
  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 insertUsersDemo :: Cmd err Int64
  55 insertUsersDemo = do
  56   users <- liftBase arbitraryUsersHash
  57   insertUsers $ map toUserWrite users
  58
  59 -----------------------------------------------------------------------
  60 toUserWrite :: NewUser HashPassword -> UserWrite
  61 toUserWrite (NewUser u m (Auth.PasswordHash p)) =
  62   UserDB (Nothing) (pgStrictText p)
  63          (Nothing) (pgBool True) (pgStrictText u)
  64          (pgStrictText "first_name")
  65          (pgStrictText "last_name")
  66          (pgStrictText m)
  67          (pgBool True)
  68          (pgBool True) Nothing
  69
  70 ------------------------------------------------------------------
  71 getUsersWith :: Username -> Cmd err [UserLight]
  72 getUsersWith u = map toUserLight <$> runOpaQuery (selectUsersLightWith u)
  73
  74 selectUsersLightWith :: Username -> Query UserRead
  75 selectUsersLightWith u = proc () -> do
  76       row      <- queryUserTable -< ()
  77       restrict -< user_username row .== pgStrictText u
  78       returnA  -< row
  79
  80 queryUserTable :: Query UserRead
  81 queryUserTable = queryTable userTable
  82
  83 ------------------------------------------------------------------
  84 -- | Select User with some parameters
  85 -- Not optimized version
  86 userWith :: (Eq a1, Foldable t) => (a -> a1) -> a1 -> t a -> Maybe a
  87 userWith f t xs = find (\x -> f x == t) xs
  88
  89 -- | Select User with Username
  90 userWithUsername :: Text -> [UserDB] -> Maybe UserDB
  91 userWithUsername t xs = userWith user_username t xs
  92
  93 userWithId :: Int -> [UserDB] -> Maybe UserDB
  94 userWithId t xs = userWith user_id t xs
  95
  96 userLightWithUsername :: Text -> [UserLight] -> Maybe UserLight
  97 userLightWithUsername t xs = userWith userLight_username t xs
  98
  99 userLightWithId :: Int -> [UserLight] -> Maybe UserLight
 100 userLightWithId t xs = userWith userLight_id t xs
 101
 102 ----------------------------------------------------------------------
 103 users :: Cmd err [UserDB]
 104 users = runOpaQuery queryUserTable
 105
 106 usersLight :: Cmd err [UserLight]
 107 usersLight = map toUserLight <$> users
 108
 109 getUser :: Username -> Cmd err (Maybe UserLight)
 110 getUser u = userLightWithUsername u <$> usersLight
 111
 112 ----------------------------------------------------------------------
 113 instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
 114   queryRunnerColumnDefault = fieldQueryRunnerColumn