Api tests for Thermoprint.Server

5 files changed, 135 insertions, 43 deletions

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";