From fff9cbfc9e7919723349e18c4b9aea89bcc48c1a Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Wed, 17 Feb 2016 01:05:57 +0000
Subject: Harness for tests of Thermoprint.Server

---
 server/test/Thermoprint/ServerSpec.hs | 59 +++++++++++++++++++++++++++++++++++
 server/thermoprint-server.cabal       | 14 +++++++--
 server/thermoprint-server.nix         | 11 ++++---
 3 files changed, 77 insertions(+), 7 deletions(-)
 create mode 100644 server/test/Thermoprint/ServerSpec.hs

(limited to 'server')

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
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 1ad4d4d..849d35a 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -36,16 +36,16 @@ library
                      , exceptions >=0.8.0 && <1
                      , monad-control >=1.0.0 && <2
                      , monad-logger >=0.3.13 && <1
+                     , resourcet >=1.1.7 && <2
                      , mtl >=2.2.1 && <3
+                     , transformers >=0.3.0 && <1
                      , persistent >=2.2 && <3
                      , persistent-template >=2.1.4 && <3
-                     , resourcet >=1.1.7 && <2
                      , servant-server >=0.4.4 && <1
                      , stm >=2.4.4 && <3
                      , text >=1.2.1 && <2
                      , thermoprint-spec ==3.0.*
                      , time >=1.5.0 && <2
-                     , transformers >=0.3.0 && <1
                      , wai >=3.0.4 && <4
                      , warp >=3.1.9 && <4
                      , mmorph >=1.0.4 && <2
@@ -65,8 +65,18 @@ Test-Suite tests
                      , thermoprint-server -any
                      , thermoprint-spec -any
                      , hspec >=2.2.1 && <3
+                     , hspec-contrib >=0.3.0 && <1
+                     , HUnit >=1.2.5 && <2
                      , QuickCheck >=2.8.1 && <3
                      , quickcheck-instances >=0.3.11 && <4
+                     , temporary >=1.2.0 && <2
+                     , monad-logger >=0.3.13 && <1
+                     , resourcet >=1.1.7 && <2
+                     , mtl >=2.2.1 && <3
+                     , transformers >=0.3.0 && <1
+                     , persistent-sqlite >=2.2 && <3
+                     , text >=1.2.1 && <2
+                     , stm >=2.4.4 && <3
 
 executable thermoprint-server
   main-is:             Main.hs
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 77911a8..737f571 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,10 +1,10 @@
 { mkDerivation, base, binary, bytestring, conduit, containers
 , data-default-class, deepseq, dyre, either, encoding, exceptions
-, extended-reals, filelock, hspec, mmorph, monad-control
-, monad-logger, mtl, persistent, persistent-sqlite
+, extended-reals, filelock, hspec, hspec-contrib, HUnit, mmorph
+, monad-control, monad-logger, mtl, persistent, persistent-sqlite
 , persistent-template, QuickCheck, quickcheck-instances, resourcet
-, servant-server, stdenv, stm, text, thermoprint-spec, time
-, transformers, wai, warp
+, servant-server, stdenv, stm, temporary, text, thermoprint-spec
+, time, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -23,7 +23,8 @@ mkDerivation {
     base monad-logger mtl persistent-sqlite resourcet
   ];
   testHaskellDepends = [
-    base hspec QuickCheck quickcheck-instances thermoprint-spec
+    base hspec hspec-contrib HUnit QuickCheck quickcheck-instances
+    temporary thermoprint-spec
   ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "Server for thermoprint-spec";
-- 
cgit v1.2.3