diff options
author | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-22 20:22:42 +0000 |
---|---|---|
committer | Gregor Kleen <gkleen@yggdrasil.li> | 2016-02-22 20:22:42 +0000 |
commit | 760027dbcd7185be038299efb18e0cc37c8088c4 (patch) | |
tree | 818a7b5700c904530a633da5139d1a0ee237eba4 /server/src/Thermoprint/Server/Push.hs | |
parent | 6dfb26d6f2966b98c278afd3e269826c96c0ab26 (diff) | |
download | thermoprint-760027dbcd7185be038299efb18e0cc37c8088c4.tar thermoprint-760027dbcd7185be038299efb18e0cc37c8088c4.tar.gz thermoprint-760027dbcd7185be038299efb18e0cc37c8088c4.tar.bz2 thermoprint-760027dbcd7185be038299efb18e0cc37c8088c4.tar.xz thermoprint-760027dbcd7185be038299efb18e0cc37c8088c4.zip |
Websocket based push notifications
Diffstat (limited to 'server/src/Thermoprint/Server/Push.hs')
-rw-r--r-- | server/src/Thermoprint/Server/Push.hs | 59 |
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 @@ | |||
1 | {-# LANGUAGE ViewPatterns #-} | ||
2 | |||
3 | module Thermoprint.Server.Push | ||
4 | ( Notification | ||
5 | , withPush | ||
6 | , protocolSpec | ||
7 | , notifyOnChange | ||
8 | ) where | ||
9 | |||
10 | import Network.WebSockets | ||
11 | import Network.Wai.Handler.WebSockets | ||
12 | import Network.Wai (Application) | ||
13 | |||
14 | import Network.URI | ||
15 | |||
16 | import Control.Concurrent.STM | ||
17 | |||
18 | import Thermoprint.Server.Queue | ||
19 | |||
20 | import Control.Monad.IO.Class | ||
21 | import Control.Monad | ||
22 | |||
23 | import Paths_thermoprint_server (version) | ||
24 | import Data.Version (showVersion) | ||
25 | |||
26 | import Data.ByteString.Char8 (ByteString) | ||
27 | import qualified Data.ByteString.Char8 as CBS | ||
28 | |||
29 | import Data.Text (Text) | ||
30 | import qualified Data.Text as Text | ||
31 | |||
32 | type Notification = URI | ||
33 | |||
34 | withPush :: TChan Notification -> Application -> Application | ||
35 | withPush chan = websocketsOr defaultConnectionOptions $ flip acceptRequestWith (AcceptRequest $ Just protocolSpec) >=> handleClient chan | ||
36 | |||
37 | protocolSpec :: ByteString | ||
38 | protocolSpec = CBS.pack $ "thermoprint-server.notification." ++ showVersion version | ||
39 | |||
40 | handleClient :: TChan Notification -> Connection -> IO () | ||
41 | handleClient chan conn = do | ||
42 | cChan <- atomically $ dupTChan chan | ||
43 | forever . void $ atomically (readTChan cChan) >>= sendTextData conn . packNotification | ||
44 | |||
45 | packNotification :: Notification -> Text | ||
46 | packNotification = Text.pack . show | ||
47 | |||
48 | notifyOnChange :: MonadIO m => TChan Notification -> (a -> a -> Bool) -> Notification -> TVar a -> m () | ||
49 | notifyOnChange chan cmp n q = void . liftIO $ readTVarIO q >>= notifyOnChange' | ||
50 | where | ||
51 | notifyOnChange' last = do | ||
52 | current <- atomically $ (\current -> current <$ check (not $ cmp last current)) =<< readTVar q | ||
53 | atomically $ writeTChan chan n | ||
54 | notifyOnChange' current | ||
55 | |||
56 | |||
57 | |||
58 | |||
59 | |||