From 760027dbcd7185be038299efb18e0cc37c8088c4 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 22 Feb 2016 20:22:42 +0000
Subject: Websocket based push notifications

---
 server/src/Thermoprint/Server.hs | 28 ++++++++++++++++++++++++----
 1 file changed, 24 insertions(+), 4 deletions(-)

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

diff --git a/server/src/Thermoprint/Server.hs b/server/src/Thermoprint/Server.hs
index df2d8e9..446c63e 100644
--- a/server/src/Thermoprint/Server.hs
+++ b/server/src/Thermoprint/Server.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE ImpredicativeTypes        #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE ViewPatterns              #-}
+{-# LANGUAGE DataKinds                 #-}
 
 module Thermoprint.Server
        ( thermoprintServer
@@ -25,9 +26,17 @@ import qualified Data.Map as Map
 
 import Data.Set (Set)
 import qualified Data.Set as Set
+       
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
+
+import Data.Time (UTCTime)
 
 import Data.Maybe (maybe)
 import Data.Foldable (mapM_, forM_, foldlM)
+import Data.Function hiding (id, (.))
+import Data.Bifunctor
+import Data.Proxy
 
 import Control.Monad.Trans.Resource
 import Control.Monad.Trans.Control
@@ -53,14 +62,20 @@ import Network.Wai (Application)
 
 import Servant.Server (serve)
 import Servant.Server.Internal.Enter (enter, (:~>)(..))
+import Servant.API
+import Servant.Utils.Links
+import Network.URI
 
 import Database.Persist.Sql (runMigrationSilent, ConnectionPool, runSqlPool)
 
 
-import Thermoprint.API (thermoprintAPI, PrinterId)
+import Thermoprint.API (thermoprintAPI, PrinterStatus, JobStatus)
+import qualified Thermoprint.API as API (PrinterId, JobId)
 
 import Thermoprint.Server.Fork
 
+import Thermoprint.Server.Push
+
 import Thermoprint.Server.Database
 import Thermoprint.Server.Printer
 import Thermoprint.Server.Queue
@@ -72,8 +87,8 @@ import Debug.Trace
 -- | Compile-time configuration for 'thermoprintServer'
 data Config m = Config { dyreError     :: Maybe String -- ^ Set by 'Dyre' -- sent to log as an error
                        , warpSettings  :: Warp.Settings -- ^ Configure 'Warp's behaviour
-                       , printers      :: Map PrinterId Printer
-                       , queueManagers :: PrinterId -> QMConfig m
+                       , printers      :: Map API.PrinterId Printer
+                       , queueManagers :: API.PrinterId -> QMConfig m
                        }
 
 data QMConfig m = forall t. ( MonadTrans t
@@ -137,4 +152,9 @@ thermoprintServer dyre io = Dyre.wrapMain $ Dyre.defaultParams
           let
             runQM' (queueManagers -> QMConfig qm nat) printer = unNat nat $ runQM gcChan qm printer
           mapM_ (fork tMgr . uncurry runQM') $ Map.toList printers
-          liftIO . Warp.runSettings warpSettings . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers
+          nChan <- liftIO $ newBroadcastTChanIO
+          let
+            printerUrl :: API.PrinterId -> URI
+            printerUrl = safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> QueryParam "printer" API.PrinterId :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
+          mapM_ (fork tMgr . uncurry (notifyOnChange nChan ((==) `on` fromZipper)) . bimap printerUrl queue) $ Map.toList printers
+          liftIO . Warp.runSettings warpSettings . withPush nChan . serve thermoprintAPI . flip enter API.thermoprintServer =<< handlerNat printers nChan
-- 
cgit v1.2.3