From 8553c33f72c41e553cbef4e7175cef8cec3cdbe2 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Sat, 23 Jan 2016 14:47:59 +0000 Subject: Printer handling threads & printers handler --- server/src/Thermoprint/Server.hs | 16 +++++++++++++--- server/src/Thermoprint/Server/API.hs | 24 ++++++++++++++++++------ server/src/Thermoprint/Server/Printer.hs | 5 ++++- 3 files changed, 35 insertions(+), 10 deletions(-) (limited to 'server/src') diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs index 0d96de0..39bf0a1 100644 --- a/server/src/Thermoprint/Server.hs +++ b/server/src/Thermoprint/Server.hs @@ -9,19 +9,25 @@ module Thermoprint.Server , Config(..) , module Data.Default.Class , module Servant.Server.Internal.Enter + , module Thermoprint.Server.Printer ) where import Data.Default.Class import qualified Config.Dyre as Dyre -import Control.Monad (mapM_) +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe (maybe) +import Data.Foldable (mapM_, forM_) 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.Concurrent import Data.Text (Text) import qualified Data.Text as T (pack) @@ -35,20 +41,23 @@ import Servant.Server.Internal.Enter (enter, (:~>)(..)) import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool) -import Thermoprint.API (thermoprintAPI) +import Thermoprint.API (thermoprintAPI, PrinterId) import Thermoprint.Server.Database +import Thermoprint.Server.Printer import qualified Thermoprint.Server.API as API (thermoprintServer) import Thermoprint.Server.API hiding (thermoprintServer) -- | Compile-time configuration for 'thermoprintServer' data Config = Config { dyreError :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error , warpSettings :: Warp.Settings -- ^ Configure 'Warp's behaviour + , printers :: Map PrinterId Printer } instance Default Config where def = Config { dyreError = Nothing , warpSettings = Warp.defaultSettings + , printers = Map.empty } @@ -68,4 +77,5 @@ thermoprintServer io = Dyre.wrapMain $ Dyre.defaultParams realMain Config{..} = unNat io $ do maybe (return ()) ($(logErrorS) "Dyre" . T.pack) dyreError mapM_ ($(logWarnS) "DB") =<< runSqlPool (runMigrationSilent migrateAll) =<< ask - liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat + forM_ printers $ liftBaseDiscard forkIO . runPrinter + liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs index 6411a70..6a92caf 100644 --- a/server/src/Thermoprint/Server/API.hs +++ b/server/src/Thermoprint/Server/API.hs @@ -10,6 +10,9 @@ 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 Data.Set (Set) import qualified Data.Set as Set import Data.Sequence (Seq) @@ -26,10 +29,14 @@ import Control.Monad.Reader import Control.Monad.Trans.Either import Control.Monad.IO.Class +import Control.Concurrent.STM + import Control.Monad ((<=<), liftM2) -import Prelude hiding ((.), id) +import Prelude hiding ((.), id, mapM) import Control.Category +import Data.Traversable (mapM) + import Database.Persist import Database.Persist.Sql @@ -37,21 +44,23 @@ type ProtoHandler = ReaderT HandlerInput (LoggingT IO) type Handler = EitherT ServantErr ProtoHandler -- ^ Runtime configuration of our handlers -data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage +data HandlerInput = HandlerInput { sqlPool :: ConnectionPool -- ^ How to interact with 'persistent' storage + , printers :: Map PrinterId Printer } handlerNat :: ( MonadReader ConnectionPool m , MonadLoggerIO m - ) => m (Handler :~> EitherT ServantErr IO) + ) => Map PrinterId Printer -> m (Handler :~> EitherT ServantErr IO) -- ^ Servant requires its handlers to be 'EitherT ServantErr IO' -- -- This generates a 'Nat'ural transformation for squashing the monad-transformer-stack we use in our handlers to the monad 'servant-server' wants -handlerNat = do +handlerNat printerMap = do sqlPool <- ask logFunc <- askLoggerIO let handlerInput = HandlerInput - { sqlPool = sqlPool + { sqlPool = sqlPool + , printers = printerMap } protoNat :: ProtoHandler :~> IO protoNat = Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput @@ -71,7 +80,10 @@ thermoprintServer = listPrinters infixr 9 <||> listPrinters :: Handler (Map PrinterId PrinterStatus) -listPrinters = return $ Map.fromList [(1, Available), (7, Available), (3, Available)] +listPrinters = fmap toStatus <$> (mapM (liftIO . readTVarIO . queue) . printers =<< ask) + where + toStatus (Queue _ Nothing _) = Available + toStatus (Queue _ (Just id) _) = Busy . castId $ fromSqlKey id queueJob :: Maybe PrinterId -> Printout -> Handler API.JobId queueJob = return undefined diff --git a/server/src/Thermoprint/Server/Printer.hs b/server/src/Thermoprint/Server/Printer.hs index 0db98a0..f34b2fa 100644 --- a/server/src/Thermoprint/Server/Printer.hs +++ b/server/src/Thermoprint/Server/Printer.hs @@ -8,7 +8,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass #-} module Thermoprint.Server.Printer - ( Printer(..) + ( Printer(..), printer , Queue(..) , runPrinter ) where @@ -54,6 +54,9 @@ 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) + atomically' :: MonadIO m => STM a -> m a atomically' = liftIO . atomically -- cgit v1.2.3