Harness for tests of Thermoprint.Server

1 files changed, 59 insertions, 0 deletions

diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
new file mode 100644
index 0000000..aa654b1
--- /dev/null
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE ImpredicativeTypes #-}
+
+module Thermoprint.ServerSpec (spec) where
+
+import Test.HUnit
+import Test.Hspec
+import Test.Hspec.Contrib.HUnit
+
+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 Database.Persist.Sqlite
+
+import Control.Concurrent
+import Control.Concurrent.STM
+
+import System.IO
+import System.IO.Temp
+
+import qualified Data.Text as T
+
+data TestPrinter = TestPrinter
+  { outputChan :: TChan Printout
+  , failSwitch :: TMVar PrintingError
+  }
+
+data TestManager = TestManager
+  { manage :: TMVar (QueueManager IdentityT)
+  }
+
+setup :: IO (ThreadId, TestPrinter, TestManager)
+setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
+  tPrinter <- TestPrinter <$> newTChanIO <*> newEmptyTMVarIO
+  tManager <- TestManager <$> newEmptyTMVarIO
+  let
+    runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
+    runSqlite = runStderrLoggingT . withSqlitePool (T.pack fp) 1 . runReaderT
+
+    printers = [ ( pure $ PM tPM
+                 , QMConfig (join . lift $ takeTMVar (manage tManager)) (Nat $ liftIO . runIdentityT)
+                 )
+               ]
+
+    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
+
+spec :: Spec
+spec = do
+  fromHUnitTest . test . ("blub" ~:) $ do
+    putStrLn "Blub."
+    return True