websockets-snap 0.6.0.2 → 0.10.3.1
raw patch · 4 files changed
Files
- CHANGELOG.md +50/−0
- README.md +12/−0
- src/Network/WebSockets/Snap.hs +108/−24
- websockets-snap.cabal +14/−5
+ 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,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 }
websockets-snap.cabal view
@@ -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