aboutsummaryrefslogtreecommitdiff
path: root/server/src/Thermoprint/Server/Push.hs
blob: 7ae03a6de40489ea24b6c65ad43c10f4d578f335 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
{-# 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
  forkPingThread conn 10
  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