diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -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 diff --git a/src/Network/WebSockets.hs b/src/Network/WebSockets.hs --- a/src/Network/WebSockets.hs +++ b/src/Network/WebSockets.hs @@ -65,6 +65,9 @@ , ServerApp , runServer , runServerWith + , ServerOptions (..) + , defaultServerOptions + , runServerWithOptions -- * Utilities for writing your own server , makeListenSocket diff --git a/src/Network/WebSockets/Http.hs b/src/Network/WebSockets/Http.hs --- a/src/Network/WebSockets/Http.hs +++ b/src/Network/WebSockets/Http.hs @@ -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 diff --git a/src/Network/WebSockets/Server.hs b/src/Network/WebSockets/Server.hs --- a/src/Network/WebSockets/Server.hs +++ b/src/Network/WebSockets/Server.hs @@ -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 diff --git a/tests/autobahn/server.hs b/tests/autobahn/server.hs --- a/tests/autobahn/server.hs +++ b/tests/autobahn/server.hs @@ -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 + } } diff --git a/websockets.cabal b/websockets.cabal --- a/websockets.cabal +++ b/websockets.cabal @@ -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,