diff --git a/CHANGELOG b/CHANGELOG deleted file mode 100644 --- a/CHANGELOG +++ /dev/null @@ -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 diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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/ diff --git a/src/Network/WebSockets/Snap.hs b/src/Network/WebSockets/Snap.hs --- a/src/Network/WebSockets/Snap.hs +++ b/src/Network/WebSockets/Snap.hs @@ -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 () diff --git a/websockets-snap.cabal b/websockets-snap.cabal --- a/websockets-snap.cabal +++ b/websockets-snap.cabal @@ -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