5 files changed, 134 insertions, 29 deletions

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]"