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/API.hs | 19 ++++++++++++++++---
 1 file changed, 16 insertions(+), 3 deletions(-)

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

diff --git a/server/src/Thermoprint/Server/API.hs b/server/src/Thermoprint/Server/API.hs
index 770737a..cbf727c 100644
--- a/server/src/Thermoprint/Server/API.hs
+++ b/server/src/Thermoprint/Server/API.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds         #-}
 
 module Thermoprint.Server.API
        ( ProtoHandler, Handler
@@ -15,6 +16,7 @@ import qualified Thermoprint.API as API (JobId(..), DraftId(..))
 import           Thermoprint.Server.Printer
 import           Thermoprint.Server.Queue
 import           Thermoprint.Server.Database
+import           Thermoprint.Server.Push
 
 import           Data.Set (Set)
 import qualified Data.Set as Set
@@ -28,6 +30,7 @@ import qualified Data.Text as T
 import           Servant
 import           Servant.Server
 import           Servant.Server.Internal.Enter
+import           Servant.Utils.Links
 
 import           Control.Monad.Logger
 import           Control.Monad.Reader
@@ -67,6 +70,7 @@ type Handler      = EitherT ServantErr ProtoHandler
 -- ^ Runtime configuration of our handlers
 data HandlerInput = HandlerInput { sqlPool  :: ConnectionPool -- ^ How to interact with 'persistent' storage
                                  , printers :: Map PrinterId Printer
+                                 , nChan    :: TChan Notification
                                  }
 
 instance MonadLogger m => MonadLogger (EitherT a m) where
@@ -74,17 +78,18 @@ instance MonadLogger m => MonadLogger (EitherT a m) where
 
 handlerNat :: ( MonadReader ConnectionPool m
               , MonadLoggerIO m
-              ) => Map PrinterId Printer -> m (Handler :~> EitherT ServantErr IO)
+              ) => Map PrinterId Printer -> TChan Notification -> 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 printerMap = do
+handlerNat printerMap nChan = do
   sqlPool <- ask
   logFunc <- askLoggerIO
   let
     handlerInput = HandlerInput
       { sqlPool  = sqlPool
       , printers = printerMap
+      , nChan    = nChan
       }
     protoNat :: ProtoHandler :~> IO
     protoNat = Nat runResourceT . Nat (($ logFunc) . runLoggingT) . runReaderTNat handlerInput
@@ -103,6 +108,9 @@ thermoprintServer = listPrinters
     (<||>) = liftM2 (:<|>)
     infixr 9 <||>
 
+notify :: Notification -> Handler ()
+notify n = liftIO . atomically =<< flip writeTChan n <$> asks nChan
+
 lookupPrinter :: Maybe PrinterId -> Handler (PrinterId, Printer)
 -- ^ Make sure a printer exists
 lookupPrinter pId = asks printers >>= maybePrinter' pId
@@ -167,7 +175,9 @@ abortJob needle = do
       let filtered = Seq.filter ((/= castId needle) . jobId) pending
       writeTVar (queue p) $ current { pending = filtered }
       return . not $ ((==) `on` length) pending filtered
-    when found . $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
+    when found $ do
+      $(logInfo) $ "Removed job #" <> (T.pack $ show (castId needle :: Integer)) <> " from " <> (T.pack . show $ pId')
+      notify $ safeLink thermoprintAPI (Proxy :: Proxy ("jobs" :> Get '[JSON] (Seq (API.JobId, UTCTime, JobStatus))))
     return found
   when (not found) $ left err404
 
@@ -180,12 +190,14 @@ addDraft :: Maybe DraftTitle -> Printout -> Handler API.DraftId
 addDraft title content = do
   id <- fmap castId . runSqlPool (insert $ Draft title content) =<< asks sqlPool
   $(logInfo) $ "Added draft #" <> (T.pack $ show (castId id :: Integer)) <> " (" <> (T.pack $ show title) <> ")"
+  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
   return id
 
 updateDraft :: API.DraftId -> Maybe DraftTitle -> Printout -> Handler ()
 updateDraft draftId title content = handle (\(KeyNotFound _) -> left $ err404) $ do
   runSqlPool (update (castId draftId) [ DraftTitle =. title, DraftContent =. content ]) =<< asks sqlPool
   $(logInfo) $ "Updated draft #" <> (T.pack $ show (castId draftId :: Integer))
+  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("draft" :> Capture "draftId" API.DraftId :> Get '[JSON] (Maybe DraftTitle, Printout))) $ draftId
 
 getDraft :: API.DraftId -> Handler (Maybe DraftTitle, Printout)
 getDraft draftId = fmap (\(Draft title content) -> (title, content)) . maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
@@ -194,6 +206,7 @@ deleteDraft :: API.DraftId -> Handler ()
 deleteDraft draftId = do
   runSqlPool (delete $ (castId draftId :: Key Draft)) =<< asks sqlPool
   $(logInfo) $ "Made sure draft #" <> (T.pack $ show (castId draftId :: Integer)) <> " is Deleted"
+  notify $ safeLink thermoprintAPI (Proxy :: Proxy ("drafts" :> Get '[JSON] (Map API.DraftId (Maybe DraftTitle))))
 
 printDraft :: API.DraftId -> Maybe PrinterId -> Handler API.JobId
 printDraft draftId printerId = (\(Draft _ content) -> queueJob printerId content) =<< maybe (left err404) return =<< runSqlPool (get $ castId draftId) =<< asks sqlPool
-- 
cgit v1.2.3