From 0c68925e930102686ca795970d2f1fe654acbec4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Thu, 25 Feb 2016 21:16:11 +0000
Subject: Catch early death of server thread during testing

---
 server/test/Thermoprint/ServerSpec.hs | 23 ++++++++++++++++++-----
 server/thermoprint-server.cabal       |  1 +
 server/thermoprint-server.nix         | 23 ++++++++++++-----------
 3 files changed, 31 insertions(+), 16 deletions(-)

diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
index deb2b9c..028ba2d 100644
--- a/server/test/Thermoprint/ServerSpec.hs
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -31,6 +31,10 @@ import           Database.Persist.Sqlite
 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Concurrent.STM.TSem
+import           Control.Concurrent.Async
+
+import           Control.Exception
+import           System.IO.Error
 
 import           System.IO
 import           System.IO.Temp
@@ -63,7 +67,8 @@ data TestManager = TestManager
 
 data RunningServer = RunningServer
   { thread :: ThreadId
-  , termination :: QSem
+  , termination :: MVar (Either SomeException ())
+  , startup :: QSem
   , printer :: TestPrinter
   , manager :: TestManager
   }
@@ -72,7 +77,8 @@ setup :: QSem -> IO RunningServer
 setup startup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
   tPrinter <- TestPrinter <$> newEmptyTMVarIO <*> newEmptyTMVarIO
   tManager <- TestManager <$> newEmptyTMVarIO <*> atomically (newTSem 0)
-  termSem <- newQSem 0
+  term <- newEmptyMVar
+  startSem <- newQSem 0
   let
     runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
     runSqlite = runStderrLoggingT . filterLogger (const (> LevelDebug)) . withSqlitePool (T.pack fp) 1 . runReaderT
@@ -84,7 +90,7 @@ setup startup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> d
 
     tPM :: MonadIO m => Printout -> m (Maybe PrintingError)
     tPM printout = liftIO . atomically $ putTMVar (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter)
-  RunningServer <$> forkFinally (S.thermoprintServer False (Nat runSqlite) $ def' `S.withPrinters` printers) (const $ signalQSem termSem) <*> pure termSem <*> pure tPrinter <*> pure tManager
+  RunningServer <$> forkFinally (S.thermoprintServer False (Nat runSqlite) $ def' `S.withPrinters` printers) (putMVar term) <*> pure term <*> pure startSem <*> pure tPrinter <*> pure tManager
   where
     def' :: MonadIO m => S.Config m
     def' = S.def { S.warpSettings = setBeforeMainLoop (signalQSem startup) $ defaultSettings }
@@ -94,8 +100,15 @@ withSetup = beforeAll setup' . afterAll teardown
   where
     setup' = do
       startup <- newQSem 0
-      setup startup <* waitQSem startup
-    teardown RunningServer{..} = killThread thread >> waitQSem termination
+      r <- setup startup
+      waitStartup <- async $ waitQSem startup
+      waitTermination <- async . readMVar $ termination r
+      wait <- waitEitherCancel waitTermination waitStartup
+      case wait of
+        Left (Left err) -> throwIO err
+        Left (Right _) -> throwIO $ userError "Server thread terminated early"
+        Right _ -> return r
+    teardown RunningServer{..} = killThread thread >> void (readMVar termination)
 
 spec :: Spec
 spec = withSetup $ do
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index f98cac1..89f636c 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -90,6 +90,7 @@ Test-Suite tests
                      , warp >=3.1.9 && <4
                      , exceptions >=0.8.0 && <1
                      , containers >=0.5.6 && <1
+                     , async >=2.1.0 && <3
 
 executable thermoprint-server
   main-is:             Main.hs
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 69ecd2f..6ff8b10 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,11 +1,11 @@
-{ mkDerivation, base, binary, bytestring, conduit, containers
-, data-default-class, deepseq, dyre, either, encoding, exceptions
-, extended-reals, filelock, hspec, mmorph, monad-control
-, monad-logger, mtl, network-uri, persistent, persistent-sqlite
-, persistent-template, QuickCheck, quickcheck-instances, resourcet
-, servant, servant-server, stdenv, stm, temporary, text
-, thermoprint-client, thermoprint-spec, time, transformers, wai
-, wai-websockets, warp, websockets
+{ mkDerivation, async, base, binary, bytestring, conduit
+, containers, data-default-class, deepseq, dyre, either, encoding
+, exceptions, extended-reals, filelock, hspec, mmorph
+, monad-control, monad-logger, mtl, network-uri, persistent
+, persistent-sqlite, persistent-template, QuickCheck
+, quickcheck-instances, resourcet, servant, servant-server, stdenv
+, stm, temporary, text, thermoprint-client, thermoprint-spec, time
+, transformers, wai, wai-websockets, warp, websockets
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -25,9 +25,10 @@ mkDerivation {
     base monad-logger mtl persistent-sqlite resourcet
   ];
   testHaskellDepends = [
-    base containers exceptions hspec monad-logger mtl persistent-sqlite
-    QuickCheck quickcheck-instances resourcet stm temporary text
-    thermoprint-client thermoprint-spec transformers warp
+    async base containers exceptions hspec monad-logger mtl
+    persistent-sqlite QuickCheck quickcheck-instances resourcet stm
+    temporary text thermoprint-client thermoprint-spec transformers
+    warp
   ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "Server for thermoprint-spec";
-- 
cgit v1.2.3