concurrency & dyre fixes for server spec

1 files changed, 25 insertions, 18 deletions

diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
index 0d698f0..fe06a05 100644
--- a/server/test/Thermoprint/ServerSpec.hs
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -3,27 +3,29 @@
 
 module Thermoprint.ServerSpec (spec) where
 
-import Test.Hspec
+import           Test.Hspec
 
-import Thermoprint.API
-import Thermoprint.Server
+import           Thermoprint.API
+import           Thermoprint.Server
 
-import Control.Monad
-import Control.Monad.Logger
-import Control.Monad.Reader
-import Control.Monad.Trans.Identity
-import Control.Monad.Trans.Resource
+import           Control.Monad
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Identity
+import           Control.Monad.Trans.Resource
 
-import Database.Persist.Sqlite
+import           Database.Persist.Sqlite
 
-import Control.Concurrent
-import Control.Concurrent.STM
+import           Control.Concurrent
+import           Control.Concurrent.STM
 
-import System.IO
-import System.IO.Temp
+import           System.IO
+import           System.IO.Temp
 
 import qualified Data.Text as T
 
+import           Debug.Trace
+
 data TestPrinter = TestPrinter
   { outputChan :: TChan Printout
   , failSwitch :: TMVar PrintingError
@@ -33,13 +35,14 @@ data TestManager = TestManager
   { manage :: TMVar (QueueManager IdentityT)
   }
 
-setup :: IO (ThreadId, TestPrinter, TestManager)
+setup :: IO (ThreadId, QSem, TestPrinter, TestManager)
 setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
   tPrinter <- TestPrinter <$> newTChanIO <*> newEmptyTMVarIO
   tManager <- TestManager <$> newEmptyTMVarIO
+  termSem <- newQSem 0
   let
     runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
-    runSqlite = runStderrLoggingT . withSqlitePool (T.pack fp) 1 . runReaderT
+    runSqlite = runNoLoggingT . withSqlitePool (T.pack fp) 1 . runReaderT
 
     printers = [ ( pure $ PM tPM
                  , QMConfig (join . lift $ takeTMVar (manage tManager)) (Nat $ liftIO . runIdentityT)
@@ -48,12 +51,16 @@ setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
 
     tPM :: MonadIO m => Printout -> m (Maybe PrintingError)
     tPM printout = liftIO . atomically $ writeTChan (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter)
-  (,,) <$> forkIO (thermoprintServer (Nat runSqlite) $ def `withPrinters` printers) <*> pure tPrinter <*> pure tManager
+  (,,,) <$> forkFinally (thermoprintServer False (Nat runSqlite) $ def `withPrinters` printers) (const $ signalQSem termSem) <*> pure termSem <*> pure tPrinter <*> pure tManager
+
+withSetup :: SpecWith (ThreadId, QSem, TestPrinter, TestManager) -> Spec
+withSetup = beforeAll setup . afterAll (\(tId, termSem, _, _) -> killThread tId >> waitQSem termSem)
 
 spec :: Spec
-spec = beforeAll setup $ do
+spec = withSetup $ do
   describe "blubTests" $ do
-    it "prints Blub." $ \(tId, _, _) -> do
+    it "prints Blub." $ \(tId, _, _, _) -> do
+      threadDelay 5000
       putStrLn "Blub."
       System.IO.print tId
       True `shouldSatisfy` id