websockets 0.12.6.1 → 0.12.7.0
raw patch · 6 files changed
+142/−24 lines, 6 filesdep +clockdep ~base
Dependencies added: clock
Dependency ranges changed: base
Files
- CHANGELOG +7/−0
- src/Network/WebSockets.hs +3/−0
- src/Network/WebSockets/Http.hs +2/−1
- src/Network/WebSockets/Server.hs +114/−16
- tests/autobahn/server.hs +9/−5
- websockets.cabal +7/−2
CHANGELOG view
@@ -1,5 +1,12 @@ # CHANGELOG +- 0.12.7.0 (2019-12-31)+ * Bump `base` lower bound to 4.8, this drops support for GHC 7.6 and 7.8+ * Add a new `runServerWithOptions` that can be extended in a more+ future-compatible way+ * Add a connection killer setting in `runServerWithOptions`+ * Fix an unsafe read issue in `decodeResponseHead`+ - 0.12.6.1 (2019-10-29) * Bump `network` dependency to 3.1
src/Network/WebSockets.hs view
@@ -65,6 +65,9 @@ , ServerApp , runServer , runServerWith+ , ServerOptions (..)+ , defaultServerOptions+ , runServerWithOptions -- * Utilities for writing your own server , makeListenSocket
src/Network/WebSockets/Http.hs view
@@ -194,7 +194,8 @@ space = A.word8 (c2w ' ') newline = A.string "\r\n" - code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space+ code = A.string "HTTP/1.1" *> space *> A.takeWhile1 digit <* space+ digit = \x -> x >= c2w '0' && x <= c2w '9' message = A.takeWhile (/= c2w '\r') <* newline
src/Network/WebSockets/Server.hs view
@@ -6,21 +6,30 @@ module Network.WebSockets.Server ( ServerApp , runServer+ , ServerOptions (..)+ , defaultServerOptions+ , runServerWithOptions , runServerWith , makeListenSocket , makePendingConnection , makePendingConnectionFromStream++ , PongTimeout ) where ---------------------------------------------------------------------------------import Control.Concurrent (forkIOWithUnmask)-import Control.Exception (allowInterrupt, bracket,- bracketOnError, finally, mask_,- throwIO)-import Control.Monad (forever, void)+import Control.Concurrent (threadDelay)+import qualified Control.Concurrent.Async as Async+import Control.Exception (Exception, allowInterrupt,+ bracket, bracketOnError,+ finally, mask_, throwIO)+import Control.Monad (forever, void, when)+import qualified Data.IORef as IORef+import Data.Maybe (isJust) import Network.Socket (Socket) import qualified Network.Socket as S+import qualified System.Clock as Clock --------------------------------------------------------------------------------@@ -63,21 +72,100 @@ -------------------------------------------------------------------------------- -- | A version of 'runServer' which allows you to customize some options. runServerWith :: String -> Int -> ConnectionOptions -> ServerApp -> IO ()-runServerWith host port opts app = S.withSocketsDo $- bracket- (makeListenSocket host port)- S.close- (\sock ->- mask_ $ forever $ do- allowInterrupt- (conn, _) <- S.accept sock- void $ forkIOWithUnmask $ \unmask ->- finally (unmask $ runApp conn opts app) (S.close conn)- )+runServerWith host port opts = runServerWithOptions defaultServerOptions+ { serverHost = host+ , serverPort = port+ , serverConnectionOptions = opts+ }+{-# DEPRECATED runServerWith "Use 'runServerWithOptions' instead" #-} +--------------------------------------------------------------------------------+data ServerOptions = ServerOptions+ { serverHost :: String+ , serverPort :: Int+ , serverConnectionOptions :: ConnectionOptions+ -- | Require a pong from the client every N seconds; otherwise kill the+ -- connection. If you use this, you should also use 'withPingThread' to+ -- send a ping at a smaller interval; for example N/2.+ , serverRequirePong :: Maybe Int+ } + --------------------------------------------------------------------------------+defaultServerOptions :: ServerOptions+defaultServerOptions = ServerOptions+ { serverHost = "127.0.0.1"+ , serverPort = 8080+ , serverConnectionOptions = defaultConnectionOptions+ , serverRequirePong = Nothing+ }+++--------------------------------------------------------------------------------+-- | Customizable version of 'runServer'. Never returns until killed.+--+-- Please use the 'defaultServerOptions' combined with record updates to set the+-- fields you want. This way your code is unlikely to break on future changes.+runServerWithOptions :: ServerOptions -> ServerApp -> IO a+runServerWithOptions opts app = S.withSocketsDo $+ bracket+ (makeListenSocket host port)+ S.close $ \sock -> mask_ $ forever $ do+ allowInterrupt+ (conn, _) <- S.accept sock++ -- This IORef holds a time at which the thread may be killed. This time+ -- can be extended by calling 'tickle'.+ killRef <- IORef.newIORef =<< (+ killDelay) <$> getSecs+ let tickle = IORef.writeIORef killRef =<< (+ killDelay) <$> getSecs++ -- Update the connection options to call 'tickle' whenever a pong is+ -- received.+ let connOpts'+ | not useKiller = connOpts+ | otherwise = connOpts+ { connectionOnPong = tickle >> connectionOnPong connOpts+ }++ -- Run the application.+ appAsync <- Async.asyncWithUnmask $ \unmask ->+ (unmask $ do+ runApp conn connOpts' app) `finally`+ (S.close conn)++ -- Install the killer if required.+ when useKiller $ void $ Async.async (killer killRef appAsync)+ where+ host = serverHost opts+ port = serverPort opts+ connOpts = serverConnectionOptions opts++ -- Get the current number of seconds on some clock.+ getSecs = Clock.sec <$> Clock.getTime Clock.Monotonic++ -- Parse the 'serverRequirePong' options.+ useKiller = isJust $ serverRequirePong opts+ killDelay = maybe 0 fromIntegral (serverRequirePong opts)++ -- Thread that reads the killRef, and kills the application if enough time+ -- has passed.+ killer killRef appAsync = do+ killAt <- IORef.readIORef killRef+ now <- getSecs+ appState <- Async.poll appAsync+ case appState of+ -- Already finished/killed/crashed, we can give up.+ Just _ -> return ()+ -- Should not be killed yet. Wait and try again.+ Nothing | now < killAt -> do+ threadDelay (fromIntegral killDelay * 1000 * 1000)+ killer killRef appAsync+ -- Time to kill.+ _ -> Async.cancelWith appAsync PongTimeout+++-------------------------------------------------------------------------------- -- | Create a standardized socket on which you can listen for incomming -- connections. Should only be used for a quick and dirty solution! Should be -- preceded by the call 'Network.Socket.withSocketsDo'.@@ -135,3 +223,13 @@ , pendingOnAccept = \_ -> return () , pendingStream = stream }+++--------------------------------------------------------------------------------+-- | Internally used exception type used to kill connections if there+-- is a pong timeout.+data PongTimeout = PongTimeout deriving Show+++--------------------------------------------------------------------------------+instance Exception PongTimeout
tests/autobahn/server.hs view
@@ -78,10 +78,14 @@ -------------------------------------------------------------------------------- -- | Accepts clients, spawns a single handler for each one. main :: IO ()-main = WS.runServerWith "0.0.0.0" 9001 options application+main = WS.runServerWithOptions options application where- options = WS.defaultConnectionOptions- { WS.connectionCompressionOptions =- WS.PermessageDeflateCompression WS.defaultPermessageDeflate- , WS.connectionStrictUnicode = True+ options = WS.defaultServerOptions+ { WS.serverHost = "0.0.0.0"+ , WS.serverPort = 9001+ , WS.serverConnectionOptions = WS.defaultConnectionOptions+ { WS.connectionCompressionOptions =+ WS.PermessageDeflateCompression WS.defaultPermessageDeflate+ , WS.connectionStrictUnicode = True+ } }
websockets.cabal view
@@ -1,5 +1,5 @@ Name: websockets-Version: 0.12.6.1+Version: 0.12.7.0 Synopsis: A sensible and clean way to write WebSocket-capable servers in Haskell.@@ -81,12 +81,13 @@ Build-depends: async >= 2.2 && < 2.3, attoparsec >= 0.10 && < 0.14,- base >= 4.6 && < 5,+ base >= 4.8 && < 5, base64-bytestring >= 0.1 && < 1.1, binary >= 0.8.1 && < 0.11, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3,+ clock >= 0.8 && < 0.9, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.2, random >= 1.0 && < 1.2,@@ -145,6 +146,7 @@ bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3,+ clock >= 0.8 && < 0.9, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.2, random >= 1.0 && < 1.2,@@ -172,6 +174,7 @@ bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3,+ clock >= 0.8 && < 0.9, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.2, random >= 1.0 && < 1.2,@@ -201,6 +204,7 @@ bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3,+ clock >= 0.8 && < 0.9, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.2, random >= 1.0 && < 1.2,@@ -228,6 +232,7 @@ bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11, case-insensitive >= 0.3 && < 1.3,+ clock >= 0.8 && < 0.9, containers >= 0.3 && < 0.7, network >= 2.3 && < 3.2, random >= 1.0 && < 1.2,