Skip to content

haskell-gargantext
haskell-gargantext
Verified Commit 8aeae22e authored by Przemyslaw Kaminski's avatar Przemyslaw Kaminski
Browse files
Options

[pubmed] implement pubmed api key in hyperdata user

parent 6bc41d73
Hide whitespace changes
Inline Side-by-side
Showing with 199 additions and 125 deletions
src/Gargantext/API/GraphQL.hs
View file @ 8aeae22e
......@@ -87,6 +87,7 @@ data Query m
data Mutation m
= Mutation
{ update_user_info :: GQLUserInfo.UserInfoMArgs -> m Int
, update_user_pubmed_api_key :: GQLUser.UserPubmedAPIKeyMArgs -> m Int
, delete_team_membership :: GQLTeam.TeamDeleteMArgs -> m [Int]
, update_node_context_category :: GQLCTX.NodeContextCategoryMArgs -> m [Int]
} deriving (Generic, GQLType)
......@@ -128,6 +129,7 @@ rootResolver =
, tree = GQLTree.resolveTree
, team = GQLTeam.resolveTeam }
, mutationResolver = Mutation { update_user_info = GQLUserInfo.updateUserInfo
, update_user_pubmed_api_key = GQLUser.updateUserPubmedAPIKey
, delete_team_membership = GQLTeam.deleteTeamMembership
, update_node_context_category = GQLCTX.updateNodeContextCategory }
, subscriptionResolver = Undefined }
......
src/Gargantext/API/GraphQL/Node.hs
View file @ 8aeae22e
......@@ -30,7 +30,6 @@ data Corpus = Corpus
{ id :: Int
, name :: Text
, parent_id :: Maybe Int
, pubmedAPIKey :: Maybe PUBMED.APIKey
, type_id :: Int
} deriving (Show, Generic, GQLType)
......@@ -116,7 +115,6 @@ toCorpus :: NN.Node Value -> Corpus
toCorpus N.Node { .. } = Corpus { id = NN.unNodeId _node_id
, name = _node_name
, parent_id = NN.unNodeId <$> _node_parent_id
, pubmedAPIKey = pubmedAPIKeyFromValue _node_hyperdata
, type_id = _node_typename }
pubmedAPIKeyFromValue :: Value -> Maybe PUBMED.APIKey
......
src/Gargantext/API/GraphQL/Team.hs
View file @ 8aeae22e
......@@ -11,6 +11,7 @@ import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.GraphQL.Utils (authUser, AuthStatus (Invalid, Valid))
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Core.Types (NodeId(..), unNodeId)
import qualified Gargantext.Core.Types.Individu as Individu
import Gargantext.Database.Action.Share (membersOf, deleteMemberShip)
import Gargantext.Database.Prelude (CmdCommon)
import Gargantext.Database.Query.Table.Node (getNode)
......@@ -52,7 +53,7 @@ dbTeam nodeId = do
let nId = NodeId nodeId
res <- lift $ membersOf nId
teamNode <- lift $ getNode nId
userNodes <- lift $ getUsersWithNodeHyperdata $ uId teamNode
userNodes <- lift $ getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode
let username = getUsername userNodes
pure $ Team { team_owner_username = username
, team_members = map toTeamMember res
......@@ -72,7 +73,7 @@ deleteTeamMembership :: (CmdCommon env, HasSettings env) =>
TeamDeleteMArgs -> GqlM' e env [Int]
deleteTeamMembership TeamDeleteMArgs { token, shared_folder_id, team_node_id } = do
teamNode <- lift $ getNode $ NodeId team_node_id
userNodes <- lift (getUsersWithNodeHyperdata $ uId teamNode)
userNodes <- lift (getUsersWithNodeHyperdata $ Individu.UserDBId $ uId teamNode)
case userNodes of
[] -> panic $ "[deleteTeamMembership] User with id " <> T.pack (show $ uId teamNode) <> " doesn't exist."
(( _, node_u):_) -> do
......
src/Gargantext/API/GraphQL/User.hs
View file @ 8aeae22e
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DuplicateRecordFields #-}
module Gargantext.API.GraphQL.User where
import Data.Maybe (listToMaybe)
import Data.Morpheus.Types
( GQLType
, Resolver, QUERY
, Resolver, ResolverM, QUERY
, lift
)
import Data.Text (Text)
import Gargantext.API.Admin.Types (HasSettings)
import Gargantext.API.Prelude (GargM, GargError)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..))
import Gargantext.Database.Admin.Types.Node (NodeId(..))
import Gargantext.Database.Prelude (CmdCommon)
import Gargantext.Database.Query.Table.User (getUsersWithId, getUserHyperdata)
import qualified Gargantext.Database.Query.Table.User as DBUser
import Gargantext.Database.Schema.User (UserLight(..))
import Gargantext.Prelude
import GHC.Generics (Generic)
import qualified Gargantext.Core.Types.Individu as Individu
data User m = User
{ u_email :: Text
......@@ -30,7 +34,14 @@ data UserArgs
{ user_id :: Int
} deriving (Generic, GQLType)
data UserPubmedAPIKeyMArgs
= UserPubmedAPIKeyMArgs
{ user_id :: Int
, api_key :: Text }
deriving (Generic, GQLType)
type GqlM e env = Resolver QUERY e (GargM env GargError)
type GqlM' e env a = ResolverM e (GargM env GargError) a
-- | Function to resolve user from a query.
resolveUsers
......@@ -42,7 +53,7 @@ resolveUsers UserArgs { user_id } = dbUsers user_id
dbUsers
:: (CmdCommon env)
=> Int -> GqlM e env [User (GqlM e env)]
dbUsers user_id = lift (map toUser <$> getUsersWithId user_id)
dbUsers user_id = lift (map toUser <$> DBUser.getUsersWithId (Individu.RootId $ NodeId user_id))
toUser
:: (CmdCommon env)
......@@ -55,4 +66,11 @@ toUser (UserLight { .. }) = User { u_email = userLight_email
resolveHyperdata
:: (CmdCommon env)
=> Int -> GqlM e env (Maybe HyperdataUser)
resolveHyperdata userid = lift (listToMaybe <$> getUserHyperdata userid)
resolveHyperdata userid = lift (listToMaybe <$> DBUser.getUserHyperdata (Individu.UserDBId userid))
updateUserPubmedAPIKey :: ( CmdCommon env, HasSettings env) =>
UserPubmedAPIKeyMArgs -> GqlM' e env Int
updateUserPubmedAPIKey UserPubmedAPIKeyMArgs { user_id, api_key } = do
_ <- lift $ DBUser.updateUserPubmedAPIKey (Individu.RootId $ NodeId user_id) api_key
pure 1
src/Gargantext/API/GraphQL/UserInfo.hs
View file @ 8aeae22e
......@@ -48,6 +48,7 @@ import Gargantext.Prelude
import GHC.Generics (Generic)
import Gargantext.API.GraphQL.Utils (AuthStatus(Invalid, Valid), authUser)
import Gargantext.API.Admin.Types (HasSettings)
import qualified Gargantext.Core.Types.Individu as Individu
data UserInfo = UserInfo
{ ui_id :: Int
......@@ -115,7 +116,7 @@ updateUserInfo
=> UserInfoMArgs -> GqlM' e env err
updateUserInfo (UserInfoMArgs { ui_id, .. }) = do
-- lift $ printDebug "[updateUserInfo] ui_id" ui_id
users <- lift (getUsersWithNodeHyperdata ui_id)
users <- lift (getUsersWithNodeHyperdata (Individu.UserDBId ui_id))
case users of
[] -> panic $ "[updateUserInfo] User with id " <> (T.pack $ show ui_id) <> " doesn't exist."
((UserLight { .. }, node_u):_) -> do
......@@ -166,7 +167,7 @@ dbUsers user_id = do
-- user <- getUsersWithId user_id
-- hyperdata <- getUserHyperdata user_id
-- lift (map toUser <$> zip user hyperdata)
lift (map toUser <$> (getUsersWithHyperdata user_id))
lift (map toUser <$> getUsersWithHyperdata (Individu.UserDBId user_id))
toUser :: (UserLight, HyperdataUser) -> UserInfo
toUser (UserLight { .. }, u_hyperdata) =
......
src/Gargantext/API/Node/Corpus/New.hs
View file @ 8aeae22e
......@@ -56,11 +56,12 @@ import Gargantext.Database.Action.User (getUserId)
import Gargantext.Database.Admin.Types.Hyperdata
import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..))
import Gargantext.Database.Prelude (hasConfig)
import Gargantext.Database.Query.Table.Node (getNodeWith, updateCorpusPubmedAPIKey)
import Gargantext.Database.Query.Table.Node (getNodeWith)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
import Gargantext.Database.Query.Table.User (getUserPubmedAPIKey)
import Gargantext.Database.Schema.Node (node_hyperdata)
import Gargantext.Prelude
import Gargantext.Prelude.Config (gc_max_docs_parsers, gc_pubmed_api_key)
import Gargantext.Prelude.Config (gc_max_docs_parsers)
import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
import qualified Gargantext.Core.Text.Corpus.API as API
import qualified Gargantext.Core.Text.Corpus.Parsers as Parser (FileType(..), parseFormatC)
......@@ -215,13 +216,6 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
markComplete jobHandle
_ -> do
case datafield of
Just (External PubMed) -> do
_api_key <- view $ hasConfig . gc_pubmed_api_key
printDebug "[addToCorpusWithQuery] pubmed api key" _api_key
_ <- updateCorpusPubmedAPIKey cid _api_key
pure ()
_ -> pure ()
markStarted 3 jobHandle
-- TODO add cid
......@@ -230,7 +224,9 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
-- if cid is root -> create corpus in Private
-- printDebug "[G.A.N.C.New] getDataText with query" q
let db = database2origin dbs
eTxt <- getDataText db (Multi l) q maybeLimit
mPubmedAPIKey <- getUserPubmedAPIKey user
-- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
eTxt <- getDataText db (Multi l) q mPubmedAPIKey maybeLimit
-- printDebug "[G.A.N.C.New] lTxts" lTxts
case eTxt of
......
src/Gargantext/Core/Text/Corpus/API.hs
View file @ 8aeae22e
......@@ -19,7 +19,6 @@ module Gargantext.Core.Text.Corpus.API
) where
import Conduit
import Control.Lens ((^.))
import Data.Bifunctor
import Data.Either (Either(..))
import Data.Maybe
......@@ -28,13 +27,13 @@ import Gargantext.API.Admin.Orchestrator.Types (ExternalAPIs(..), externalAPIs)
import Gargantext.Core (Lang(..))
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataDocument(..))
import Gargantext.Prelude
import Gargantext.Prelude.Config (GargConfig, gc_pubmed_api_key)
import qualified Gargantext.Core.Text.Corpus.API.Arxiv as Arxiv
import qualified Gargantext.Core.Text.Corpus.API.Hal as HAL
import qualified Gargantext.Core.Text.Corpus.API.Isidore as ISIDORE
import qualified Gargantext.Core.Text.Corpus.API.Istex as ISTEX
import qualified Gargantext.Core.Text.Corpus.API.Pubmed as PUBMED
import qualified Gargantext.Core.Text.Corpus.Query as Corpus
import qualified PUBMED.Types as PUBMED
import Servant.Client (ClientError)
data GetCorpusError
......@@ -45,19 +44,19 @@ data GetCorpusError
deriving (Show, Eq)
-- | Get External API metadata main function
get :: GargConfig
-> ExternalAPIs
get :: ExternalAPIs
-> Lang
-> Corpus.RawQuery
-> Maybe PUBMED.APIKey
-> Maybe Corpus.Limit
-- -> IO [HyperdataDocument]
-> IO (Either GetCorpusError (Maybe Integer, ConduitT () HyperdataDocument IO ()))
get cfg externalAPI la q limit = do
get externalAPI la q mPubmedAPIKey limit = do
case Corpus.parseQuery q of
Left err -> pure $ Left $ InvalidInputQuery q (T.pack err)
Right corpusQuery -> case externalAPI of
PubMed -> first ExternalAPIError <$>
PUBMED.get (cfg ^. gc_pubmed_api_key) corpusQuery limit
PUBMED.get (fromMaybe "" mPubmedAPIKey) corpusQuery limit
--docs <- PUBMED.get q default_limit -- EN only by default
--pure (Just $ fromIntegral $ length docs, yieldMany docs)
Arxiv -> Right <$> Arxiv.get la corpusQuery limit
......
src/Gargantext/Database/Action/Flow.hs
View file @ 8aeae22e
......@@ -112,6 +112,7 @@ import Gargantext.Prelude.Crypto.Hash (Hash)
import Gargantext.Utils.Jobs (JobHandle, MonadJobStatus(..))
import qualified Gargantext.Core.Text.Corpus.API as API
import qualified Gargantext.Database.Query.Table.Node.Document.Add as Doc (add)
import qualified PUBMED.Types as PUBMED
--import qualified Prelude
------------------------------------------------------------------------
......@@ -151,14 +152,13 @@ getDataText :: FlowCmdM env err m
=> DataOrigin
-> TermType Lang
-> API.RawQuery
-> Maybe PUBMED.APIKey
-> Maybe API.Limit
-> m (Either API.GetCorpusError DataText)
getDataText (ExternalOrigin api) la q li = do
cfg <- view $ hasConfig
eRes <- liftBase $ API.get cfg api (_tt_lang la) q li
getDataText (ExternalOrigin api) la q mPubmedAPIKey li = do
eRes <- liftBase $ API.get api (_tt_lang la) q mPubmedAPIKey li
pure $ DataNew <$> eRes
getDataText (InternalOrigin _) _la q _li = do
getDataText (InternalOrigin _) _la q _ _li = do
(_masterUserId, _masterRootId, cId) <- getOrMk_RootWithCorpus
(UserName userMaster)
(Left "")
......@@ -173,7 +173,7 @@ getDataText_Debug :: FlowCmdM env err m
-> Maybe API.Limit
-> m ()
getDataText_Debug a l q li = do
result <- getDataText a l q li
result <- getDataText a l q Nothing li
case result of
Left err -> liftBase $ putStrLn $ show err
Right res -> liftBase $ printDataText res
......
src/Gargantext/Database/Action/User.hs
View file @ 8aeae22e
......@@ -26,7 +26,7 @@ import Gargantext.Prelude
------------------------------------------------------------------------
getUserLightWithId :: HasNodeError err => Int -> Cmd err UserLight
getUserLightWithId i = do
candidates <- head <$> getUsersWithId i
candidates <- head <$> getUsersWithId (UserDBId i)
case candidates of
Nothing -> nodeError NoUserFound
Just u -> pure u
......@@ -70,8 +70,8 @@ getUsername :: HasNodeError err
=> User
-> Cmd err Username
getUsername (UserName u) = pure u
getUsername (UserDBId i) = do
users <- getUsersWithId i
getUsername user@(UserDBId _) = do
users <- getUsersWithId user
case head users of
Just u -> pure $ userLight_username u
Nothing -> nodeError $ NodeError "G.D.A.U.getUserName: User not found with that id"
......@@ -82,4 +82,3 @@ getUsername UserPublic = pure "UserPublic"
--------------------------------------------------------------------------
-- getRootId is in Gargantext.Database.Query.Tree.Root
src/Gargantext/Database/Admin/Types/Hyperdata/User.hs
View file @ 8aeae22e
......@@ -31,13 +31,15 @@ import Gargantext.Database.Admin.Types.Hyperdata.Prelude
import Gargantext.Database.Admin.Types.Hyperdata.Contact
import Gargantext.Database.Admin.Types.Node (DocumentId)
import Gargantext.Prelude
import qualified PUBMED.Types as PUBMED
-- import Gargantext.Database.Schema.Node -- (Node(..))
data HyperdataUser =
HyperdataUser { _hu_private :: !(Maybe HyperdataPrivate)
, _hu_shared :: !(Maybe HyperdataContact)
, _hu_public :: !(Maybe HyperdataPublic)
HyperdataUser { _hu_private :: !(Maybe HyperdataPrivate)
, _hu_shared :: !(Maybe HyperdataContact)
, _hu_public :: !(Maybe HyperdataPublic)
, _hu_pubmed_api_key :: !(Maybe PUBMED.APIKey)
} deriving (Eq, Show, Generic)
instance GQLType HyperdataUser where
......@@ -66,9 +68,10 @@ instance GQLType HyperdataPublic where
defaultHyperdataUser :: HyperdataUser
defaultHyperdataUser =
HyperdataUser
{ _hu_private = Just defaultHyperdataPrivate
, _hu_shared = Just defaultHyperdataContact
, _hu_public = Just defaultHyperdataPublic }
{ _hu_private = Just defaultHyperdataPrivate
, _hu_shared = Just defaultHyperdataContact
, _hu_public = Just defaultHyperdataPublic
, _hu_pubmed_api_key = Nothing }
defaultHyperdataPublic :: HyperdataPublic
defaultHyperdataPublic = HyperdataPublic "pseudo" [1..10]
......@@ -97,7 +100,7 @@ $(deriveJSON (unPrefix "_hpu_") ''HyperdataPublic)
-- | Arbitrary instances
instance Arbitrary HyperdataUser where
arbitrary = HyperdataUser <$> arbitrary <*> arbitrary <*> arbitrary
arbitrary = HyperdataUser <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary HyperdataPrivate where
arbitrary = pure defaultHyperdataPrivate
......@@ -143,4 +146,3 @@ instance DefaultFromField SqlJsonb HyperdataPrivate where
instance DefaultFromField SqlJsonb HyperdataPublic where
defaultFromField = fromPGSFromField
src/Gargantext/Database/Query/Table/Node.hs
View file @ 8aeae22e
......@@ -29,7 +29,6 @@ import Data.Text (Text)
import Database.PostgreSQL.Simple.SqlQQ (sql)
import Opaleye hiding (FromField)
import Prelude hiding (null, id, map, sum)
import qualified PUBMED.Types as PUBMED
import Gargantext.Core
import Gargantext.Core.Types
......@@ -203,7 +202,7 @@ getCorporaWithParentId n = runOpaQuery $ selectNodesWith' n (Just NodeCorpus)
selectNodesWithParentID :: NodeId -> Select NodeRead
selectNodesWithParentID n = proc () -> do
row@(Node _ _ _ _ parent_id _ _ _) <- queryNodeTable -< ()
restrict -< parent_id .== (pgNodeId n)
restrict -< parent_id .== pgNodeId n
returnA -< row
......@@ -217,7 +216,22 @@ getNodesWithType nt _ = runOpaQuery $ selectNodesWithType nt
=> NodeType -> Select NodeRead
selectNodesWithType nt' = proc () -> do
row@(Node _ _ tn _ _ _ _ _) <- queryNodeTable -< ()
restrict -< tn .== (sqlInt4 $ toDBid nt')
restrict -< tn .== sqlInt4 (toDBid nt')
returnA -< row
getNodeWithType :: (HasNodeError err, JSONB a, HasDBid NodeType)
=> NodeId
-> NodeType
-> proxy a
-> Cmd err [Node a]
getNodeWithType nId nt _ = runOpaQuery $ selectNodeWithType nId nt
where
selectNodeWithType :: HasDBid NodeType
=> NodeId -> NodeType -> Select NodeRead
selectNodeWithType (NodeId nId') nt' = proc () -> do
row@(Node ti _ tn _ _ _ _ _) <- queryNodeTable -< ()
restrict -< ti .== sqlInt4 nId'
restrict -< tn .== sqlInt4 (toDBid nt')
returnA -< row
getNodesIdWithType :: (HasNodeError err, HasDBid NodeType) => NodeType -> Cmd err [NodeId]
......@@ -328,31 +342,6 @@ insertNodesWithParent pid ns = insertNodes (set node_parent_id (pgNodeId <$> pid
insertNodesWithParentR :: Maybe ParentId -> [NodeWrite] -> Cmd err [NodeId]
insertNodesWithParentR pid ns = insertNodesR (set node_parent_id (pgNodeId <$> pid) <$> ns)
getCorpusPubmedAPIKey :: NodeId -> Cmd err (Maybe PUBMED.APIKey)
getCorpusPubmedAPIKey cId = do
res <- runPGSQuery query params
pure $ (\(PGS.Only apiKey) -> apiKey) <$> head res
where
query :: PGS.Query
query = [sql|
SELECT hyperdata -> 'pubmed_api_key'
FROM nodes
WHERE id = ?
|]
params = PGS.Only cId
updateCorpusPubmedAPIKey :: NodeId -> PUBMED.APIKey -> Cmd err Int64
updateCorpusPubmedAPIKey cId apiKey =
execPGSQuery query params
where
query :: PGS.Query
query = [sql|
UPDATE nodes
SET hyperdata = hyperdata || ?
WHERE id = ?
|]
params = (encode $ object [ "pubmed_api_key" .= apiKey ], cId)
------------------------------------------------------------------------
-- TODO
-- currently this function removes the child relation
......
src/Gargantext/Database/Query/Table/Node/Select.hs
View file @ 8aeae22e
......@@ -27,7 +27,7 @@ import Gargantext.Database.Schema.Node
import Gargantext.Database.Schema.User
import Gargantext.Database.Query.Table.User
selectNodesWithUsername :: NodeType -> Username -> Cmd err [NodeId]
selectNodesWithUsername :: (HasDBid NodeType) => NodeType -> Username -> Cmd err [NodeId]
selectNodesWithUsername nt u = runOpaQuery $ proc () -> do
n <- queryNodeTable -< ()
usrs <- optionalRestrict queryUserTable -<
......
src/Gargantext/Database/Query/Table/Node/UpdateOpaleye.hs
View file @ 8aeae22e
......@@ -39,10 +39,10 @@ updateHyperdataQuery i h = seq h' $ trace "updateHyperdataQuery: encoded JSON" $
-> Node { _node_hyperdata = h', .. }
-- -> trace "updating mate" $ Node _ni _nh _nt _nu _np _nn _nd h'
)
, uWhere = (\row -> {-trace "uWhere" $-} _node_id row .== pgNodeId i )
, uWhere = \row -> {-trace "uWhere" $-} _node_id row .== pgNodeId i
, uReturning = rCount
}
where h' = (sqlJSONB $ cs $ encode $ h)
where h' = sqlJSONB $ cs $ encode h
----------------------------------------------------------------------------------
updateNodesWithType :: ( HasNodeError err
......@@ -54,6 +54,19 @@ updateNodesWithType nt p f = do
ns <- getNodesWithType nt p
mapM (\n -> updateHyperdata (_node_id n) (f $ _node_hyperdata n)) ns
updateNodeWithType :: ( HasNodeError err
, JSONB a
, ToJSON a
, HasDBid NodeType
) => NodeId
-> NodeType
-> proxy a
-> (a -> a)
-> Cmd err [Int64]
updateNodeWithType nId nt p f = do
ns <- getNodeWithType nId nt p
mapM (\n -> updateHyperdata (_node_id n) (f $ _node_hyperdata n)) ns
-- | In case the Hyperdata Types are not compatible
updateNodesWithType_ :: ( HasNodeError err
......
src/Gargantext/Database/Query/Table/User.hs
View file @ 8aeae22e
......@@ -13,9 +13,10 @@ Functions to deal with users, database side.
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE Arrows #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Gargantext.Database.Query.Table.User
( insertUsers
......@@ -29,6 +30,8 @@ module Gargantext.Database.Query.Table.User
, updateUserEmail
, updateUserPassword
, updateUserForgotPasswordUUID
, getUserPubmedAPIKey
, updateUserPubmedAPIKey
, getUser
, insertNewUsers
, selectUsersLightWith
......@@ -44,22 +47,27 @@ module Gargantext.Database.Query.Table.User
where
import Control.Arrow (returnA)
import Control.Lens ((^.))
import Data.Maybe (fromMaybe)
import Control.Lens ((^.), (?~))
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text (Text)
import Data.Time (UTCTime)
import qualified Data.UUID as UUID
import Gargantext.Core.Types.Individu
import qualified Gargantext.Prelude.Crypto.Auth as Auth
import Gargantext.Database.Admin.Config (nodeTypeId)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser)
import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node)
import Gargantext.Database.Admin.Types.Hyperdata (HyperdataUser(..), hu_pubmed_api_key)
import Gargantext.Database.Admin.Types.Node (NodeType(NodeUser), Node, NodeId(..), pgNodeId)
import Gargantext.Database.Prelude
import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_user_id, node_typename)
import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateNodeWithType)
import Gargantext.Database.Schema.Node (NodeRead, node_hyperdata, queryNodeTable, node_id, node_user_id, node_typename)
import Gargantext.Database.Schema.User
import Gargantext.Prelude
import Opaleye
import qualified PUBMED.Types as PUBMED
import Gargantext.Database.Query.Table.Node.Error (HasNodeError)
import Gargantext.Core (HasDBid)
import Gargantext.Database.Admin.Config (nodeTypeId)
------------------------------------------------------------------------
-- TODO: on conflict, nice message
......@@ -86,7 +94,7 @@ updateUserDB us = mkCmd $ \c -> runUpdate_ c (updateUserQuery us)
, user_email = em'
, .. }
)
, uWhere = (\row -> user_username row .== un')
, uWhere = \row -> user_username row .== un'
, uReturning = rCount
}
where
......@@ -139,52 +147,82 @@ selectUsersLightWithForgotPasswordUUID uuid = proc () -> do
returnA -< row
----------------------------------------------------------
getUsersWithId :: Int -> Cmd err [UserLight]
getUsersWithId i = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
getUsersWithId :: User -> Cmd err [UserLight]
getUsersWithId (UserDBId i) = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
where
selectUsersLightWithId :: Int -> Select UserRead
selectUsersLightWithId i' = proc () -> do
row <- queryUserTable -< ()
restrict -< user_id row .== sqlInt4 i'
returnA -< row
row <- queryUserTable -< ()
restrict -< user_id row .== sqlInt4 i'
returnA -< row
getUsersWithId (RootId i) = map toUserLight <$> runOpaQuery (selectUsersLightWithId i)
where
selectUsersLightWithId :: NodeId -> Select UserRead
selectUsersLightWithId i' = proc () -> do
n <- queryNodeTable -< ()
restrict -< n^.node_id .== pgNodeId i'
restrict -< n^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
row <- queryUserTable -< ()
restrict -< user_id row .== n^.node_user_id
returnA -< row
getUsersWithId _ = undefined
queryUserTable :: Select UserRead
queryUserTable = selectTable userTable
----------------------------------------------------------------------
getUserHyperdata :: Int -> Cmd err [HyperdataUser]
getUserHyperdata i = do
runOpaQuery (selectUserHyperdataWithId i)
-- | Get hyperdata associated with user node.
getUserHyperdata :: User -> Cmd err [HyperdataUser]
getUserHyperdata (RootId uId) = do
runOpaQuery (selectUserHyperdataWithId uId)
where
selectUserHyperdataWithId :: Int -> Select (Column SqlJsonb)
selectUserHyperdataWithId :: NodeId -> Select (Field SqlJsonb)
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== (sqlInt4 i')
restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
restrict -< row^.node_id .== pgNodeId i'
returnA -< row^.node_hyperdata
getUserHyperdata (UserDBId uId) = do
runOpaQuery (selectUserHyperdataWithId uId)
where
selectUserHyperdataWithId :: Int -> Select (Field SqlJsonb)
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== sqlInt4 i'
restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
returnA -< row^.node_hyperdata
getUserHyperdata _ = undefined
getUserNodeHyperdata :: Int -> Cmd err [Node HyperdataUser]
getUserNodeHyperdata i = do
runOpaQuery (selectUserHyperdataWithId i)
-- | Same as `getUserHyperdata` but returns a `Node` type.
getUserNodeHyperdata :: User -> Cmd err [Node HyperdataUser]
getUserNodeHyperdata (RootId uId) = do
runOpaQuery (selectUserHyperdataWithId uId)
where
selectUserHyperdataWithId :: NodeId -> Select NodeRead
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_id .== pgNodeId i'
returnA -< row
getUserNodeHyperdata (UserDBId uId) = do
runOpaQuery (selectUserHyperdataWithId uId)
where
selectUserHyperdataWithId :: Int -> Select NodeRead
selectUserHyperdataWithId i' = proc () -> do
row <- queryNodeTable -< ()
restrict -< row^.node_user_id .== (sqlInt4 i')
restrict -< row^.node_typename .== (sqlInt4 $ nodeTypeId NodeUser)
restrict -< row^.node_user_id .== sqlInt4 i'
restrict -< row^.node_typename .== sqlInt4 (nodeTypeId NodeUser)
returnA -< row
getUserNodeHyperdata _ = undefined
getUsersWithHyperdata :: Int -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata :: User -> Cmd err [(UserLight, HyperdataUser)]
getUsersWithHyperdata i = do
u <- getUsersWithId i
h <- getUserHyperdata i
-- printDebug "[getUsersWithHyperdata]" (u,h)
pure $ zip u h
getUsersWithNodeHyperdata :: Int -> Cmd err [(UserLight, Node HyperdataUser)]
getUsersWithNodeHyperdata :: User -> Cmd err [(UserLight, Node HyperdataUser)]
getUsersWithNodeHyperdata i = do
u <- getUsersWithId i
h <- getUserNodeHyperdata i
......@@ -208,8 +246,8 @@ updateUserPassword (UserLight { userLight_password = GargPassword password, .. }
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uUpdateWith = updateEasy (\(UserDB { .. }) -> UserDB { user_password = sqlStrictText password, .. } )
, uWhere = \row -> user_id row .== sqlInt4 userLight_id
, uReturning = rCount }
updateUserForgotPasswordUUID :: UserLight -> Cmd err Int64
......@@ -219,9 +257,23 @@ updateUserForgotPasswordUUID (UserLight { .. }) = mkCmd $ \c -> runUpdate_ c upd
updateUserQuery :: Update Int64
updateUserQuery = Update
{ uTable = userTable
, uUpdateWith = updateEasy (\ (UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
, uWhere = (\row -> user_id row .== (sqlInt4 userLight_id))
, uUpdateWith = updateEasy (\(UserDB { .. }) -> UserDB { user_forgot_password_uuid = pass, .. })
, uWhere = \row -> user_id row .== sqlInt4 userLight_id
, uReturning = rCount }
getUserPubmedAPIKey :: User -> Cmd err (Maybe PUBMED.APIKey)
getUserPubmedAPIKey user = do
hs <- getUserHyperdata user
case hs of
[] -> pure Nothing
(x:_) -> pure $ _hu_pubmed_api_key x
updateUserPubmedAPIKey :: (HasDBid NodeType, HasNodeError err)
=> User -> PUBMED.APIKey -> Cmd err Int64
updateUserPubmedAPIKey (RootId uId) apiKey = do
_ <- updateNodeWithType uId NodeUser (Proxy :: Proxy HyperdataUser) (\h -> h & hu_pubmed_api_key ?~ apiKey)
pure 1
updateUserPubmedAPIKey _ _ = undefined
------------------------------------------------------------------
-- | Select User with some parameters
-- Not optimized version
......
src/Gargantext/Database/Schema/Node.hs
View file @ 8aeae22e
......@@ -72,23 +72,27 @@ nodeTable = Table "nodes" (pNode Node { _node_id = optionalTableField "i
queryNodeTable :: Query NodeRead
queryNodeTable = selectTable nodeTable
------------------------------------------------------------------------
type NodeWrite = NodePoly (Maybe (Field SqlInt4) )
(Maybe (Field SqlText) )
(Field SqlInt4)
(Field SqlInt4)
(Maybe (Field SqlInt4) )
(Field SqlText)
(Maybe (Field SqlTimestamptz))
(Field SqlJsonb)
type NodeRead = NodePoly (Field SqlInt4 )
(Field SqlText )
(Field SqlInt4 )
(Field SqlInt4 )
(Field SqlInt4 )
(Field SqlText )
(Field SqlTimestamptz )
(Field SqlJsonb )
type NodeHWrite a = NodePoly (Maybe (Field SqlInt4) )
(Maybe (Field SqlText) )
(Field SqlInt4)
(Field SqlInt4)
(Maybe (Field SqlInt4) )
(Field SqlText)
(Maybe (Field SqlTimestamptz))
(Field a)
type NodeHRead a = NodePoly (Field SqlInt4 )
(Field SqlText )
(Field SqlInt4 )
(Field SqlInt4 )
(Field SqlInt4 )
(Field SqlText )
(Field SqlTimestamptz )
(Field a )
------------------------------------------------------------------------
type NodeWrite = NodeHWrite SqlJsonb
type NodeRead = NodeHRead SqlJsonb
------------------------------------------------------------------------
-- | Node(Read|Write)Search is slower than Node(Write|Read) use it
-- for full text search only
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment