engine-io 1.2.0 → 1.2.1

raw patch · 3 files changed

+31/−14 lines, 3 filesdep +freePVP ok

version bump matches the API change (PVP)

Dependencies added: free

API changes (from Hackage documentation)

Files

• Changelog.md +5/−0
• engine-io.cabal +2/−1
• src/Network/EngineIO.hs +24/−13

@@ -1,3 +1,8 @@+## 1.2.1++* Fixed a potential race condition in session allocation, where we could+  clobber existing session ids.+ ## 1.2.0  * `ServerAPI`'s `srvParseParseRequestBody` has changed its return type to

@@ -1,5 +1,5 @@ name: engine-io-version: 1.2.0+version: 1.2.1 synopsis: A Haskell implementation of Engine.IO homepage: http://github.com/ocharles/engine.io license: BSD3@@ -34,6 +34,7 @@     base64-bytestring >=1.0 && <1.1,     bytestring >=0.10.2.0 && <0.11,     either >= 3.4 && <4.4,+    free >= 4.9 && <5.0,     monad-loops >=0.4 && <0.5,     mwc-random >=0.13 && <0.14,     stm >=2.4 && <2.5,

@@ -53,6 +53,7 @@ import Control.Concurrent.MVar (MVar, newMVar, withMVar) import Control.Exception (SomeException(SomeException), try) import Control.Monad (MonadPlus, forever, guard, mzero, replicateM)+import Control.Monad.Trans.Iter (cutoff, delay, retract) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Loops (unfoldM) import Control.Monad.Trans.Class (lift)@@ -448,20 +449,30 @@   -> Bool   -> m () freshSession eio socketHandler api supportsBinary = do-  sId <- liftIO (newSocketId eio)+  socket <- do+    mkSocket <- liftIO $ do+      transport <- STM.newTVarIO =<< (Transport <$> STM.newTChanIO <*> STM.newTChanIO <*> pure Polling)+      incoming <- STM.newTChanIO+      outgoing <- STM.newTChanIO+      rawInBroadcast <- STM.newBroadcastTChanIO+      return (\sId -> Socket sId transport incoming outgoing rawInBroadcast) -  socket <- liftIO $-    Socket <$> pure sId-           <*> (do transport <- Transport <$> STM.newTChanIO-                                          <*> STM.newTChanIO-                                          <*> pure Polling-                   STM.newTVarIO transport)-           <*> STM.newTChanIO-           <*> STM.newTChanIO-           <*> STM.newBroadcastTChanIO+    let+      tryAllocation = liftIO $ do+        sId <- newSocketId eio+        STM.atomically $ runMaybeT $ do+          openSessions <- lift (STM.readTVar (eioOpenSessions eio))+          guard (not (HashMap.member sId openSessions))+          let socket = mkSocket sId+          lift (STM.modifyTVar' (eioOpenSessions eio) (HashMap.insert sId socket))+          return socket -  liftIO $ STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.insert sId socket))+      untilSuccess f = maybe (delay (untilSuccess f)) return =<< f +    maybeSocket <- retract (cutoff 10 (untilSuccess tryAllocation))+    maybe (srvTerminateWithResponse api 500 "text/plain" "Session allocation failed")+          return maybeSocket+   app <- socketHandler socket   userSpace <- liftIO $ Async.async (saApp app) @@ -495,10 +506,10 @@    _ <- liftIO $ Async.async $ do     _ <- Async.waitAnyCatchCancel [ userSpace, brain ]-    STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.delete sId))+    STM.atomically (STM.modifyTVar' (eioOpenSessions eio) (HashMap.delete (socketId socket)))     saOnDisconnect app -  let openMessage = OpenMessage { omSocketId = sId+  let openMessage = OpenMessage { omSocketId = socketId socket                                 , omUpgrades = [ Websocket ]                                 , omPingTimeout = 60000                                 , omPingInterval = 25000