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,41 +1,125 @@ +-------------------------------------------------------------------------------- -- | Snap integration for the WebSockets library +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} module Network.WebSockets.Snap ( runWebSocketsSnap , runWebSocketsSnapWith ) where -import qualified Network.WebSockets as WS -import qualified Snap.Core as Snap -import qualified Snap.Internal.Http.Types as Snap -import qualified Snap.Types.Headers as Headers +-------------------------------------------------------------------------------- +import Control.Concurrent (forkIO, myThreadId, threadDelay) +import Control.Exception (Exception (..), + 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 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.Types.Headers as Headers +import qualified System.IO.Streams as Streams + +-------------------------------------------------------------------------------- +data Chunk + = Chunk ByteString + | Eof + | Error SomeException + deriving (Show) + + +-------------------------------------------------------------------------------- +data ServerAppDone = ServerAppDone + deriving (Eq, Ord, Show, Typeable) + + +-------------------------------------------------------------------------------- +instance Exception ServerAppDone where + toException ServerAppDone = SomeException ServerAppDone + fromException (SomeException e) = cast 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 -- from the socket. -runWebSocketsSnap :: WS.Protocol p - => (WS.Request -> WS.WebSockets p ()) - -> Snap.Snap () -runWebSocketsSnap = runWebSocketsSnapWith WS.defaultWebSocketsOptions +runWebSocketsSnap + :: Snap.MonadSnap m + => WS.ServerApp + -> m () +runWebSocketsSnap = runWebSocketsSnapWith WS.defaultConnectionOptions + +-------------------------------------------------------------------------------- -- | Variant of 'runWebSocketsSnap' which allows custom options -runWebSocketsSnapWith :: WS.Protocol p - => WS.WebSocketsOptions - -> (WS.Request -> WS.WebSockets p ()) - -> Snap.Snap () -runWebSocketsSnapWith options ws = do - rq <- Snap.getRequest - Snap.escapeHttp $ \tickle writeEnd -> - let options' = options - { WS.onPong = tickle (max 30) >> WS.onPong options - } +runWebSocketsSnapWith + :: Snap.MonadSnap m + => WS.ConnectionOptions + -> WS.ServerApp + -> m () +runWebSocketsSnapWith options app = do + rq <- Snap.getRequest + Snap.escapeHttp $ \tickle readEnd writeEnd -> do - in WS.runWebSocketsWith options' (fromSnapRequest rq) ws writeEnd + thisThread <- myThreadId + stream <- WS.makeStream (Streams.read readEnd) + (\v -> do + Streams.write (fmap BSBuilder.lazyByteString v) writeEnd + Streams.write (Just BSBuilder.flush) writeEnd + ) + done <- newIORef False + + let options' = options + { WS.connectionOnPong = do + tickle (max 45) + WS.connectionOnPong options + } + + 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 ()) -> IORef Bool -> WS.Connection -> IO () +forkPingThread tickle done conn = do + _ <- forkIO pingThread + return () + where + 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 () + + +-------------------------------------------------------------------------------- -- | Convert a snap request to a websockets request -fromSnapRequest :: Snap.Request -> WS.RequestHttpPart -fromSnapRequest rq = WS.RequestHttpPart - { WS.requestHttpPath = Snap.rqURI rq - , WS.requestHttpHeaders = Headers.toList (Snap.rqHeaders rq) - , WS.requestHttpSecure = Snap.rqIsSecure rq +fromSnapRequest :: Snap.Request -> WS.RequestHead +fromSnapRequest rq = WS.RequestHead + { WS.requestPath = Snap.rqURI rq + , WS.requestHeaders = Headers.toList (Snap.rqHeaders rq) + , WS.requestSecure = Snap.rqIsSecure rq } 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.6.0.2 +Version: 0.10.3.1 Synopsis: Snap integration for the websockets library Description: Snap integration for the websockets library License: BSD3 @@ -10,17 +10,26 @@ Build-type: Simple Cabal-version: >= 1.6 +Extra-source-files: + CHANGELOG.md + README.md + Library Hs-source-dirs: src + Ghc-options: -Wall Exposed-modules: Network.WebSockets.Snap Build-depends: - base >= 4 && < 5, - snap-core >= 0.8 && < 0.10, - snap-server >= 0.8 && < 0.10, - websockets >= 0.6 && < 0.7 + 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