From c3a6d0657eb2987aa13b53419269274d848d9e0c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sun, 24 Jan 2016 16:10:48 +0000
Subject: Working printer config & debug printer

---
 server/src/Thermoprint/Server/Printer.hs | 51 +++++++++++++++++++++++++++-----
 1 file changed, 44 insertions(+), 7 deletions(-)

(limited to 'server/src/Thermoprint/Server/Printer.hs')

diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs
index f34b2fa..46b8a53 100644
--- a/server/src/Thermoprint/Server/Printer.hs
+++ b/server/src/Thermoprint/Server/Printer.hs
@@ -1,16 +1,21 @@
 {-# LANGUAGE RankNTypes                    #-}
+{-# LANGUAGE TypeSynonymInstances          #-}
 {-# LANGUAGE MultiParamTypeClasses         #-}
+{-# LANGUAGE FlexibleInstances             #-}
 {-# LANGUAGE FlexibleContexts              #-}
 {-# LANGUAGE RecordWildCards               #-}
 {-# LANGUAGE OverloadedStrings             #-}
 {-# LANGUAGE TemplateHaskell               #-}
 {-# LANGUAGE StandaloneDeriving            #-}
+{-# LANGUAGE GADTs                         #-}
+{-# LANGUAGE ExistentialQuantification     #-}
 {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 
 module Thermoprint.Server.Printer
-       ( Printer(..), printer
+       ( PrinterMethod(..), PrinterSpec(..), IsPrinter(..), Printer(..), printer
        , Queue(..)
        , runPrinter
+       , addToQueue
        ) where
 
 import Thermoprint.API (PrintingError(..), Printout)
@@ -31,6 +36,7 @@ import qualified Data.Text as T (pack)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import Control.DeepSeq
+import Data.Default.Class
 
 import Control.Monad.Trans.Resource
 import Control.Monad.IO.Class
@@ -41,8 +47,20 @@ import Control.Monad (forever)
 
 import Control.Concurrent.STM
 
+newtype PrinterMethod = PM { unPM :: forall m. (MonadResource m, MonadLogger m) => Printout -> m (Maybe PrintingError) }
+data PrinterSpec m = forall p. IsPrinter p m => PS p
+
+class IsPrinter p m where
+  printMethod :: p -> m PrinterMethod
+
+instance Applicative m => IsPrinter PrinterMethod m where
+  printMethod = pure
+
+instance IsPrinter (PrinterSpec m) m where
+  printMethod (PS p) = printMethod p
+
 data Printer = Printer
-  { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)
+  { print :: PrinterMethod
   , queue :: TVar Queue
   }
 
@@ -54,16 +72,23 @@ data Queue = Queue
   }
   deriving (Typeable, Generic, NFData)
 
-printer :: (MonadIO m) => (forall m. (MonadIO m) => Printout -> m (Maybe PrintingError)) -> m Printer
-printer f = Printer f <$> liftIO (newTVarIO $ Queue Seq.empty Nothing Seq.empty)
+instance Default Queue where
+  def = Queue
+    { pending = Seq.empty
+    , current = Nothing
+    , history = Seq.empty
+    }
+
+printer :: (MonadResource m, IsPrinter p m) => p -> m Printer
+printer spec = Printer <$> printMethod spec <*> liftIO (newTVarIO def)
 
 atomically' :: MonadIO m => STM a -> m a
 atomically' = liftIO . atomically
 
 runPrinter :: ( MonadReader ConnectionPool m
-              , MonadIO m
               , MonadLogger m
               , MonadBaseControl IO m
+              , MonadResource m
               ) => Printer -> m ()
 -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method
 runPrinter Printer{..} = forever $ do
@@ -78,6 +103,18 @@ runPrinter Printer{..} = forever $ do
   case job of
     Nothing  -> $(logWarn) "Nonexistent job id in printer queue"
     Just job -> do
-      printReturn <- print (jobContent job)
-      maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show jobId ++ ": ") ++) . show) $ printReturn
+      $(logInfo) . T.pack $ "Printing " ++ show (unSqlBackendKey . unJobKey $ jobId)
+      printReturn <- (unPM print) (jobContent job)
+      maybe (return ()) ($(logWarn) . T.pack . (("Error while printing " ++ show (unSqlBackendKey . unJobKey $ jobId) ++ ": ") ++) . show) $ printReturn
       atomically' $ modifyTVar' queue (\Queue{..} -> force . Queue pending Nothing $ (jobId, printReturn) <| history)
+
+addToQueue :: ( MonadReader ConnectionPool m
+              , MonadLogger m
+              , MonadResource m
+              , MonadBaseControl IO m
+              ) => Printout -> Printer -> m JobId
+addToQueue printout Printer{..} = do
+  jobId <- runSqlPool (insert $ Job printout) =<< ask
+  $(logInfo) . T.pack $ "Queueing " ++ show (unSqlBackendKey . unJobKey $ jobId)
+  atomically' $ modifyTVar' queue (\Queue{..} -> force $ Queue (jobId <| pending) current history)
+  return jobId
-- 
cgit v1.2.3