aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--server/src/Thermoprint/Server/Printer/Generic.hs32
-rw-r--r--spec/src/Thermoprint/API.hs2
2 files changed, 21 insertions, 13 deletions
diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs
index f37be21..b993eaf 100644
--- a/server/src/Thermoprint/Server/Printer/Generic.hs
+++ b/server/src/Thermoprint/Server/Printer/Generic.hs
@@ -7,7 +7,7 @@ module Thermoprint.Server.Printer.Generic
7 ) where 7 ) where
8 8
9import Thermoprint.Printout 9import Thermoprint.Printout
10import Thermoprint.API (PrintingError(IOError)) 10import Thermoprint.API (PrintingError(..))
11import Thermoprint.Server.Printer 11import Thermoprint.Server.Printer
12 12
13import System.FileLock 13import System.FileLock
@@ -46,14 +46,11 @@ import Data.Int (Int64)
46 46
47import Prelude hiding (mapM_, sequence_) 47import Prelude hiding (mapM_, sequence_)
48 48
49lockedFile :: FilePath -> Acquire (FileLock, Handle)
50lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f AppendMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock)
51
52withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a
53withLockedFile path f = withEx (lockedFile path) (f . snd)
54
55genericPrint :: FilePath -> PrinterMethod 49genericPrint :: FilePath -> PrinterMethod
56genericPrint path = PM $ flip catches handlers . withLockedFile path . print 50genericPrint path = PM $ genericPrint' path
51
52genericPrint' :: (MonadIO m, MonadMask m) => FilePath -> Printout -> m (Maybe PrintingError)
53genericPrint' path = flip catches handlers . withLockedFile path . print
57 where 54 where
58 print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing 55 print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing
59 handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String) 56 handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String)
@@ -61,6 +58,12 @@ genericPrint path = PM $ flip catches handlers . withLockedFile path . print
61 , Handler $ return . Just 58 , Handler $ return . Just
62 ] 59 ]
63 60
61withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a
62withLockedFile path f = withEx (lockedFile path) (f . snd)
63
64lockedFile :: FilePath -> Acquire (FileLock, Handle)
65lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f WriteMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock)
66
64type Render = ReaderT Handle IO () 67type Render = ReaderT Handle IO ()
65 68
66encode' :: ByteSink m => String -> m () 69encode' :: ByteSink m => String -> m ()
@@ -84,19 +87,22 @@ newl = "\r\n"
84newls :: Integer -> Lazy.ByteString 87newls :: Integer -> Lazy.ByteString
85newls i = mconcat $ genericReplicate i newl 88newls i = mconcat $ genericReplicate i newl
86 89
90newls' :: Integer -> Render
91newls' = mapM_ pushWord8 . LBS.unpack . newls
92
87finalize :: Render -- TODO: adjust this to produce proper padding 93finalize :: Render -- TODO: adjust this to produce proper padding
88finalize = encode' $ newls 2 94finalize = newls' 2
89 95
90intersperse :: b -> (a -> b) -> Seq a -> Seq b 96intersperse :: b -> (a -> b) -> Seq a -> Seq b
91intersperse _ _ (viewl -> EmptyL) = Seq.empty 97intersperse _ _ (viewl -> EmptyL) = Seq.empty
92intersperse _ f (viewl -> x :< (viewl -> EmptyL)) = Seq.singleton $ f x 98intersperse _ f (viewl -> x :< (viewl -> EmptyL)) = Seq.singleton $ f x
93intersperse b f (viewl -> x :< xs) = f x <| b <| intersperse' b f xs 99intersperse b f (viewl -> x :< xs) = f x <| b <| intersperse b f xs
94 100
95intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m () 101intersperse' :: Monad m => m b -> (a -> m b) -> Seq a -> m ()
96intersperse' b f = sequence_ . intersperse b f 102intersperse' b f = sequence_ . intersperse b f
97 103
98render :: Printout -> Render 104render :: Printout -> Render
99render = intersperse' (encode' newl) renderPar 105render = intersperse' (newls' 1) renderPar
100 106
101renderPar :: Paragraph -> Render 107renderPar :: Paragraph -> Render
102renderPar = mapM_ renderChunk 108renderPar = mapM_ renderChunk
@@ -105,6 +111,6 @@ renderPar = mapM_ renderChunk
105 renderChunk (Cooked block) = renderBlock block 111 renderChunk (Cooked block) = renderBlock block
106 112
107renderBlock :: Block -> Render 113renderBlock :: Block -> Render
108renderBlock (VSpace n) = encode' $ newls n 114renderBlock (VSpace n) = newls' n
109renderBlock (NewlSep xs) = intersperse' (encode' newl) . fmap renderBlock $ xs 115renderBlock (NewlSep xs) = intersperse' (newls' 1) renderBlock xs
110renderBlock (Line x) = undefined 116renderBlock (Line x) = undefined
diff --git a/spec/src/Thermoprint/API.hs b/spec/src/Thermoprint/API.hs
index 6f7fc02..f5b7bee 100644
--- a/spec/src/Thermoprint/API.hs
+++ b/spec/src/Thermoprint/API.hs
@@ -43,6 +43,8 @@ import Control.Exception (Exception)
43import Data.Time (UTCTime) 43import Data.Time (UTCTime)
44import Data.Time.Format 44import Data.Time.Format
45 45
46import Data.Encoding.Exception (EncodingException(..))
47
46instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where 48instance (Integral k, Ord k, ToJSON v) => ToJSON (Map k v) where
47 toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId) 49 toJSON = toJSON . Map.foldMapWithKey (IntMap.singleton . castId)
48 50