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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImpredicativeTypes #-}
module Thermoprint.ServerSpec (spec) where
import Test.Hspec
import Thermoprint.API
import Thermoprint.Server
import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Resource
import Database.Persist.Sqlite
import Control.Concurrent
import Control.Concurrent.STM
import System.IO
import System.IO.Temp
import qualified Data.Text as T
import Debug.Trace
data TestPrinter = TestPrinter
{ outputChan :: TChan Printout
, failSwitch :: TMVar PrintingError
}
data TestManager = TestManager
{ manage :: TMVar (QueueManager IdentityT)
}
setup :: IO (ThreadId, QSem, TestPrinter, TestManager)
setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
tPrinter <- TestPrinter <$> newTChanIO <*> newEmptyTMVarIO
tManager <- TestManager <$> newEmptyTMVarIO
termSem <- newQSem 0
let
runSqlite :: ReaderT ConnectionPool (NoLoggingT IO) a -> IO a
runSqlite = runNoLoggingT . withSqlitePool (T.pack fp) 1 . runReaderT
printers = [ ( pure $ PM tPM
, QMConfig (join . lift $ takeTMVar (manage tManager)) (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)
spec :: Spec
spec = withSetup $ do
describe "blubTests" $ do
it "prints Blub." $ \(tId, _, _, _) -> do
threadDelay 5000
putStrLn "Blub."
System.IO.print tId
True `shouldSatisfy` id
|
