websockets 0.5.1.1 → 0.5.2.0

raw patch · 2 files changed

+71/−1 lines, 2 files

Files

• src/Network/WebSockets/Util/PubSub.hs +69/−0
• websockets.cabal +2/−1

@@ -0,0 +1,69 @@+-- | This is a simple utility module to implement a publish-subscribe pattern.+-- Note that this only allows communication in a single direction: pusing data+-- from the server to connected clients (browsers).+--+-- Usage:+--+-- * Create a new 'PubSub' handle using 'newPubSub'+--+-- * Subscribe your clients using the 'subscribe' call+--+-- * Push new updates from the server using the 'publish' call+--+{-# LANGUAGE Rank2Types #-}+module Network.WebSockets.Util.PubSub+    ( PubSub+    , newPubSub+    , publish+    , subscribe+    ) where++import Control.Applicative ((<$>))+import Control.Monad (forM_, forever)+import Control.Monad.Trans (liftIO)+import Data.IntMap (IntMap)+import qualified Control.Concurrent.MVar as MV++import qualified Data.IntMap as IM++import Network.WebSockets++data PubSub_ p = PubSub_+    { pubSubNextId :: Int+    , pubSubSinks  :: IntMap (Sink p)+    }++addClient :: Sink p -> PubSub_ p -> (PubSub_ p, Int)+addClient sink (PubSub_ nid sinks) =+    (PubSub_ (nid + 1) (IM.insert nid sink sinks), nid)++removeClient :: Int -> PubSub_ p -> PubSub_ p+removeClient ref ps = ps {pubSubSinks = IM.delete ref (pubSubSinks ps)}++-- | A handle which keeps track of subscribed clients+newtype PubSub p = PubSub (MV.MVar (PubSub_ p))++-- | Create a new 'PubSub' handle, with no clients initally connected+newPubSub :: IO (PubSub p)+newPubSub = PubSub <$> MV.newMVar PubSub_+    { pubSubNextId  = 0+    , pubSubSinks  = IM.empty+    }++-- | Broadcast a message to all connected clients+publish :: PubSub p -> Message p -> IO ()+publish (PubSub mvar) msg = do+    sinks <- pubSubSinks <$> MV.readMVar mvar +    forM_ (IM.toList sinks) $ \(_, s) -> sendSink s msg++-- | Blocks forever+subscribe :: Protocol p => PubSub p -> WebSockets p ()+subscribe (PubSub mvar) = do+    sink <- getSink+    ref  <- liftIO $ MV.modifyMVar mvar $ return . addClient sink+    catchWsError loop $ const $ liftIO $+        MV.modifyMVar_ mvar $ return . removeClient ref+  where+    loop = forever $ do+        _ <- receiveDataMessage+        return ()

@@ -1,5 +1,5 @@ Name:    websockets-Version: 0.5.1.1+Version: 0.5.2.0  Synopsis:   A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -46,6 +46,7 @@   Exposed-modules:     Network.WebSockets     Network.WebSockets.Internal+    Network.WebSockets.Util.PubSub    Other-modules:     Network.WebSockets.Handshake