[pubmed] implement per-user api keys

gargantext.cabal

@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           gargantext
-version: 0.0.6.9.9.3.2
+version:        0.0.6.9.9.3.2
 synopsis:       Search, map, share
 description:    Please see README.md
 category:       Data

src/Gargantext/API/GraphQL.hs

@@ -74,6 +74,7 @@ data Query m
     , job_logs            :: GQLAT.JobLogArgs -> m (Map Int JobLog)
     , languages           :: GQLNLP.LanguagesArgs -> m GQLNLP.LanguagesMap
     , nodes               :: GQLNode.NodeArgs -> m [GQLNode.Node]
+    , nodes_corpus        :: GQLNode.CorpusArgs -> m [GQLNode.Corpus]
     , node_parent         :: GQLNode.NodeParentArgs -> m [GQLNode.Node]
     , user_infos          :: GQLUserInfo.UserInfoArgs -> m [GQLUserInfo.UserInfo]
     , users               :: GQLUser.UserArgs -> m [GQLUser.User m]
@@ -117,6 +118,7 @@ rootResolver =
                             , job_logs            = GQLAT.resolveJobLogs
                             , languages           = GQLNLP.resolveLanguages
                             , nodes               = GQLNode.resolveNodes
+                            , nodes_corpus        = GQLNode.resolveNodesCorpus
                             , node_parent         = GQLNode.resolveNodeParent
                             , user_infos          = GQLUserInfo.resolveUserInfos
                             , users               = GQLUser.resolveUsers

src/Gargantext/API/GraphQL/Node.hs

@@ -3,7 +3,9 @@
 
 module Gargantext.API.GraphQL.Node where
 
+import Data.Aeson
 import Data.Either (Either(..))
+import qualified Data.HashMap.Strict as HashMap
 import Data.Morpheus.Types
   ( GQLType
   , Resolver
@@ -16,23 +18,37 @@ import Gargantext.API.Prelude (GargM, GargError)
 import Gargantext.Database.Admin.Types.Node (NodeId(..), NodeType)
 import qualified Gargantext.Database.Admin.Types.Node as NN
 import Gargantext.Database.Query.Table.Node (getClosestParentIdByType, getNode)
-import Gargantext.Database.Prelude (CmdCommon)
+import Gargantext.Database.Prelude (CmdCommon)  -- , JSONB)
 import qualified Gargantext.Database.Schema.Node as N
 import Gargantext.Prelude
 import GHC.Generics (Generic)
 import qualified Prelude
+import qualified PUBMED.Types as PUBMED
 import Text.Read (readEither)
 
+data Corpus = Corpus
+  { id           :: Int
+  , name         :: Text
+  , parent_id    :: Maybe Int
+  , pubmedAPIKey :: Maybe PUBMED.APIKey
+  , type_id      :: Int
+  } deriving (Show, Generic, GQLType)
+
 data Node = Node
-  { id        :: Int
-  , name      :: Text
-  , parent_id :: Maybe Int
-  , type_id   :: Int
+  { id           :: Int
+  , name         :: Text
+  , parent_id    :: Maybe Int
+  , type_id      :: Int
   } deriving (Show, Generic, GQLType)
 
+data CorpusArgs
+  = CorpusArgs
+    { corpus_id :: Int
+    } deriving (Generic, GQLType)
+
 data NodeArgs
   = NodeArgs
-    { node_id        :: Int
+    { node_id :: Int
     } deriving (Generic, GQLType)
 
 type GqlM e env = Resolver QUERY e (GargM env GargError)
@@ -43,6 +59,11 @@ resolveNodes
   => NodeArgs -> GqlM e env [Node]
 resolveNodes NodeArgs { node_id } = dbNodes node_id
 
+resolveNodesCorpus
+  :: (CmdCommon env)
+  => CorpusArgs -> GqlM e env [Corpus]
+resolveNodesCorpus CorpusArgs { corpus_id } = dbNodesCorpus corpus_id
+
 dbNodes
   :: (CmdCommon env)
   => Int -> GqlM e env [Node]
@@ -50,6 +71,13 @@ dbNodes node_id = do
   node <- lift $ getNode $ NodeId node_id
   pure [toNode node]
 
+dbNodesCorpus
+  :: (CmdCommon env)
+  => Int -> GqlM e env [Corpus]
+dbNodesCorpus corpus_id = do
+  corpus <- lift $ getNode $ NodeId corpus_id
+  pure [toCorpus corpus]
+
 data NodeParentArgs
   = NodeParentArgs
     { node_id     :: Int
@@ -79,7 +107,23 @@ dbParentNodes node_id parent_type = do
           pure [toNode node]
 
 toNode :: NN.Node json -> Node
-toNode (N.Node { .. }) = Node { id = NN.unNodeId _node_id
-                              , name = _node_name
-                              , parent_id = NN.unNodeId <$> _node_parent_id
-                              , type_id = _node_typename }
+toNode N.Node { .. } = Node { id = NN.unNodeId _node_id
+                            , name = _node_name
+                            , parent_id = NN.unNodeId <$> _node_parent_id
+                            , type_id = _node_typename }
+
+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
+pubmedAPIKeyFromValue (Object kv) =
+  case HashMap.lookup "pubmed_api_key" kv of
+    Nothing -> Nothing
+    Just v  -> case fromJSON v of
+      Error _    -> Nothing
+      Success v' -> Just v'
+pubmedAPIKeyFromValue _           = Nothing

src/Gargantext/API/Node/Corpus/New.hs

@@ -56,7 +56,7 @@ import Gargantext.Database.Action.User (getUserId)
 import Gargantext.Database.Admin.Types.Hyperdata
 import Gargantext.Database.Admin.Types.Node (CorpusId, NodeType(..), UserId)
 import Gargantext.Database.Prelude (hasConfig)
-import Gargantext.Database.Query.Table.Node (getNodeWith)
+import Gargantext.Database.Query.Table.Node (getNodeWith, updateCorpusPubmedAPIKey)
 import Gargantext.Database.Query.Table.Node.UpdateOpaleye (updateHyperdata)
 import Gargantext.Database.Schema.Node (node_hyperdata)
 import Gargantext.Prelude
@@ -209,6 +209,12 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       markComplete jobHandle
 
     _ -> do
+      case datafield of
+         Just (External (PubMed { _api_key })) -> do
+           printDebug "[addToCorpusWithQuery] pubmed api key" _api_key
+           _ <- updateCorpusPubmedAPIKey cid _api_key
+           pure ()
+         _ -> pure ()
       markStarted 3 jobHandle
 
       -- TODO add cid
@@ -227,7 +233,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
           markProgress 1 jobHandle
 
           void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle
-          -- printDebug "corpus id" cids
+-- printDebug "corpus id" cids
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...

src/Gargantext/API/Node/Corpus/Types.hs

@@ -3,28 +3,23 @@
 module Gargantext.API.Node.Corpus.Types where
 
 import Control.Lens hiding (elements, Empty)
-import Control.Monad.Fail (fail)
 import Control.Monad.Reader (MonadReader)
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import Data.Monoid (mempty)
 import Data.Swagger
-import Data.Text (Text)
-import qualified Data.Text as T
 import GHC.Generics (Generic)
-import Text.Regex.TDFA ((=~))
+import qualified PUBMED.Types as PUBMED
 
-import Protolude ((++))
 import Gargantext.Prelude
 
 import qualified Gargantext.API.Admin.Orchestrator.Types as T
 import Gargantext.Core.Utils.Prefix (unPrefix)
 import Gargantext.Database.Action.Flow (DataOrigin(..))
 import Gargantext.Database.Prelude (HasConfig(..))
-import Gargantext.Prelude.Config (gc_pubmed_api_key)
 
 data Database = Empty
-              | PubMed
+              | PubMed { _api_key :: Maybe PUBMED.APIKey }
               | Arxiv
               | HAL
               | IsTex
@@ -32,15 +27,16 @@ data Database = Empty
   deriving (Eq, Show, Generic)
 
 deriveJSON (unPrefix "") ''Database
-instance ToSchema Database
+instance ToSchema Database where
+  declareNamedSchema = genericDeclareNamedSchemaUnrestricted defaultSchemaOptions
 
 database2origin :: ( MonadReader env m
                    , HasConfig env ) => Database -> m DataOrigin
 database2origin Empty   = pure $ InternalOrigin T.IsTex
-database2origin PubMed  = do
-  pubmed_api_key <- view $ hasConfig . gc_pubmed_api_key
+database2origin (PubMed { _api_key }) = do
+  -- pubmed_api_key <- view $ hasConfig . gc_pubmed_api_key
 
-  pure $ ExternalOrigin $ T.PubMed { mAPIKey = Just pubmed_api_key }
+  pure $ ExternalOrigin $ T.PubMed { mAPIKey = _api_key }
 database2origin Arxiv   = pure $ ExternalOrigin T.Arxiv
 database2origin HAL     = pure $ ExternalOrigin T.HAL
 database2origin IsTex   = pure $ ExternalOrigin T.IsTex
@@ -48,27 +44,29 @@ database2origin Isidore = pure $ ExternalOrigin T.Isidore
 
 ------------------------------------------------------------------------
 data Datafield = Gargantext
-               | External (Maybe Database)
+               | External Database
                | Web
                | Files
   deriving (Eq, Show, Generic)
 
-instance FromJSON Datafield where
-  parseJSON = withText "Datafield" $ \text ->
-    case text of
-      "Gargantext" -> pure Gargantext
-      "Web" -> pure Web
-      "Files" -> pure Files
-      v ->
-        let (preExternal, _, postExternal) = v =~ ("External " :: Text) :: (Text, Text, Text)
-        in
-        if preExternal == "" then do
-          db <- parseJSON $ String postExternal
-          pure $ External db
-        else fail $ "Cannot match patterh 'External <db>' for string " ++ (T.unpack v)
-instance ToJSON Datafield where
-  toJSON (External db) = toJSON $ "External " ++ (show db)
-  toJSON s = toJSON $ show s
+instance FromJSON Datafield
+instance ToJSON Datafield
+-- instance FromJSON Datafield where
+--   parseJSON = withText "Datafield" $ \text ->
+--     case text of
+--       "Gargantext" -> pure Gargantext
+--       "Web" -> pure Web
+--       "Files" -> pure Files
+--       v ->
+--         let (preExternal, _, postExternal) = v =~ ("External " :: Text) :: (Text, Text, Text)
+--         in
+--         if preExternal == "" then do
+--           db <- parseJSON $ String postExternal
+--           pure $ External db
+--         else fail $ "Cannot match patterh 'External <db>' for string " ++ (T.unpack v)
+-- instance ToJSON Datafield where
+--   toJSON (External db) = toJSON $ "External " ++ (show db)
+--   toJSON s = toJSON $ show s
 instance ToSchema Datafield where
   declareNamedSchema _ = do
     return $ NamedSchema (Just "Datafield") $ mempty

src/Gargantext/API/Table.hs

@@ -74,11 +74,11 @@ type TableApi = Summary "Table API"
                 :> Get '[JSON] Text
 
 data TableQuery = TableQuery
-  { tq_offset  :: Offset
-  , tq_limit   :: Limit
-  , tq_orderBy :: OrderBy
-  , tq_view    :: TabType
-  , tq_query   :: Text
+  { tq_offset       :: Offset
+  , tq_limit        :: Limit
+  , tq_orderBy      :: OrderBy
+  , tq_view         :: TabType
+  , tq_query        :: Text
   } deriving (Generic)
 
 type FacetTableResult = TableResult FacetDoc

src/Gargantext/Core/Viz/Phylo/API/Tools.hs

@@ -12,10 +12,10 @@ Portability : POSIX
 module Gargantext.Core.Viz.Phylo.API.Tools
   where
 
-import Data.Proxy
 import Data.Aeson (Value, decodeFileStrict, eitherDecode, encode)
 import Data.Map.Strict (Map)
 import Data.Maybe (catMaybes)
+import Data.Proxy
 import Data.Set (Set)
 import Data.Text (Text, pack)
 import Data.Time.Calendar (fromGregorian, diffGregorianDurationClip, cdMonths, diffDays, showGregorian)

src/Gargantext/Database/Admin/Types/Hyperdata/Corpus.hs

@@ -24,22 +24,26 @@ module Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Prelude
 import Gargantext.Database.Admin.Types.Hyperdata.CorpusField
 import Gargantext.Database.Admin.Types.Hyperdata.Prelude
+import PUBMED.Types (APIKey)
 
 ------------------------------------------------------------------------
 data HyperdataCorpus =
-  HyperdataCorpus { _hc_fields :: ![HyperdataField CorpusField] }
+  HyperdataCorpus { _hc_fields         :: ![HyperdataField CorpusField]
+                  , _hc_pubmed_api_key :: Maybe APIKey }
     deriving (Generic)
 
 defaultHyperdataCorpus :: HyperdataCorpus
 defaultHyperdataCorpus =
-  HyperdataCorpus [ HyperdataField Markdown
-                                   "Corpus analysis"
-                                   (MarkdownField "# title\n## subtitle")
-
-                  , HyperdataField JSON
-                                   "Metadata (Experts only)"
-                                   (JsonField "Title" "Descr" "Bool query" "Authors")
-                  ]
+  HyperdataCorpus
+    { _hc_fields = [ HyperdataField Markdown
+                     "Corpus analysis"
+                     (MarkdownField "# title\n## subtitle")
+
+                   , HyperdataField JSON
+                     "Metadata (Experts only)"
+                     (JsonField "Title" "Descr" "Bool query" "Authors")
+                   ]
+    , _hc_pubmed_api_key = Nothing }
 
 ------------------------------------------------------------------------
 ------------------------------------------------------------------------

src/Gargantext/Database/Query/Table/Node.hs

@@ -29,6 +29,7 @@ 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
@@ -327,6 +328,31 @@ 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 -> Maybe PUBMED.APIKey -> Cmd err Int64
+updateCorpusPubmedAPIKey cId mAPIKey =
+  execPGSQuery query params
+  where
+    query :: PGS.Query
+    query = [sql|
+                UPDATE nodes
+                SET hyperdata = hyperdata || ?
+                WHERE id = ?
+            |]
+    params = (encode $ object [ "pubmed_api_key" .= mAPIKey ], cId)
 ------------------------------------------------------------------------
 -- TODO
 -- currently this function removes the child relation