First work on driver for generic (cheap) printers

1 files changed, 100 insertions, 0 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