Printer handling threads & printers handler

5 files changed, 43 insertions, 16 deletions

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
 
diff --git a/server/thermoprint-server.cabal b/server/thermoprint-server.cabal
index 926118d..185a0f3 100644
--- a/server/thermoprint-server.cabal
+++ b/server/thermoprint-server.cabal
@@ -41,6 +41,7 @@ library
                      , text >=1.2.1 && <2
                      , stm >=2.4.4 && <3
                      , deepseq >=1.4.1 && <2
+                     , monad-control >=1.0.0 && <2
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/server/thermoprint-server.nix b/server/thermoprint-server.nix
index 69bff1d..46859e2 100644
--- a/server/thermoprint-server.nix
+++ b/server/thermoprint-server.nix
@@ -1,7 +1,7 @@
 { mkDerivation, base, containers, data-default-class, deepseq, dyre
-, either, monad-logger, mtl, persistent, persistent-sqlite
-, persistent-template, resourcet, servant-server, stdenv, stm, text
-, thermoprint-spec, transformers, wai, warp
+, either, monad-control, monad-logger, mtl, persistent
+, persistent-sqlite, persistent-template, resourcet, servant-server
+, stdenv, stm, text, thermoprint-spec, transformers, wai, warp
 }:
 mkDerivation {
   pname = "thermoprint-server";
@@ -10,9 +10,10 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    base containers data-default-class deepseq dyre either monad-logger
-    mtl persistent persistent-template resourcet servant-server stm
-    text thermoprint-spec transformers wai warp
+    base containers data-default-class deepseq dyre either
+    monad-control monad-logger mtl persistent persistent-template
+    resourcet servant-server stm text thermoprint-spec transformers wai
+    warp
   ];
   executableHaskellDepends = [
     base monad-logger mtl persistent-sqlite resourcet