First work on driver for generic (cheap) printers

3 files changed, 114 insertions, 8 deletions

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";