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