From 55074a07fdb847749e4f57c6c2eac4ffab1d48b6 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 18 Feb 2016 21:59:00 +0000 Subject: Api tests for Thermoprint.Server --- server/test/Thermoprint/Server/QueueSpec.hs | 13 --- server/test/Thermoprint/ServerSpec.hs | 126 +++++++++++++++++++++++----- 2 files changed, 103 insertions(+), 36 deletions(-) (limited to 'server/test') 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 + + -- cgit v1.2.3