Functions to deal with users, database side.
-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
, deleteUsers
, updateUserDB
, queryUserTable
+ , getUserHyperdata
, getUser
, insertNewUsers
, selectUsersLightWith
where
import Control.Arrow (returnA)
+import Control.Lens ((^.))
import Data.List (find)
import Data.Text (Text)
import Data.Time (UTCTime)
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
-import Gargantext.Database.Schema.User
+import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Database.Prelude
+import Gargantext.Database.Schema.Node (node_hyperdata, node_id, queryNodeTable)
+import Gargantext.Database.Schema.User
import Gargantext.Prelude
import Opaleye
insert = Insert userTable us rCount Nothing
deleteUsers :: [Username] -> Cmd err Int64
-deleteUsers us = mkCmd $ \c -> runDelete c userTable
- (\user -> in_ (map pgStrictText us) (user_username user))
+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
+ 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
, uReturning = rCount
}
where
- UserDB _ p' _ _ un' _ _ em' _ _ _ = us
+ UserDB _ p' _ _ un' _ _ em' _ _ _ = us'
-----------------------------------------------------------------------
toUserWrite :: NewUser HashPassword -> UserWrite
toUserWrite (NewUser u m (Auth.PasswordHash p)) =
- UserDB (Nothing) (pgStrictText p)
- (Nothing) (pgBool True) (pgStrictText u)
- (pgStrictText "first_name")
- (pgStrictText "last_name")
- (pgStrictText m)
+ UserDB (Nothing) (sqlStrictText p)
+ (Nothing) (pgBool True) (sqlStrictText u)
+ (sqlStrictText "first_name")
+ (sqlStrictText "last_name")
+ (sqlStrictText m)
(pgBool True)
(pgBool True) Nothing
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
+ selectUsersLightWithId i' = proc () -> do
row <- queryUserTable -< ()
- restrict -< user_id row .== pgInt4 i
+ restrict -< user_id row .== sqlInt4 i'
returnA -< row
-
queryUserTable :: Query UserRead
-queryUserTable = queryTable userTable
+queryUserTable = selectTable userTable
+----------------------------------------------------------------------
+getUserHyperdata :: Int -> Cmd err [HyperdataUser]
+getUserHyperdata i = do
+ runOpaQuery (selectUserHyperdataWithId i)
+ where
+ selectUserHyperdataWithId :: Int -> Query (Column PGJsonb)
+ selectUserHyperdataWithId i' = proc () -> do
+ row <- queryNodeTable -< ()
+ restrict -< row^.node_id .== (sqlInt4 i')
+ returnA -< row^.node_hyperdata
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
userLightWithId :: Int -> [UserLight] -> Maybe UserLight
userLightWithId t xs = userWith userLight_id t xs
-
----------------------------------------------------------------------
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
+ users' <- liftBase $ mapM toUserHash newUsers
+ insertUsers $ map toUserWrite users'
----------------------------------------------------------------------
-instance QueryRunnerColumnDefault PGTimestamptz (Maybe UTCTime) where
- queryRunnerColumnDefault = fieldQueryRunnerColumn
+instance DefaultFromField PGTimestamptz (Maybe UTCTime) where
+ defaultFromField = fieldQueryRunnerColumn