1 files changed, 59 insertions, 0 deletions

diff --git a/server/src/Thermoprint/Server/Push.hs b/server/src/Thermoprint/Server/Push.hs
new file mode 100644
index 0000000..b2eca6b
--- /dev/null
+++ b/server/src/Thermoprint/Server/Push.hs
@@ -0,0 +1,59 @@
+{-# LANGUAGE ViewPatterns #-}
+
+module Thermoprint.Server.Push
+       ( Notification
+       , withPush
+       , protocolSpec
+       , notifyOnChange
+       ) where
+
+import Network.WebSockets
+import Network.Wai.Handler.WebSockets
+import Network.Wai (Application)
+
+import Network.URI
+
+import Control.Concurrent.STM
+
+import Thermoprint.Server.Queue
+
+import Control.Monad.IO.Class
+import Control.Monad
+
+import Paths_thermoprint_server (version)
+import Data.Version (showVersion)
+
+import           Data.ByteString.Char8        (ByteString)
+import qualified Data.ByteString.Char8 as CBS
+
+import           Data.Text         (Text)
+import qualified Data.Text as Text
+
+type Notification = URI
+
+withPush :: TChan Notification -> Application -> Application
+withPush chan = websocketsOr defaultConnectionOptions $ flip acceptRequestWith (AcceptRequest $ Just protocolSpec) >=> handleClient chan
+
+protocolSpec :: ByteString
+protocolSpec = CBS.pack $ "thermoprint-server.notification." ++ showVersion version
+
+handleClient :: TChan Notification -> Connection -> IO ()
+handleClient chan conn = do
+  cChan <- atomically $ dupTChan chan
+  forever . void $ atomically (readTChan cChan) >>= sendTextData conn . packNotification
+
+packNotification :: Notification -> Text
+packNotification = Text.pack . show
+
+notifyOnChange :: MonadIO m => TChan Notification -> (a -> a -> Bool) -> Notification -> TVar a -> m ()
+notifyOnChange chan cmp n q = void . liftIO $ readTVarIO q >>= notifyOnChange'
+  where
+    notifyOnChange' last = do
+      current <- atomically $ (\current -> current <$ check (not $ cmp last current)) =<< readTVar q
+      atomically $ writeTChan chan n
+      notifyOnChange' current
+      
+        
+      
+      
+