blob: aa654b165307a7d2bf875b22da1de74df8425ee1 (
plain)
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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ImpredicativeTypes #-}
module Thermoprint.ServerSpec (spec) where
import Test.HUnit
import Test.Hspec
import Test.Hspec.Contrib.HUnit
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
data TestPrinter = TestPrinter
{ outputChan :: TChan Printout
, failSwitch :: TMVar PrintingError
}
data TestManager = TestManager
{ manage :: TMVar (QueueManager IdentityT)
}
setup :: IO (ThreadId, TestPrinter, TestManager)
setup = withSystemTempFile "thermoprint.sqlite" $ \fp h -> hClose h >> do
tPrinter <- TestPrinter <$> newTChanIO <*> newEmptyTMVarIO
tManager <- TestManager <$> newEmptyTMVarIO
let
runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a
runSqlite = runStderrLoggingT . 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)
(,,) <$> forkIO (thermoprintServer (Nat runSqlite) $ def `withPrinters` printers) <*> pure tPrinter <*> pure tManager
spec :: Spec
spec = do
fromHUnitTest . test . ("blub" ~:) $ do
putStrLn "Blub."
return True
|
