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 --- default.nix | 2 +- server/src/Thermoprint/Server/Queue.hs | 19 +++++ server/test/Thermoprint/Server/QueueSpec.hs | 13 --- server/test/Thermoprint/ServerSpec.hs | 126 +++++++++++++++++++++++----- server/thermoprint-server.cabal | 7 +- server/thermoprint-server.nix | 13 +-- spec/src/Thermoprint/API.hs | 17 ++++ 7 files changed, 153 insertions(+), 44 deletions(-) diff --git a/default.nix b/default.nix index 6fe42e3..52ecd20 100644 --- a/default.nix +++ b/default.nix @@ -12,7 +12,7 @@ rec { thermoprint-server = pkgs.callPackage ./server/wrapped.nix { inherit (pkgs.haskellPackages) ghcWithPackages; thermoprint-server = pkgs.haskellPackages.callPackage ./server/thermoprint-server.nix { - inherit thermoprint-spec; + inherit thermoprint-spec thermoprint-client; }; }; bbcode = pkgs.haskellPackages.callPackage ./bbcode/bbcode.nix {}; diff --git a/server/src/Thermoprint/Server/Queue.hs b/server/src/Thermoprint/Server/Queue.hs index cc87886..3c8fb9e 100644 --- a/server/src/Thermoprint/Server/Queue.hs +++ b/server/src/Thermoprint/Server/Queue.hs @@ -46,6 +46,11 @@ import Data.Foldable import Data.Monoid import Data.Ord +import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) +import Test.QuickCheck.Gen (Gen, scale) +import Test.QuickCheck.Instances +import Test.QuickCheck.Modifiers + -- | Zipper for 'Seq QueueEntry' with additional support for 'PrintingError' in the section after point data Queue = Queue { pending :: Seq QueueEntry -- ^ Pending jobs, closest last @@ -54,6 +59,14 @@ data Queue = Queue } deriving (Typeable, Generic, NFData, Show) +instance Arbitrary Queue where + arbitrary = Queue + <$> scale (`div` 2) arbitrary + <*> arbitrary + <*> scale (`div` 2) arbitrary + +instance CoArbitrary Queue + class HasQueue a where extractQueue :: a -> TVar Queue @@ -73,6 +86,12 @@ data QueueEntry = QueueEntry } deriving (Typeable, Generic, NFData, Eq, Ord, Show) +instance Arbitrary QueueEntry where + arbitrary = QueueEntry <$> (fromIntegral . getNonNegative <$> (arbitrary :: Gen (NonNegative Integer))) <*> arbitrary + +instance CoArbitrary QueueEntry where + coarbitrary QueueEntry{..} = coarbitrary created . coarbitrary (fromIntegral jobId :: Integer) + data QueueItem = Pending Int QueueEntry | Current QueueEntry | History Int QueueEntry (Maybe PrintingError) instance Eq QueueItem where 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 + + diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index cfef947..7afcb55 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -55,6 +55,8 @@ library , bytestring >=0.10.6 && <1 , encoding >=0.8 && <1 , binary >=0.7.5 && <1 + , QuickCheck >=2.8.1 && <3 + , quickcheck-instances >=0.3.11 && <4 hs-source-dirs: src default-language: Haskell2010 @@ -63,7 +65,8 @@ Test-Suite tests hs-source-dirs: test main-is: Spec.hs build-depends: base >=4.8.1 && <5 - , thermoprint-server -any + , thermoprint-server ==0.0.* + , thermoprint-client ==0.0.* , thermoprint-spec -any , hspec >=2.2.1 && <3 , QuickCheck >=2.8.1 && <3 @@ -76,6 +79,8 @@ Test-Suite tests , persistent-sqlite >=2.2 && <3 , text >=1.2.1 && <2 , stm >=2.4.4 && <3 + , warp >=3.1.9 && <4 + , exceptions >=0.8.0 && <1 executable thermoprint-server main-is: Main.hs diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix index 737f571..d7a7684 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, hspec-contrib, HUnit, mmorph -, monad-control, monad-logger, mtl, persistent, persistent-sqlite +, extended-reals, filelock, hspec, mmorph, monad-control +, monad-logger, mtl, persistent, persistent-sqlite , persistent-template, QuickCheck, quickcheck-instances, resourcet -, servant-server, stdenv, stm, temporary, text, thermoprint-spec -, time, transformers, wai, warp +, servant-server, stdenv, stm, temporary, text, thermoprint-client +, thermoprint-spec, time, transformers, wai, warp }: mkDerivation { pname = "thermoprint-server"; @@ -23,8 +23,9 @@ mkDerivation { base monad-logger mtl persistent-sqlite resourcet ]; testHaskellDepends = [ - base hspec hspec-contrib HUnit QuickCheck quickcheck-instances - temporary thermoprint-spec + base exceptions hspec monad-logger mtl persistent-sqlite QuickCheck + quickcheck-instances resourcet stm temporary text + thermoprint-client thermoprint-spec transformers warp ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Server for thermoprint-spec"; diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs index 5bfe431..3ffd239 100644 --- a/spec/src/Thermoprint/API.hs +++ b/spec/src/Thermoprint/API.hs @@ -50,6 +50,10 @@ import Data.Time.Format import Data.Encoding.Exception (EncodingException(..)) +import Test.QuickCheck.Arbitrary (Arbitrary(..), CoArbitrary(..)) +import Test.QuickCheck.Gen (scale, variant, oneof) +import Test.QuickCheck.Instances + instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId) @@ -75,6 +79,13 @@ data PrintingError = IOError String -- ^ Not the actual error because we can't m | EncError EncodingException -- ^ Could not encode some part of the 'Printout' deriving (Typeable, Generic, NFData, Show, FromJSON, ToJSON) +instance Arbitrary PrintingError where + arbitrary = IOError <$> arbitrary + +instance CoArbitrary PrintingError where + coarbitrary (IOError _) = variant 0 + coarbitrary (EncError _) = variant 1 + instance Exception PrintingError type DraftTitle = Text @@ -87,6 +98,12 @@ instance ToText UTCTime where data Range a = Min a | Max a | Through a a +instance Arbitrary a => Arbitrary (Range a) where + arbitrary = oneof [ Min <$> arbitrary + , Max <$> arbitrary + , Through <$> arbitrary <*> arbitrary + ] + contains :: Ord a => Range a -> a -> Bool -- ^ Check if a 'Range' contains a point contains (Min min) x = min <= x -- cgit v1.2.3