From 6434397a3d103547b563ada27fd64c38cb05e1f0 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 23 Jan 2016 19:42:22 +0000 Subject: Broken existentially quantified printer config --- server/src/Thermoprint/Server.hs | 21 +++++++++++--- server/src/Thermoprint/Server/Printer.hs | 39 ++++++++++++++++++++++---- server/src/Thermoprint/Server/Printer/Debug.hs | 32 +++++++++++++++++++++ 3 files changed, 82 insertions(+), 10 deletions(-) create mode 100644 server/src/Thermoprint/Server/Printer/Debug.hs (limited to 'server/src') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 39bf0a1..4e8d962 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -3,10 +3,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ViewPatterns #-} module Thermoprint.Server ( thermoprintServer - , Config(..) + , Config(..), withPrinters , module Data.Default.Class , module Servant.Server.Internal.Enter , module Thermoprint.Server.Printer @@ -19,7 +20,8 @@ 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 Data.Monoid import Control.Monad.Trans.Resource import Control.Monad.Trans.Control @@ -27,6 +29,8 @@ import Control.Monad.Logger import Control.Monad.Reader import Control.Monad.IO.Class +import Control.Monad.Writer + import Control.Concurrent import Data.Text (Text) @@ -62,9 +66,9 @@ instance Default Config where thermoprintServer :: ( MonadLoggerIO m - , MonadIO m - , MonadBaseControl IO m , MonadReader ConnectionPool m + , MonadResource m + , MonadBaseControl IO 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 () -- ^ Run the server @@ -79,3 +83,12 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask forM_ printers $ liftBaseDiscard forkIO . runPrinter liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers + +withPrinters :: MonadResource m => Config -> [PrinterSpec] -> m Config +-- ^ Helper for comfortably specifying a set of 'Printer's +withPrinters cfg = fmap (\ps -> cfg { printers = printers cfg <> ps }) . foldlM (\ps p -> Map.insert (nextKey ps) <$> printer p <*> pure ps) Map.empty + where + nextKey :: Map PrinterId a -> PrinterId + nextKey (Map.keys -> keys) + | null keys = 0 + | otherwise = succ $ maximum keys diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs index f34b2fa..cd12297 100644 --- a/server/src/Thermoprint/Server/Printer.hs +++ b/server/src/Thermoprint/Server/Printer.hs @@ -1,14 +1,18 @@ {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Thermoprint.Server.Printer ( Printer(..), printer + , IsPrinter(..), PrinterSpec(..) , Queue(..) , runPrinter ) where @@ -41,8 +45,23 @@ import Control.Monad (forever) import Control.Concurrent.STM -data Printer = Printer - { print :: forall m. (MonadIO m) => Printout -> m (Maybe PrintingError) +import Data.Default.Class + +import Prelude hiding (print) + +class IsPrinter a where + toMethod :: forall m. (MonadResource m) => a -> (forall m1. (MonadResource m1) => m (Printout -> m1 (Maybe PrintingError))) + +instance (MonadResource m) => IsPrinter (Printer m) where + toMethod Printer{..} = return print + +instance (MonadResource m) => IsPrinter (PrinterSpec m) where + toMethod (PS p) = toMethod p + +data PrinterSpec m = forall p. IsPrinter p => PS p + +data Printer m = Printer + { print :: Printout -> m (Maybe PrintingError) , queue :: TVar Queue } @@ -54,17 +73,25 @@ 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, MonadResource m1, IsPrinter p) => p -> m (Printer m1) +-- ^ Version of 'Printer' handling the initialisation of the 'TVar' +printer p = Printer <$> toMethod p <*> liftIO (newTVarIO def) atomically' :: MonadIO m => STM a -> m a atomically' = liftIO . atomically runPrinter :: ( MonadReader ConnectionPool m - , MonadIO m , MonadLogger m + , MonadResource m , MonadBaseControl IO m - ) => Printer -> m () + ) => Printer m -> m () -- ^ Loop 'forever' pushing entries from the 'Queue' associated to a 'Printer' into its 'print'-method runPrinter Printer{..} = forever $ do jobId <- atomically' $ do diff --git a/server/src/Thermoprint/Server/Printer/Debug.hs b/server/src/Thermoprint/Server/Printer/Debug.hs new file mode 100644 index 0000000..81e43a3 --- /dev/null +++ b/server/src/Thermoprint/Server/Printer/Debug.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module Thermoprint.Server.Printer.Debug + ( Debug + ) where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource + +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL + +import Thermoprint.Printout +import Thermoprint.Server.Printer + +import Data.List (intersperse) +import Data.Foldable (toList) +import Data.Monoid + +data Debug + +-- instance IsPrinter Debug where +-- toMethod _ = (>> return Nothing) . liftIO . TL.putStrLn . cotext' + +-- cotext' :: Printout -> Text +-- cotext' = mconcat . intersperse "\n\n" . map (mconcat . map cotext'' . toList) . toList +-- where +-- cotext'' (Cooked b) = cotext b +-- cotext'' (Raw _) = "[Raw]" -- cgit v1.2.3