Add test to add documents to corpus

We now require CoreNLP listening on port :9000. We will have to find
a way to spin that up in CI as well.

devops/postgres/schema.sql

@@ -272,7 +272,7 @@ CREATE INDEX        ON public.contexts USING btree (user_id, typename, parent_id
 CREATE INDEX        ON public.contexts USING btree (id, typename, date ASC);
 CREATE INDEX        ON public.contexts USING btree (id, typename, date DESC);
 CREATE INDEX        ON public.contexts USING btree (typename, id);
-CREATE UNIQUE INDEX IF NOT EXISTS ON public.contexts USING btree (hash_id);
+CREATE UNIQUE INDEX ON public.contexts USING btree (hash_id);
 
 CREATE INDEX ON public.nodescontexts_nodescontexts USING btree (nodescontexts1, nodescontexts2);
 -- CREATE UNIQUE INDEX ON public.nodes USING btree (((hyperdata ->> 'uniqId'::text)));

gargantext.cabal

@@ -119,6 +119,7 @@ library
       Gargantext.Database.Admin.Trigger.Init
       Gargantext.Database.Admin.Types.Hyperdata
       Gargantext.Database.Admin.Types.Hyperdata.Corpus
+      Gargantext.Database.Admin.Types.Hyperdata.Document
       Gargantext.Database.Admin.Types.Node
       Gargantext.Database.Prelude
       Gargantext.Database.Query.Table.NgramsPostag
@@ -303,7 +304,6 @@ library
       Gargantext.Database.Admin.Types.Hyperdata.CorpusField
       Gargantext.Database.Admin.Types.Hyperdata.Dashboard
       Gargantext.Database.Admin.Types.Hyperdata.Default
-      Gargantext.Database.Admin.Types.Hyperdata.Document
       Gargantext.Database.Admin.Types.Hyperdata.File
       Gargantext.Database.Admin.Types.Hyperdata.Folder
       Gargantext.Database.Admin.Types.Hyperdata.Frame
@@ -884,6 +884,8 @@ test-suite garg-test-tasty
       Core.Text.Flow
       Core.Utils
       Database.Operations
+      Database.Operations.DocumentSearch
+      Database.Operations.Types
       Graph.Clustering
       Graph.Distance
       Ngrams.Lang
@@ -952,6 +954,7 @@ test-suite garg-test-tasty
     , lens >= 5.2.2 && < 5.3
     , monad-control >= 1.0.3 && < 1.1
     , mtl ^>= 2.2.2
+    , network-uri
     , parsec ^>= 3.1.14.0
     , patches-class ^>= 0.1.0.1
     , patches-map ^>= 0.1.0.1
@@ -981,6 +984,8 @@ test-suite garg-test-hspec
   main-is: hspec/Main.hs
   other-modules:
       Database.Operations
+      Database.Operations.DocumentSearch
+      Database.Operations.Types
       Paths_gargantext
   hs-source-dirs:
       test
@@ -1032,6 +1037,7 @@ test-suite garg-test-hspec
     , lens >= 5.2.2 && < 5.3
     , monad-control >= 1.0.3 && < 1.1
     , mtl ^>= 2.2.2
+    , network-uri
     , parsec ^>= 3.1.14.0
     , patches-class ^>= 0.1.0.1
     , patches-map ^>= 0.1.0.1

src/Gargantext/API/Server.hs

@@ -83,7 +83,7 @@ showAsServantErr :: GargError -> ServerError
 showAsServantErr (GargNodeError err@(NoListFound {})) = err404 { errBody = BL8.pack $ show err }
 showAsServantErr (GargNodeError err@NoRootFound) = err404 { errBody = BL8.pack $ show err }
 showAsServantErr (GargNodeError err@NoCorpusFound) = err404 { errBody = BL8.pack $ show err }
-showAsServantErr (GargNodeError err@NoUserFound) = err404 { errBody = BL8.pack $ show err }
+showAsServantErr (GargNodeError err@NoUserFound{}) = err404 { errBody = BL8.pack $ show err }
 showAsServantErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = BL8.pack $ show err }
 showAsServantErr (GargServerError err) = err
 showAsServantErr a = err500 { errBody = BL8.pack $ show a }
@@ -92,7 +92,7 @@ showAsServantJSONErr :: GargError -> ServerError
 showAsServantJSONErr (GargNodeError err@(NoListFound {})) = err404 { errBody = Aeson.encode err }
 showAsServantJSONErr (GargNodeError err@NoRootFound) = err404 { errBody = Aeson.encode err }
 showAsServantJSONErr (GargNodeError err@NoCorpusFound) = err404 { errBody = Aeson.encode err }
-showAsServantJSONErr (GargNodeError err@NoUserFound) = err404 { errBody = Aeson.encode err }
+showAsServantJSONErr (GargNodeError err@NoUserFound{}) = err404 { errBody = Aeson.encode err }
 showAsServantJSONErr (GargNodeError err@(DoesNotExist {})) = err404 { errBody = Aeson.encode err }
 showAsServantJSONErr (GargServerError err) = err
 showAsServantJSONErr a = err500 { errBody = Aeson.encode a }

src/Gargantext/Core/Types/Individu.hs

 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 
 {-|
 Module      : Gargantext.Core.Types.Individu
@@ -25,11 +26,19 @@ import GHC.Generics (Generic)
 import Gargantext.Database.Admin.Types.Node (NodeId, UserId)
 import Gargantext.Prelude hiding (reverse)
 import qualified Gargantext.Prelude.Crypto.Auth as Auth
+import qualified Data.Text as T
 
 -- FIXME UserName used twice
 data User = UserDBId UserId | UserName Text | RootId NodeId | UserPublic
   deriving (Eq)
 
+renderUser :: User -> T.Text
+renderUser = \case
+  UserDBId urId -> T.pack (show urId)
+  UserName txt  -> txt
+  RootId   nId  -> T.pack (show nId)
+  UserPublic    -> T.pack "public"
+
 type Username = Text
 
 type HashPassword    = Auth.PasswordHash Auth.Argon2

src/Gargantext/Database/Action/User.hs

@@ -28,7 +28,7 @@ getUserLightWithId :: HasNodeError err => UserId -> DBCmd err UserLight
 getUserLightWithId i = do
   candidates <- head <$> getUsersWithId (UserDBId i)
   case candidates of
-    Nothing -> nodeError NoUserFound
+    Nothing -> nodeError (NoUserFound (UserDBId i))
     Just u  -> pure u
 
 getUserLightDB :: HasNodeError err => User -> DBCmd err UserLight
@@ -44,7 +44,7 @@ getUserId :: HasNodeError err
 getUserId u = do
   maybeUser <- getUserId' u
   case maybeUser of
-    Nothing -> nodeError NoUserFound
+    Nothing -> nodeError (NoUserFound u)
     Just u'  -> pure u'
 
 getUserId' :: HasNodeError err

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

@@ -14,17 +14,19 @@ import Control.Lens (Prism', (#), (^?))
 import Control.Monad.Except (MonadError(..))
 import Data.Aeson
 import Data.Text (Text, pack)
+import qualified Data.Text as T
 
 import Prelude hiding (null, id, map, sum)
 
 import Gargantext.Database.Admin.Types.Node (ListId, NodeId(..))
 import Gargantext.Prelude hiding (sum, head)
+import Gargantext.Core.Types.Individu
 
 ------------------------------------------------------------------------
 data NodeError = NoListFound { listId :: ListId }
                | NoRootFound
                | NoCorpusFound
-               | NoUserFound
+               | NoUserFound User
                | MkNode
                | UserNoParent
                | HasParent
@@ -41,7 +43,7 @@ instance Show NodeError
     show (NoListFound {})   = "No list   found"
     show NoRootFound   = "No Root   found"
     show NoCorpusFound = "No Corpus found"
-    show NoUserFound   = "No user   found"
+    show (NoUserFound ur) = "User(" <> T.unpack (renderUser ur) <> ") not found"
 
     show MkNode        = "Cannot make node"
     show NegativeId    = "Node with negative Id"

test-data/docker-compose.yml

+version: '3'
+
+services:
+  corenlp:
+    image: 'cgenie/corenlp-garg:4.5.4'
+    ports:
+      - 9000:9000

test-data/test_config.ini

@@ -16,3 +16,8 @@ MAX_DOCS_SCRAPERS = 10000
 JS_JOB_TIMEOUT = 1800
 JS_ID_TIMEOUT = 1800
 PUBMED_API_KEY = "no_key"
+
+[nlp]
+EN = corenlp://localhost:9000
+FR = spacy://localhost:8001
+All = corenlp://localhost:9000

test/Database/Operations.hs

@@ -10,22 +10,19 @@ module Database.Operations (
   ) where
 
 import Control.Exception hiding (assert)
-import Control.Lens hiding (elements)
 import Control.Monad.Except
 import Control.Monad.Reader
-import Control.Monad.Trans.Control
-import Data.IORef
 import Data.Pool hiding (withResource)
 import Data.String
 import Database.PostgreSQL.Simple
+import Gargantext.API.Node.Corpus.Update
+import Gargantext.Core
 import Gargantext.Core.Types.Individu
 import Gargantext.Database.Action.User
 import Gargantext.Database.Action.User.New
 import Gargantext.Database.Admin.Types.Hyperdata.Corpus
 import Gargantext.Database.Admin.Types.Node
-import Gargantext.Database.Prelude
 import Gargantext.Database.Query.Table.Node (mk, getCorporaWithParentId)
-import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Tree.Root (getRootId)
 import Gargantext.Database.Schema.Node (NodePoly(..))
 import Gargantext.Prelude
@@ -40,18 +37,13 @@ import qualified Database.PostgreSQL.Simple.Options as Client
 import qualified Database.Postgres.Temp as Tmp
 import qualified Shelly as SH
 
+import Database.Operations.Types
+import Database.Operations.DocumentSearch
 import Paths_gargantext
 import Test.Hspec
 import Test.QuickCheck.Monadic
 import Test.Tasty.HUnit hiding (assert)
 import Test.Tasty.QuickCheck
-import Gargantext.API.Node.Corpus.Update
-import Gargantext.Core
-import Gargantext.Utils.Jobs
-import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
-import Gargantext.API.Admin.EnvTypes
-import Gargantext.API.Prelude
-import Gargantext.API.Admin.Orchestrator.Types
 
 -- | Keeps a log of usernames we have already generated, so that our
 -- roundtrip tests won't fail.
@@ -70,62 +62,6 @@ dbUser = "gargantua"
 dbPassword = "gargantua_test"
 dbName = "gargandb_test"
 
-newtype Counter = Counter { _Counter :: IORef Int }
-  deriving Eq
-
-instance Show Counter where
-  show (Counter _) = "Counter"
-
-emptyCounter :: IO Counter
-emptyCounter = Counter <$> newIORef 0
-
-nextCounter :: Counter -> IO Int
-nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
-
-data TestEnv = TestEnv {
-    test_db          :: !DBHandle
-  , test_config      :: !GargConfig
-  , test_usernameGen :: !Counter
-  }
-
-newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
-  deriving ( Functor, Applicative, Monad
-           , MonadReader TestEnv, MonadError IOException
-           , MonadBase IO
-           , MonadBaseControl IO
-           , MonadFail
-           , MonadIO
-           )
-
-instance MonadJobStatus TestMonad where
-  type JobHandle      TestMonad = EnvTypes.ConcreteJobHandle GargError
-  type JobType        TestMonad = GargJob
-  type JobOutputType  TestMonad = JobLog
-  type JobEventType   TestMonad = JobLog
-
-  getLatestJobStatus _  = TestMonad (pure noJobLog)
-  withTracer _ jh n     = n jh
-  markStarted _ _       = TestMonad $ pure ()
-  markProgress _ _      = TestMonad $ pure ()
-  markFailure _ _ _     = TestMonad $ pure ()
-  markComplete _        = TestMonad $ pure ()
-  markFailed _ _        = TestMonad $ pure ()
-  addMoreSteps _ _      = TestMonad $ pure ()
-
-data DBHandle = DBHandle {
-    _DBHandle :: Pool PG.Connection
-  , _DBTmp    :: Tmp.DB
-  }
-
-instance HasNodeError IOException where
-  _NodeError = prism' (userError . show) (const Nothing)
-
-instance HasConnectionPool TestEnv where
-  connPool = to (_DBHandle . test_db)
-
-instance HasConfig TestEnv where
-  hasConfig = to test_config
-
 fakeIniPath :: IO FilePath
 fakeIniPath = getDataFileName "test-data/test_config.ini"
 
@@ -263,10 +199,3 @@ corpusAddLanguage env = do
     addLanguageToCorpus (_node_id corpus) IT
     [corpus'] <- getCorporaWithParentId parentId
     liftIO $ (_hc_lang . _node_hyperdata $ corpus') `shouldBe` Just IT
-
-corpusAddDocuments :: TestEnv -> Assertion
-corpusAddDocuments env = do
-  flip runReaderT env $ runTestMonad $ do
-    parentId <- getRootId (UserName "alfredo")
-    [_corpus] <- getCorporaWithParentId parentId
-    pure ()

test/Database/Operations/DocumentSearch.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+module Database.Operations.DocumentSearch where
+
+import Prelude
+
+import Control.Monad.Reader
+import Data.Aeson.QQ.Simple
+import Data.Aeson.Types
+import Data.Maybe
+import Gargantext.Core
+import Gargantext.Core.Types.Individu
+import Gargantext.Database.Action.Flow
+import Gargantext.Database.Action.User
+import Gargantext.Database.Action.User.New
+import Gargantext.Database.Admin.Types.Hyperdata.Corpus
+import Gargantext.Database.Admin.Types.Hyperdata.Document
+import Gargantext.Database.Query.Table.Node
+import Gargantext.Database.Query.Tree.Root
+import Gargantext.Database.Schema.Node (NodePoly(..))
+import Network.URI (parseURI)
+
+import Test.Tasty.HUnit
+import Database.Operations.Types
+
+
+exampleDocument_01 :: HyperdataDocument
+exampleDocument_01 = either error id $ parseEither parseJSON $ [aesonQQ|
+  { "doi":"sdfds"
+  , "publication_day":6
+  , "language_iso2":"en"
+  , "publication_minute":0
+  , "publication_month":7
+  , "language_iso3":"eng"
+  , "publication_second":0
+  , "authors":"Nils Hovdenak, Kjell Haram"
+  , "publication_year":2012
+  , "publication_date":"2012-07-06 00:00:00+00:00"
+  , "language_name":"English"
+  , "realdate_full_":"2012 01 12"
+  , "source":"European journal of obstetrics, gynecology, and reproductive biology Institute"
+  , "abstract":"The literature was searched for publications on minerals and vitamins during pregnancy and the possible influence of supplements on pregnancy outcome."
+  , "title":"Influence of mineral and vitamin supplements on pregnancy outcome."
+  , "publication_hour":0
+  }
+|]
+
+exampleDocument_02 :: HyperdataDocument
+exampleDocument_02 = either error id $ parseEither parseJSON $ [aesonQQ|
+  { "doi":"sdfds"
+  , "publication_day":6
+  , "language_iso2":"en"
+  , "publication_minute":0
+  , "publication_month":7
+  , "language_iso3":"eng"
+  , "publication_second":0
+  , "authors":"Ajeje Brazorf and Manuel Agnelli"
+  , "publication_year":2012
+  , "publication_date":"2012-07-06 00:00:00+00:00"
+  , "language_name":"English"
+  , "realdate_full_":"2012 01 12"
+  , "source":"Malagrotta Institute of Technology"
+  , "abstract":"We present PyPlasm, an innovative approach to computational graphics"
+  , "title":"PyPlasm: computational geometry made easy"
+  , "publication_hour":0
+  }
+|]
+
+nlpServerConfig :: NLPServerConfig
+nlpServerConfig =
+  let uri = parseURI "http://localhost:9000"
+  in NLPServerConfig CoreNLP (fromMaybe (error "parseURI for nlpServerConfig failed") uri)
+
+corpusAddDocuments :: TestEnv -> Assertion
+corpusAddDocuments env = do
+  flip runReaderT env $ runTestMonad $ do
+
+    -- NOTE(adn) We need to create user 'gargantua'(!!) in order
+    -- for 'addDocumentsToHyperCorpus' to work.
+    let nur = mkNewUser "gargantua@foo.com" (GargPassword "my_secret")
+    void $ new_user nur
+    uid      <- getUserId (UserName "alfredo")
+    parentId <- getRootId (UserName "gargantua")
+    void $ mk (Just "Test_Corpus") (Nothing :: Maybe HyperdataCorpus) parentId uid
+    [corpus] <- getCorporaWithParentId parentId
+
+    _ids <- addDocumentsToHyperCorpus nlpServerConfig
+                                      (Just $ _node_hyperdata $ corpus)
+                                      (Multi EN)
+                                      (_node_id corpus)
+                                      [exampleDocument_01]
+    pure ()

test/Database/Operations/Types.hs

+{-# LANGUAGE TypeFamilies         #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# OPTIONS_GHC -Wno-orphans      #-}
+
+module Database.Operations.Types where
+
+import Control.Exception
+import Control.Lens
+import Control.Monad.Except
+import Control.Monad.Reader
+import Control.Monad.Trans.Control
+import Data.IORef
+import Data.Pool
+import Gargantext
+import Gargantext.API.Admin.EnvTypes
+import Gargantext.API.Admin.Orchestrator.Types
+import Gargantext.API.Prelude
+import Gargantext.Database.Query.Table.Node.Error
+import Gargantext.Prelude.Config
+import Gargantext.Utils.Jobs
+import Prelude
+import qualified Database.PostgreSQL.Simple as PG
+import qualified Database.Postgres.Temp as Tmp
+import qualified Gargantext.API.Admin.EnvTypes as EnvTypes
+
+newtype Counter = Counter { _Counter :: IORef Int }
+  deriving Eq
+
+instance Show Counter where
+  show (Counter _) = "Counter"
+
+emptyCounter :: IO Counter
+emptyCounter = Counter <$> newIORef 0
+
+nextCounter :: Counter -> IO Int
+nextCounter (Counter ref) = atomicModifyIORef' ref (\old -> (succ old, old))
+
+data TestEnv = TestEnv {
+    test_db          :: !DBHandle
+  , test_config      :: !GargConfig
+  , test_usernameGen :: !Counter
+  }
+
+newtype TestMonad a = TestMonad { runTestMonad :: ReaderT TestEnv IO a }
+  deriving ( Functor, Applicative, Monad
+           , MonadReader TestEnv, MonadError IOException
+           , MonadBase IO
+           , MonadBaseControl IO
+           , MonadFail
+           , MonadIO
+           )
+
+instance MonadJobStatus TestMonad where
+  type JobHandle      TestMonad = EnvTypes.ConcreteJobHandle GargError
+  type JobType        TestMonad = GargJob
+  type JobOutputType  TestMonad = JobLog
+  type JobEventType   TestMonad = JobLog
+
+  getLatestJobStatus _  = TestMonad (pure noJobLog)
+  withTracer _ jh n     = n jh
+  markStarted _ _       = TestMonad $ pure ()
+  markProgress _ _      = TestMonad $ pure ()
+  markFailure _ _ _     = TestMonad $ pure ()
+  markComplete _        = TestMonad $ pure ()
+  markFailed _ _        = TestMonad $ pure ()
+  addMoreSteps _ _      = TestMonad $ pure ()
+
+data DBHandle = DBHandle {
+    _DBHandle :: Pool PG.Connection
+  , _DBTmp    :: Tmp.DB
+  }
+
+instance HasNodeError IOException where
+  _NodeError = prism' (userError . show) (const Nothing)
+
+instance HasConnectionPool TestEnv where
+  connPool = to (_DBHandle . test_db)
+
+instance HasConfig TestEnv where
+  hasConfig = to test_config
+