Api tests for Thermoprint.Server

2 files changed, 103 insertions, 36 deletions

diff --git a/server/test/Thermoprint/Server/QueueSpec.hs b/server/test/Thermoprint/Server/QueueSpec.hs
index 4a9297e..8a6bb7b 100644
--- a/server/test/Thermoprint/Server/QueueSpec.hs
+++ b/server/test/Thermoprint/Server/QueueSpec.hs
@@ -16,19 +16,6 @@ import Test.QuickCheck.Modifiers
 deriving instance (Eq PrintingError)
 deriving instance (Eq Queue)
 
-instance Arbitrary Queue where
-  arbitrary = Queue <$> arbitrary <*> arbitrary <*> arbitrary
-
-instance Arbitrary QueueEntry where
-  arbitrary = QueueEntry <$> arbitrary <*> arbitrary
-
-instance Arbitrary PrintingError where
-  arbitrary = oneof [ return (IOError "dummy")
-                    ]
-
-instance Arbitrary JobId where
-  arbitrary = castId . getNonNegative <$> (arbitrary :: Gen (NonNegative Integer))
-
 spec :: Spec
 spec = do
   describe "queue morphisms" $ do
diff --git a/server/test/Thermoprint/ServerSpec.hs b/server/test/Thermoprint/ServerSpec.hs
index 495ad10..deb2b9c 100644
--- a/server/test/Thermoprint/ServerSpec.hs
+++ b/server/test/Thermoprint/ServerSpec.hs
@@ -1,66 +1,146 @@
 {-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE OverloadedLists  #-}
 {-# LANGUAGE ImpredicativeTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 module Thermoprint.ServerSpec (spec) where
 
 import           Test.Hspec
+import           Test.Hspec.QuickCheck
+import qualified Test.Hspec as Hspec
+
+import           Test.QuickCheck
 
 import           Thermoprint.API
-import           Thermoprint.Server
+import qualified Thermoprint.Server as S
+import           Thermoprint.Client
 
+import           Data.Monoid
+import           Data.Function
 import           Control.Monad
 import           Control.Monad.Logger
 import           Control.Monad.Reader
+import           Control.Monad.State
 import           Control.Monad.Trans.Identity
 import           Control.Monad.Trans.Resource
+import           Control.Monad.Catch (finally)
 
 import           Database.Persist.Sqlite
 
 import           Control.Concurrent
 import           Control.Concurrent.STM
+import           Control.Concurrent.STM.TSem
 
 import           System.IO
 import           System.IO.Temp
 
 import qualified Data.Text as T
 
-import           Debug.Trace
+import           Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop)
+
+import qualified Data.Map as Map
+
+deriving instance Eq PrintingError
+deriving instance Eq JobStatus
+deriving instance Eq PrinterStatus
+
+-- Equality via cotext on Block
+instance Eq Block where
+  (==) = (==) `on` cotext
+-- Structural equality for Chunk 
+deriving instance Eq Chunk
 
 data TestPrinter = TestPrinter
-  { outputChan :: TChan Printout
+  { outputChan :: TMVar Printout
   , failSwitch :: TMVar PrintingError
   }
 
 data TestManager = TestManager
-  { manage :: TMVar (QueueManager IdentityT)
+  { manage :: TMVar (S.QueueManager IdentityT)
+  , ran :: TSem
   }
 
-setup :: IO (ThreadId, QSem, TestPrinter, TestManager)
-setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
-  tPrinter <- TestPrinter <$> newTChanIO <*> newEmptyTMVarIO
-  tManager <- TestManager <$> newEmptyTMVarIO
+data RunningServer = RunningServer
+  { thread :: ThreadId
+  , termination :: QSem
+  , printer :: TestPrinter
+  , manager :: TestManager
+  }
+
+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
   let
-    runSqlite :: ReaderT ConnectionPool (NoLoggingT IO) a -> IO a
-    runSqlite = runNoLoggingT . withSqlitePool (T.pack fp) 1 . runReaderT
+    runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
+    runSqlite = runStderrLoggingT . filterLogger (const (> LevelDebug)) . withSqlitePool (T.pack fp) 1 . runReaderT
 
-    printers = [ ( pure $ PM tPM
-                 , QMConfig (join . lift $ takeTMVar (manage tManager)) (Nat $ liftIO . runIdentityT)
+    printers = [ ( pure $ S.PM tPM
+                 , S.QMConfig ((join . lift $ takeTMVar (manage tManager) <* signalTSem (ran tManager)) >> return 0) (Nat $ liftIO . runIdentityT)
                  )
                ]
 
     tPM :: MonadIO m => Printout -> m (Maybe PrintingError)
-    tPM printout = liftIO . atomically $ writeTChan (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter)
-  (,,,) <$> 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)
+    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
+  where
+    def' :: MonadIO m => S.Config m
+    def' = S.def { S.warpSettings = setBeforeMainLoop (signalQSem startup) $ defaultSettings }
+
+withSetup :: SpecWith RunningServer -> Spec
+withSetup = beforeAll setup' . afterAll teardown
+  where
+    setup' = do
+      startup <- newQSem 0
+      setup startup <* waitQSem startup
+    teardown RunningServer{..} = killThread thread >> waitQSem termination
 
 spec :: Spec
 spec = withSetup $ do
-  describe "blubTests" $ do
-    it "prints Blub." $ \(tId, _, _, _) -> do
-      threadDelay 5000
-      putStrLn "Blub."
-      System.IO.print tId
-      True `shouldSatisfy` id
+  it "Reports initial server state" $ \RunningServer{..} -> do
+    printers                     `shouldReturn` [(0, Available)]
+    jobs Nothing Nothing Nothing `shouldReturn` []
+    drafts                       `shouldReturn` []
+  it "Reports printing errors" $ \RunningServer{..} -> do
+    let
+      err = IOError "test"
+    atomically $ putTMVar (failSwitch printer) err
+    jId <- jobCreate Nothing mempty
+    atomically . takeTMVar $ outputChan printer
+    jobStatus jId `shouldReturn` (Failed err)
+  -- it "Queues any Printout" $ \RunningServer{..} -> property $ \p -> do
+  --   jId <- jobCreate (Just 0) p
+  --   (atomically . takeTMVar . outputChan $ printer) `shouldReturn` p
+  it "Reports qualitative queue position" $ \RunningServer{..} -> do
+    jids <- replicateM 3 $ jobCreate (Just 0) mempty
+    zipWithM_ (\jid ret -> jobStatus jid `shouldReturn` ret) jids
+      [ Done
+      , Printing 0
+      , Queued 0
+      ]
+    replicateM_ (length jids) . atomically . takeTMVar . outputChan $ printer
+    zipWithM_ (\jid ret -> jobStatus jid `shouldReturn` ret) jids (replicate (length jids) Done)
+  it "Keeps history" $ \RunningServer{..} -> do
+    jobs Nothing Nothing Nothing `shouldNotReturn` []
+  it "Runs queue managers" $ \RunningServer{..} -> do
+    atomically $ putTMVar (manage manager) S.nullQM
+    atomically $ waitTSem (ran manager)
+    jobs Nothing Nothing Nothing `shouldReturn` []
+  it "Handles drafts" $ \RunningServer{..} -> do
+    drafts `shouldReturn` []
+    dId <- draftCreate Nothing mempty
+    draft dId `shouldReturn` (Nothing, mempty)
+    drafts `shouldReturn` [(dId, mempty)]
+    p <- generate arbitrary
+    draftReplace dId (Just "Title") p
+    draft dId `shouldReturn` (Just "Title", p)
+    jId <- draftPrint dId Nothing
+    (atomically . takeTMVar $ outputChan printer) `shouldReturn` p
+    draftDelete dId
+    drafts `shouldReturn` []
+  where
+    Client{..} = mkClient' $ BaseUrl Http "localhost" 3000
+    
+