1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
|
{-# 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 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 Control.Concurrent.Async
import Control.Exception
import System.IO.Error
import System.IO
import System.IO.Temp
import qualified Data.Text as T
import Network.Wai.Handler.Warp (defaultSettings, setBeforeMainLoop)
import Network.HTTP.Types.Status (Status(..))
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 :: TMVar Printout
, failSwitch :: TMVar PrintingError
}
data TestManager = TestManager
{ manage :: TMVar (S.QueueManager IdentityT)
, ran :: TSem
}
data RunningServer = RunningServer
{ thread :: ThreadId
, termination :: MVar (Either SomeException ())
, startup :: 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)
term <- newEmptyMVar
startSem <- newQSem 0
let
runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
runSqlite = runStderrLoggingT . filterLogger (const (> LevelDebug)) . withSqlitePool (T.pack fp) 1 . runReaderT
printers = [ ( pure $ S.PM tPM
, S.QMConfig ((join . lift $ takeTMVar (manage tManager) <* signalTSem (ran tManager)) >> return 0) (NT $ liftIO . runIdentityT)
)
]
tPM :: MonadIO m => Printout -> m (Maybe PrintingError)
tPM printout = liftIO . atomically $ putTMVar (outputChan tPrinter) printout >> tryTakeTMVar (failSwitch tPrinter)
RunningServer <$> forkFinally (S.thermoprintServer False (NT runSqlite) $ def' `S.withPrinters` printers) (putMVar term) <*> pure term <*> pure startSem <*> 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
r <- setup startup
waitStartup <- async $ waitQSem startup
waitTermination <- async . readMVar $ termination r
wait <- waitEitherCancel waitTermination waitStartup
case wait of
Left (Left err) -> throwIO err
Left (Right _) -> throwIO $ userError "Server thread terminated early"
Right _ -> return r
teardown RunningServer{..} = killThread thread >> void (readMVar termination)
spec :: Spec
spec = withSetup $ do
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, Nothing :: Maybe DraftTitle)]
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` []
draftReplace dId Nothing p `shouldThrow` is404
where
Client{..} = mkClient' $ BaseUrl Http "localhost" 3000 ""
is404 :: ServantError -> Bool
is404 (FailureResponse e) = statusCode (responseStatusCode e) == 404
is404 _ = False
|
