From c3a6d0657eb2987aa13b53419269274d848d9e0c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sun, 24 Jan 2016 16:10:48 +0000 Subject: Working printer config & debug printer --- server/default-conf/Main.hs | 14 +++++-- server/src/Thermoprint/Server.hs | 35 ++++++++++++------ server/src/Thermoprint/Server/API.hs | 27 ++++++++++---- server/src/Thermoprint/Server/Database.hs | 11 ++++-- server/src/Thermoprint/Server/Printer.hs | 51 ++++++++++++++++++++++---- server/src/Thermoprint/Server/Printer/Debug.hs | 39 ++++++++++++++++++++ server/thermoprint-server.cabal | 1 + 7 files changed, 145 insertions(+), 33 deletions(-) create mode 100644 server/src/Thermoprint/Server/Printer/Debug.hs diff --git a/server/default-conf/Main.hs b/server/default-conf/Main.hs index 0aa7d91..0fba774 100644 --- a/server/default-conf/Main.hs +++ b/server/default-conf/Main.hs @@ -1,9 +1,12 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImpredicativeTypes #-} module Main (main) where import Thermoprint.Server +import Thermoprint.Server.Printer.Debug + import Control.Monad.Trans.Resource import Control.Monad.Logger import Control.Monad.Reader @@ -11,7 +14,10 @@ import Control.Monad.Reader import Database.Persist.Sqlite main :: IO () -main = thermoprintServer (Nat runSqlite) def +main = thermoprintServer (Nat runSqlite) $ def `withPrinters` printers where - runSqlite :: ReaderT ConnectionPool (LoggingT (ResourceT IO)) a -> IO a - runSqlite = runResourceT . runStderrLoggingT . withSqlitePool ":memory:" 1 . runReaderT + runSqlite :: ReaderT ConnectionPool (LoggingT IO) a -> IO a + runSqlite = runStderrLoggingT . withSqlitePool ":memory:" 1 . runReaderT + + printers = [ PS Debug + ] diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 39bf0a1..ed20983 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ImpredicativeTypes #-} module Thermoprint.Server ( thermoprintServer , Config(..) + , withPrinters , module Data.Default.Class , module Servant.Server.Internal.Enter , module Thermoprint.Server.Printer @@ -19,13 +21,15 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (maybe) -import Data.Foldable (mapM_, forM_) +import Data.Foldable (mapM_, forM_, foldlM) import Control.Monad.Trans.Resource import Control.Monad.Trans.Control import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.IO.Class +import Control.Category +import Prelude hiding (id, (.)) import Control.Concurrent @@ -62,20 +66,27 @@ instance Default Config where thermoprintServer :: ( MonadLoggerIO m - , MonadIO m - , MonadBaseControl IO m , MonadReader ConnectionPool m + , MonadResourceBase m ) => (m :~> IO) -- ^ 'dyre' controls the base of the monad-transformer-stack ('IO') but we let the user specify the rest of it. Therefore we require a specification of how to enter the stack. - -> Config -> IO () + -> ResourceT m Config -> IO () -- ^ Run the server thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams { Dyre.projectName = "thermoprint-server" , Dyre.realMain = realMain - , Dyre.showError = (\cfg msg -> cfg { dyreError = Just msg }) + , Dyre.showError = flip (\msg -> fmap (\cfg -> cfg { dyreError = Just msg })) } where - realMain Config{..} = unNat io $ do + realMain cfg = unNat (io . Nat runResourceT) $ do + Config{..} <- cfg maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask - forM_ printers $ liftBaseDiscard forkIO . runPrinter + forM_ printers $ resourceForkIO . runPrinter liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers + +withPrinters :: MonadResource m => Config -> [PrinterSpec m] -> m Config +withPrinters cfg pss = (\map -> cfg { printers = map }) <$> foldlM (\map spec -> Map.insert (nextKey map) <$> printer spec <*> pure map) Map.empty pss + where + nextKey map + | Map.null map = 0 + | otherwise = succ . fst $ Map.findMin map diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 6a92caf..a1efb8f 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Thermoprint.Server.API ( ProtoHandler, Handler @@ -11,7 +12,8 @@ module Thermoprint.Server.API import Thermoprint.API hiding (JobId(..), DraftId(..)) import qualified Thermoprint.API as API (JobId(..), DraftId(..)) -import Thermoprint.Server.Printer (Printer(..), Queue(..)) +import Thermoprint.Server.Printer +import Thermoprint.Server.Database import Data.Set (Set) import qualified Data.Set as Set @@ -26,6 +28,7 @@ import Servant.Server.Internal.Enter import Control.Monad.Logger import Control.Monad.Reader +import Control.Monad.Trans.Resource import Control.Monad.Trans.Either import Control.Monad.IO.Class @@ -40,7 +43,7 @@ import Data.Traversable (mapM) import Database.Persist import Database.Persist.Sql -type ProtoHandler = ReaderT HandlerInput (LoggingT IO) +type ProtoHandler = ReaderT HandlerInput (LoggingT (ResourceT IO)) type Handler = EitherT ServantErr ProtoHandler -- ^ Runtime configuration of our handlers @@ -63,7 +66,7 @@ handlerNat printerMap = do , printers = printerMap } protoNat :: ProtoHandler :~> IO - protoNat = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput + protoNat = Nat runResourceT . Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput return $ hoistNat protoNat thermoprintServer :: ServerT ThermoprintAPI Handler @@ -79,6 +82,16 @@ thermoprintServer = listPrinters (<||>) = liftM2 (:<|>) infixr 9 <||> +lookupPrinter :: Maybe PrinterId -> Handler Printer +lookupPrinter pId = asks printers >>= maybePrinter' pId + where + maybePrinter' Nothing printerMap + | Map.null printerMap = left $ err501 { errBody = "No printers available" } + | otherwise = return . snd $ Map.findMin printerMap + maybePrinter (Just pId) printerMap + | Just printer <- Map.lookup pId printerMap = return printer + | otherwise = left $ err404 { errBody = "No such printer" } + listPrinters :: Handler (Map PrinterId PrinterStatus) listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) where @@ -86,7 +99,7 @@ listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId -queueJob = return undefined +queueJob pId printout = lift . fmap (castId' . unJobKey) . withReaderT sqlPool . addToQueue printout =<< lookupPrinter pId printerStatus :: PrinterId -> Handler PrinterStatus printerStatus = return undefined diff --git a/server/src/Thermoprint/Server/Database.hs b/server/src/Thermoprint/Server/Database.hs index 29732e1..1e01680 100644 --- a/server/src/Thermoprint/Server/Database.hs +++ b/server/src/Thermoprint/Server/Database.hs @@ -9,16 +9,18 @@ module Thermoprint.Server.Database ( Job(..), JobId , Draft(..), DraftId + , Key(..) , migrateAll + , castId' ) where import Control.DeepSeq -import Thermoprint.API (Printout, DraftTitle, JobStatus) +import Thermoprint.API (Printout, DraftTitle, JobStatus, castId) import Database.Persist.TH -import Database.Persist.Sql (unSqlBackendKey) -import Database.Persist.Class (Key) +import Database.Persist.Sql (unSqlBackendKey, SqlBackend) +import Database.Persist.Class (Key, BackendKey) import Thermoprint.Server.Database.Instances @@ -32,3 +34,6 @@ Draft instance NFData (Key Job) where rnf = rnf . unSqlBackendKey . unJobKey + +castId' :: Enum b => BackendKey SqlBackend -> b +castId' = castId . unSqlBackendKey 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 diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs new file mode 100644 index 0000000..b8c1430 --- /dev/null +++ b/server/src/Thermoprint/Server/Printer/Debug.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} + +module Thermoprint.Server.Printer.Debug + ( Debug(..) + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Control.Monad.Logger + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL + +import qualified Data.Text as T + +import Thermoprint.Printout +import Thermoprint.Server.Printer + +import Data.List (intersperse) +import Data.Foldable (toList) +import Data.Monoid + +data Debug = Debug + +instance Applicative m => IsPrinter Debug m where + printMethod _ = printMethod debugPrinter + +debugPrinter :: PrinterMethod +debugPrinter = PM $ (>> return Nothing) . $(logDebugS) "Printer.Debug" . T.pack . show . cotext' + +cotext' :: Printout -> Text +cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList + where + cotext'' (Cooked b) = cotext b + cotext'' (Raw _) = "[Raw]" diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal index 185a0f3..dd495c0 100644 --- a/server/thermoprint-server.cabal +++ b/server/thermoprint-server.cabal @@ -21,6 +21,7 @@ library , Thermoprint.Server.Database , Thermoprint.Server.API , Thermoprint.Server.Printer + , Thermoprint.Server.Printer.Debug other-modules: Thermoprint.Server.Database.Instances -- other-extensions: build-depends: base >=4.8 && <5 -- cgit v1.2.3