From 8553c33f72c41e553cbef4e7175cef8cec3cdbe2 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Sat, 23 Jan 2016 14:47:59 +0000
Subject: Printer handling threads & printers handler

---
 server/src/Thermoprint/Server/API.hs     | 24 ++++++++++++++++++------
 server/src/Thermoprint/Server/Printer.hs |  5 ++++-
 2 files changed, 22 insertions(+), 7 deletions(-)

(limited to 'server/src/Thermoprint/Server')

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