[tests] better startup of corenlp

Take into account the async nature of createProcess. Add proper watch
so that we monitor that coreNLP is running.
parent bde033f9
Pipeline #7738 canceled with stages
in 7 minutes and 46 seconds
...@@ -7,6 +7,7 @@ import Control.Monad ...@@ -7,6 +7,7 @@ import Control.Monad
import Data.Text qualified as T import Data.Text qualified as T
import Gargantext.Prelude hiding (isInfixOf) import Gargantext.Prelude hiding (isInfixOf)
import System.IO import System.IO
import System.IO.Error (userError)
import System.Process import System.Process
import System.Posix.Process import System.Posix.Process
import System.Posix.Signals import System.Posix.Signals
...@@ -17,13 +18,13 @@ import Test.Hspec ...@@ -17,13 +18,13 @@ import Test.Hspec
import Test.Server.ReverseProxy qualified as ReverseProxy import Test.Server.ReverseProxy qualified as ReverseProxy
startCoreNLPServer :: IO ProcessHandle startCoreNLPServer :: IO (Handle, Handle, ProcessHandle)
startCoreNLPServer = do startCoreNLPServer = do
putText "calling start core nlp" putText "calling start core nlp"
devNull <- openFile "/dev/null" WriteMode -- devNull <- openFile "/dev/null" WriteMode
let p = proc "nix" [ "run" let p = proc "nix" [ "run"
, "git+https://gitlab.iscpif.fr/gargantext/corenlp-nix.git" ] , "git+https://gitlab.iscpif.fr/gargantext/corenlp-nix.git" ]
(_, _, _, hdl) <- (createProcess $ p { cwd = Nothing (_, m_stdout_hdl, m_stderr_hdl, hdl) <- (createProcess $ p { cwd = Nothing
-- NOTE(adn) Issue #451, this one has to stay disabled, because if we -- NOTE(adn) Issue #451, this one has to stay disabled, because if we
-- turn it on, despite the confusing documentation on the `process` library -- turn it on, despite the confusing documentation on the `process` library
-- it will cause the Haskell RTS to completely ignore the Ctrl^c and instead -- it will cause the Haskell RTS to completely ignore the Ctrl^c and instead
...@@ -32,17 +33,23 @@ startCoreNLPServer = do ...@@ -32,17 +33,23 @@ startCoreNLPServer = do
-- to Ctrl^C requests. -- to Ctrl^C requests.
, delegate_ctlc = False , delegate_ctlc = False
, create_group = True , create_group = True
, std_out = UseHandle devNull , std_out = CreatePipe
, std_err = UseHandle devNull , std_err = CreatePipe
-- , std_out = UseHandle devNull
-- , std_err = UseHandle devNull
}) `catch` \(e :: SomeException) -> }) `catch` \(e :: SomeException) ->
case e of case e of
_ | True <- "does not exist" `T.isInfixOf` (T.pack . show @SomeException $ e) _ | True <- "does not exist" `T.isInfixOf` (T.pack . show @SomeException $ e)
-> fail $ "Cannot execute the 'corenlp' via nix flakes. Make sure you are in a nix environment." -> fail $ "Cannot execute the 'corenlp' via nix flakes. Make sure you have 'nix' installed."
| otherwise -> throwIO e | otherwise -> throwIO e
pure hdl
killProcessTree :: ProcessHandle -> IO () let stdout_hdl = fromMaybe (errorTrace "Can't get stdout handle!") m_stdout_hdl
killProcessTree ph = do let stderr_hdl = fromMaybe (errorTrace "Can't get stderr handle!") m_stderr_hdl
pure (stdout_hdl, stderr_hdl, hdl)
killProcessTree :: (Handle, Handle, ProcessHandle) -> IO ()
killProcessTree (_, _, ph) = do
pid <- getPid ph pid <- getPid ph
case pid of case pid of
Nothing -> putText "Process already terminated" Nothing -> putText "Process already terminated"
...@@ -50,6 +57,23 @@ killProcessTree ph = do ...@@ -50,6 +57,23 @@ killProcessTree ph = do
pgid <- getProcessGroupIDOf p pgid <- getProcessGroupIDOf p
signalProcessGroup keyboardSignal pgid signalProcessGroup keyboardSignal pgid
-- NOTE(seeg) createProcess is nonblocking, and so its exception
-- handling is incomplete:
-- λ> createProcess $ proc "l" []
-- *** Exception: l: createProcess: posix_spawnp: does not exist (No such file or directory)
-- λ> createProcess $ proc "ls" ["haha"]
-- ls: cannot access 'haha': No such file or directory
-- Credit for this construct goes to @adn
waitOrDie :: (Handle, Handle, ProcessHandle) -> IO ()
waitOrDie (stdout_h, stderr_h, h) = do
ec <- waitForProcess h
when (ec /= ExitSuccess) $ do
out <- hGetContents stdout_h
err <- hGetContents stderr_h
throwIO $ userError ("Async process quit!\nStdout:\n" <> out <> "\nStderr:\n" <> err)
-- It's especially important to use Hspec for DB tests, because, -- It's especially important to use Hspec for DB tests, because,
-- unlike 'tasty', 'Hspec' has explicit control over parallelism, -- unlike 'tasty', 'Hspec' has explicit control over parallelism,
-- and it's important that DB tests are run according to a very -- and it's important that DB tests are run according to a very
...@@ -60,7 +84,7 @@ killProcessTree ph = do ...@@ -60,7 +84,7 @@ killProcessTree ph = do
main :: IO () main :: IO ()
main = do main = do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
bracket startCoreNLPServer killProcessTree (const run_tests) bracket startCoreNLPServer killProcessTree (\h -> race (waitOrDie h) run_tests *> pure())
where where
run_tests = hspec $ sequential $ do run_tests = hspec $ sequential $ do
API.tests API.tests
......
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