From 0609858031013f9d95f8104739811d6413331e9b Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 14 Feb 2016 21:43:23 +0000 Subject: First work on driver for generic (cheap) printers --- server/src/Thermoprint/Server/Printer/Generic.hs | 100 +++++++++++++++++++++++ server/thermoprint-server.cabal | 4 + server/thermoprint-server.nix | 18 ++-- 3 files changed, 114 insertions(+), 8 deletions(-) create mode 100644 server/src/Thermoprint/Server/Printer/Generic.hs diff --git a/server/src/Thermoprint/Server/Printer/Generic.hs b/server/src/Thermoprint/Server/Printer/Generic.hs new file mode 100644 index 0000000..bf6ce3b --- /dev/null +++ b/server/src/Thermoprint/Server/Printer/Generic.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Thermoprint.Server.Printer.Generic + ( genericPrint + ) where + +import Thermoprint.Printout +import Thermoprint.API (PrintingError(IOError)) +import Thermoprint.Server.Printer + +import System.FileLock +import System.IO + +import Data.Sequence (Seq, (|>), (<|), ViewL(..), viewl) +import qualified Data.Sequence as Seq + +import qualified Data.ByteString.Lazy as Lazy (ByteString) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as CLBS + +import qualified Data.Text.Lazy as Lazy (Text) +import qualified Data.Text.Lazy as TL + +import Data.Encoding +import Data.Encoding.CP437 +import Data.Word + +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans.State +import Control.Monad.IO.Class + +import Control.Monad.Trans.Resource +import Data.Acquire + +import Control.Exception.Base (IOException) +import Control.Monad.Catch + +import Data.Foldable + +import Data.List (intersperse, genericReplicate, intercalate) + +import Data.Int (Int64) + +import Prelude hiding (mapM_, sequence_) + +lockedFile :: FilePath -> Acquire (FileLock, Handle) +lockedFile f = mkAcquire ((,) <$> lockFile f Exclusive <*> openFile f AppendMode) (\(lock, h) -> () <$ hClose h <* unlockFile lock) + +withLockedFile :: (MonadIO m, MonadMask m) => FilePath -> (Handle -> m a) -> m a +withLockedFile path f = withEx (lockedFile path) (f . snd) + +genericPrint :: FilePath -> PrinterMethod +genericPrint path = PM $ flip catches handlers . withLockedFile path . print + where + print printout handle = liftIO $ runReaderT (bracket_ initialize (render printout) finalize) handle >> return Nothing + handlers = [ Handler $ return . Just . IOError . (show :: IOException -> String) + , Handler $ return . Just . EncError + ] + +type Render = ReaderT Handle IO () + +encode' :: ByteSink m => String -> m () +encode' = encode CP437 + +width :: Int64 +width = 32 + +esc :: Word8 +esc = 27 + +escSequence :: [Word8] -> Render +escSequence = mapM_ pushWord8 . (esc:) + +initialize :: Render +initialize = replicateM_ 2 $ escSequence [64] + +finalize :: Render -- TODO: adjust this to produce proper padding +finalize = encode' "\n\n\n" + +intersperse' :: b -> (a -> b) -> Seq a -> Seq b +intersperse' _ _ (viewl -> EmptyL) = Seq.empty +intersperse' _ f (viewl -> x :< (viewl -> EmptyL)) = Seq.singleton $ f x +intersperse' b f (viewl -> x :< xs) = f x <| b <| intersperse' b f xs + +render :: Printout -> Render +render = sequence_ . intersperse' (encode' "\n\n") renderPar + +renderPar :: Paragraph -> Render +renderPar = mapM_ renderChunk + where + renderChunk (Raw bs) = mapM_ pushWord8 $ LBS.unpack bs + renderChunk (Cooked block) = renderBlock block + +renderBlock :: Block -> Render +renderBlock (VSpace n) = encode' $ genericReplicate n '\n' +renderBlock (NewlSep xs) = sequence_ intercalate (encode' "\n") . map renderBlock . toList $ xs +renderBlock (Line x) = undefined diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 5783f06..5e9c61f 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -23,6 +23,7 @@ library , Thermoprint.Server.Queue , Thermoprint.Server.Printer , Thermoprint.Server.Printer.Debug + , Thermoprint.Server.Printer.Generic other-modules: Thermoprint.Server.Database.Instances -- other-extensions: build-depends: base >=4.8 && <5 @@ -49,6 +50,9 @@ library , warp >=3.1.9 && <4 , mmorph >=1.0.4 && <2 , extended-reals >=0.2.1 && <1 + , filelock >=0.1.0 && <1 + , bytestring >=0.10.6 && <1 + , encoding >=0.8 && <1 hs-source-dirs: src default-language: Haskell2010 diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix index a33e6db..d4ebb60 100644 --- a/server/thermoprint-server.nix +++ b/server/thermoprint-server.nix @@ -1,6 +1,7 @@ -{ mkDerivation, base, conduit, containers, data-default-class -, deepseq, dyre, either, exceptions, extended-reals, hspec, mmorph -, monad-control, monad-logger, mtl, persistent, persistent-sqlite +{ mkDerivation, base, bytestring, conduit, containers +, data-default-class, deepseq, dyre, either, encoding, exceptions +, extended-reals, filelock, hspec, mmorph, monad-control +, monad-logger, mtl, persistent, persistent-sqlite , persistent-template, QuickCheck, quickcheck-instances, resourcet , servant-server, stdenv, stm, text, thermoprint-spec, time , transformers, wai, warp @@ -12,16 +13,17 @@ mkDerivation { isLibrary = true; isExecutable = true; libraryHaskellDepends = [ - base conduit containers data-default-class deepseq dyre either - exceptions extended-reals mmorph monad-control monad-logger mtl - persistent persistent-template resourcet servant-server stm text - thermoprint-spec time transformers wai warp + base bytestring conduit containers data-default-class deepseq dyre + either encoding exceptions extended-reals filelock mmorph + monad-control monad-logger mtl persistent persistent-template + resourcet servant-server stm text thermoprint-spec time + transformers wai warp ]; executableHaskellDepends = [ base monad-logger mtl persistent-sqlite resourcet ]; testHaskellDepends = [ - base hspec QuickCheck quickcheck-instances + base hspec QuickCheck quickcheck-instances thermoprint-spec ]; homepage = "http://dirty-haskell.org/tags/thermoprint.html"; description = "Server for thermoprint-spec"; -- cgit v1.2.3