Functions to deal with users, database side.
-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.User
( insertUsers
+ , toUserWrite
+ , deleteUsers
+ , updateUserDB
, queryUserTable
, getUser
- , gargUserWith
- , insertUsersDemo
+ , insertNewUsers
, selectUsersLightWith
, userWithUsername
, userWithId
, userLightWithId
, getUsersWith
+ , getUsersWithId
, module Gargantext.Database.Schema.User
)
where
import Control.Arrow (returnA)
-import Data.Eq(Eq(..))
import Data.List (find)
-import Data.Maybe (Maybe)
import Data.Text (Text)
import Data.Time (UTCTime)
import Gargantext.Core.Types.Individu
-import qualified Gargantext.Core.Auth as Auth
+import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Schema.User
import Gargantext.Database.Prelude
import Gargantext.Prelude
import Opaleye
------------------------------------------------------------------------
-
-
-- TODO: on conflict, nice message
insertUsers :: [UserWrite] -> Cmd err Int64
insertUsers us = mkCmd $ \c -> runInsert_ c insert
where
insert = Insert userTable us rCount Nothing
-insertUsersDemo :: Cmd err Int64
-insertUsersDemo = do
- users <- liftBase arbitraryUsersHash
- insertUsers $ map (\(u,m,h) -> gargUserWith u m h) users
+deleteUsers :: [Username] -> Cmd err Int64
+deleteUsers us = mkCmd $ \c -> runDelete_ c
+ $ Delete userTable
+ (\user -> in_ (map sqlStrictText us) (user_username user))
+ rCount
+
+-- Updates email or password only (for now)
+updateUserDB :: UserWrite -> Cmd err Int64
+updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
+ where
+ updateUserQuery :: UserWrite -> Update Int64
+ updateUserQuery us' = Update
+ { uTable = userTable
+ , uUpdateWith = updateEasy (\ (UserDB _id _p ll su un fn ln _em is ia dj)
+ -> UserDB _id p' ll su un fn ln em' is ia dj
+ )
+ , uWhere = (\row -> user_username row .== un')
+ , uReturning = rCount
+ }
+ where
+ UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
-----------------------------------------------------------------------
-gargUserWith :: Username -> Email -> Auth.PasswordHash Auth.Argon2 -> UserWrite
-gargUserWith u m (Auth.PasswordHash p) = UserDB (Nothing) (pgStrictText p)
- (Nothing) (pgBool True) (pgStrictText u)
- (pgStrictText "first_name")
- (pgStrictText "last_name")
- (pgStrictText m)
- (pgBool True)
- (pgBool True) Nothing
+toUserWrite :: NewUser HashPassword -> UserWrite
+toUserWrite (NewUser u m (Auth.PasswordHash p)) =
+ UserDB (Nothing) (sqlStrictText p)
+ (Nothing) (pgBool True) (sqlStrictText u)
+ (sqlStrictText "first_name")
+ (sqlStrictText "last_name")
+ (sqlStrictText m)
+ (pgBool True)
+ (pgBool True) Nothing
------------------------------------------------------------------
getUsersWith :: Username -> Cmd err [UserLight]
selectUsersLightWith :: Username -> Query UserRead
selectUsersLightWith u = proc () -> do
row <- queryUserTable -< ()
- restrict -< user_username row .== pgStrictText u
+ restrict -< user_username row .== sqlStrictText u
returnA -< row
+----------------------------------------------------------
+getUsersWithId :: Int -> Cmd err [UserLight]
+getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
+ where
+ selectUsersLightWithId :: Int -> Query UserRead
+ selectUsersLightWithId i' = proc () -> do
+ row <- queryUserTable -< ()
+ restrict -< user_id row .== sqlInt4 i'
+ returnA -< row
+
+
+
queryUserTable :: Query UserRead
-queryUserTable = queryTable userTable
+queryUserTable = selectTable userTable
------------------------------------------------------------------
-- | Select User with some parameters
userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId t xs = userWith userLight_id t xs
-
-instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
- queryRunnerColumnDefault = fieldQueryRunnerColumn
-
-
+----------------------------------------------------------------------
users :: Cmd err [UserDB]
users = runOpaQuery queryUserTable
getUser :: Username -> Cmd err (Maybe UserLight)
getUser u = userLightWithUsername u <$> usersLight
+----------------------------------------------------------------------
+insertNewUsers :: [NewUser GargPassword] -> Cmd err Int64
+insertNewUsers newUsers = do
+ users' <- liftBase $ mapM toUserHash newUsers
+ insertUsers $ map toUserWrite users'
+
+----------------------------------------------------------------------
+instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
+ defaultFromField = fieldQueryRunnerColumn