websockets-snap 0.9.2.0 → 0.10.3.1
raw patch · 5 files changed
Files
- CHANGELOG +0/−11
- CHANGELOG.md +50/−0
- README.md +12/−0
- src/Network/WebSockets/Snap.hs +45/−99
- websockets-snap.cabal +11/−9
− CHANGELOG
@@ -1,11 +0,0 @@-- 0.9.2.0- * Bump websockets to 0.9.5.0 to fix socket closing issues--- 0.9.1.0- * Fixed interleaved messages issue--- 0.9.0.0- * Bump websockets dependency--- 0.8.2.2- * Bump mtl dependency
+ CHANGELOG.md view
@@ -0,0 +1,50 @@+# CHANGELOG++- 0.10.3.1 (2019-05-06)+ * Gracefully close ping threads when ServerApp finishes (by Lorenz+ Mösenlechner)++- 0.10.3.0 (2018-05-13)+ * Increase ping thread frequency to every 10s, extend Snap timeout by at+ least 60s (by Dmitry Dzhus)++- 0.10.2.5+ * Bump snap-server to 1.1++- 0.10.2.4 (2017-11-26)+ * Bump io-streams to 1.5++- 0.10.2.3 (2017-07-21)+ * Bump websockets to 0.12.0.0++- 0.10.2.2+ * Bump io-streams to 1.4.0.0++- 0.10.2.1+ * Bump websockets to 0.11.0.0++- 0.10.2.0+ * Bump websockets to 0.10.0.0++- 0.10.1.1+ * Add `bytestring-builder` as dependency to fix GHC 7.6 compatibility++- 0.10.1.0+ * Fix issues with timeout tickling++- 0.10.0.0+ * Bump snap-core and snap-server to 1.0.0.0+ * Remove git submodules; use hackage for all dependencies+ * Use cabal.project file to build example server++- 0.9.2.0+ * Bump websockets to 0.9.5.0 to fix socket closing issues++- 0.9.1.0+ * Fixed interleaved messages issue++- 0.9.0.0+ * Bump websockets dependency++- 0.8.2.2+ * Bump mtl dependency
+ README.md view
@@ -0,0 +1,12 @@+websockets-snap+===============++Provides [Snap] integration for the [websockets] library.++This library must be used with the threaded GHC runtime system. You can do this+by using something like this in your cabal file:++ ghc-options: -Wall -threaded -rtsopts "-with-rtsopts=-N"++[Snap]: http://snapframework.com/+[websockets]: http://jaspervdj.be/websockets/
src/Network/WebSockets/Snap.hs view
@@ -1,6 +1,7 @@ -------------------------------------------------------------------------------- -- | Snap integration for the WebSockets library {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Snap ( runWebSocketsSnap , runWebSocketsSnapWith@@ -9,27 +10,23 @@ -------------------------------------------------------------------------------- import Control.Concurrent (forkIO, myThreadId, threadDelay)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar,- takeMVar) import Control.Exception (Exception (..),- SomeException (..), finally,- handle, throwIO, throwTo)-import Control.Monad (forever)-import Control.Monad.Trans (lift)+ SomeException (..), handle,+ throwTo, finally)+import Data.IORef (IORef, newIORef, readIORef,+ writeIORef)+import Control.Monad (unless) import Data.ByteString (ByteString)+import qualified Data.ByteString.Builder as BSBuilder+import qualified Data.ByteString.Builder.Extra as BSBuilder import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import Data.IORef (newIORef, readIORef, writeIORef) import Data.Typeable (Typeable, cast) import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS import qualified Network.WebSockets.Stream as WS import qualified Snap.Core as Snap-import qualified Snap.Internal.Http.Types as Snap import qualified Snap.Types.Headers as Headers-+import qualified System.IO.Streams as Streams -------------------------------------------------------------------------------- data Chunk@@ -51,61 +48,6 @@ ---------------------------------------------------------------------------------copyIterateeToMVar- :: ((Int -> Int) -> IO ())- -> MVar Chunk- -> E.Iteratee ByteString IO ()-copyIterateeToMVar tickle mvar = E.catchError go handler- where- go = do- mbs <- EL.head- case mbs of- Just x -> do- lift (tickle (max 60))- lift (putMVar mvar (Chunk x))- go- Nothing -> lift (putMVar mvar Eof)-- handler se@(SomeException e) = case cast e of- -- Clean exit- Just ServerAppDone -> return ()- -- Actual error- Nothing -> lift $ putMVar mvar $ Error se------------------------------------------------------------------------------------copyMVarToStream :: MVar Chunk -> IO (IO (Maybe ByteString))-copyMVarToStream mvar = return go- where- go = do- chunk <- takeMVar mvar- case chunk of- Chunk x -> return (Just x)- Eof -> return Nothing- Error (SomeException e) -> throwIO e------------------------------------------------------------------------------------copyStreamToIteratee- :: E.Iteratee ByteString IO ()- -> IO (Maybe BL.ByteString -> IO ())-copyStreamToIteratee iteratee0 = do- ref <- newIORef =<< E.runIteratee iteratee0- return (go ref)- where- go _ Nothing = return ()- go ref (Just bl) = do- step <- readIORef ref- case step of- E.Continue f -> do- let chunks = BL.toChunks bl- step' <- E.runIteratee $ f $ E.Chunks chunks- writeIORef ref step'- E.Yield () _ -> throwIO WS.ConnectionClosed- E.Error (SomeException e) -> throwIO e----------------------------------------------------------------------------------- -- | The following function escapes from the current 'Snap.Snap' handler, and -- continues processing the 'WS.WebSockets' action. The action to be executed -- takes the 'WS.Request' as a parameter, because snap has already read this@@ -120,50 +62,54 @@ -------------------------------------------------------------------------------- -- | Variant of 'runWebSocketsSnap' which allows custom options runWebSocketsSnapWith- :: Snap.MonadSnap m- => WS.ConnectionOptions- -> WS.ServerApp- -> m ()+ :: Snap.MonadSnap m+ => WS.ConnectionOptions+ -> WS.ServerApp+ -> m () runWebSocketsSnapWith options app = do- rq <- Snap.getRequest- Snap.escapeHttp $ \tickle writeEnd -> do+ rq <- Snap.getRequest+ Snap.escapeHttp $ \tickle readEnd writeEnd -> do - thisThread <- lift myThreadId- mvar <- lift newEmptyMVar- parse <- lift $ copyMVarToStream mvar- write <- lift $ copyStreamToIteratee writeEnd- stream <- lift $ WS.makeStream parse write+ thisThread <- myThreadId+ stream <- WS.makeStream (Streams.read readEnd)+ (\v -> do+ Streams.write (fmap BSBuilder.lazyByteString v) writeEnd+ Streams.write (Just BSBuilder.flush) writeEnd+ ) - let options' = options- { WS.connectionOnPong = do- tickle (max 60)- WS.connectionOnPong options- }+ done <- newIORef False - pc = WS.PendingConnection- { WS.pendingOptions = options'- , WS.pendingRequest = fromSnapRequest rq- , WS.pendingOnAccept = forkPingThread tickle- , WS.pendingStream = stream- }+ let options' = options+ { WS.connectionOnPong = do+ tickle (max 45)+ WS.connectionOnPong options+ } - _ <- lift $ forkIO $ finally (app pc) $ do- WS.close stream- throwTo thisThread ServerAppDone- copyIterateeToMVar tickle mvar+ pc = WS.PendingConnection+ { WS.pendingOptions = options'+ , WS.pendingRequest = fromSnapRequest rq+ , WS.pendingOnAccept = forkPingThread tickle done+ , WS.pendingStream = stream+ }+ (app pc >> throwTo thisThread ServerAppDone) `finally` writeIORef done True -------------------------------------------------------------------------------- -- | Start a ping thread in the background-forkPingThread :: ((Int -> Int) -> IO ()) -> WS.Connection -> IO ()-forkPingThread tickle conn = do+forkPingThread :: ((Int -> Int) -> IO ()) -> IORef Bool -> WS.Connection -> IO ()+forkPingThread tickle done conn = do _ <- forkIO pingThread return () where- pingThread = handle ignore $ forever $ do- WS.sendPing conn (BC.pack "ping")- tickle (min 15)- threadDelay $ 30 * 1000 * 1000+ pingThread = handle ignore $+ let loop = do+ d <- readIORef done+ unless d $ do+ WS.sendPing conn (BC.pack "ping")+ tickle (max 60)+ threadDelay $ 10 * 1000 * 1000+ loop in+ loop ignore :: SomeException -> IO () ignore _ = return ()
websockets-snap.cabal view
@@ -1,5 +1,5 @@ Name: websockets-snap-Version: 0.9.2.0+Version: 0.10.3.1 Synopsis: Snap integration for the websockets library Description: Snap integration for the websockets library License: BSD3@@ -11,7 +11,8 @@ Cabal-version: >= 1.6 Extra-source-files:- CHANGELOG+ CHANGELOG.md+ README.md Library Hs-source-dirs: src@@ -21,13 +22,14 @@ Network.WebSockets.Snap Build-depends:- base >= 4 && < 5,- bytestring >= 0.9 && < 0.11,- enumerator >= 0.4 && < 0.5,- mtl >= 2.1 && < 2.3,- snap-core >= 0.8 && < 0.10,- snap-server >= 0.8 && < 0.10,- websockets >= 0.9.5 && < 0.10+ base >= 4 && < 5,+ bytestring >= 0.9 && < 0.11,+ bytestring-builder >= 0.10 && < 0.11,+ io-streams >= 1.3 && < 1.6,+ mtl >= 2.1 && < 2.3,+ snap-core >= 1.0 && < 1.1,+ snap-server >= 1.0 && < 1.2,+ websockets >= 0.9.5 && < 0.13 Source-repository head Type: git