wai-websockets 2.0.0.1 → 2.1.0
raw patch · 3 files changed
+67/−55 lines, 3 filesdep +http-typesdep ~waidep ~warp
Dependencies added: http-types
Dependency ranges changed: wai, warp
Files
- Network/Wai/Handler/WebSockets.hs +62/−50
- server.lhs +1/−2
- wai-websockets.cabal +4/−3
Network/Wai/Handler/WebSockets.hs view
@@ -1,60 +1,75 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WebSockets- ( intercept- , interceptWith+ ( websocketsApp+ , websocketsOr+ , isWebSocketsReq+ , getRequestHead+ , runWebSockets ) where -import Control.Monad.IO.Class (liftIO)-import Blaze.ByteString.Builder (Builder)-import qualified Blaze.ByteString.Builder as Builder import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC-import Data.Char (toLower)+import qualified Data.CaseInsensitive as CI import Data.Conduit+import Data.IORef (newIORef, readIORef, writeIORef)+import Network.HTTP.Types (status500) import qualified Network.Wai as Wai-import qualified Network.Wai.Handler.Warp as Warp import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS import System.IO.Streams (InputStream, OutputStream) import qualified System.IO.Streams as Streams ----------------------------------------------------------------------------------- | For use with 'settingsIntercept' from the Warp web server.-intercept :: WS.ServerApp- -> Wai.Request- -> Maybe (Source IO ByteString -> Warp.Connection -> IO ())-intercept = interceptWith WS.defaultConnectionOptions+isWebSocketsReq :: Wai.Request -> Bool+isWebSocketsReq req =+ fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket" ----------------------------------------------------------------------------------- | Variation of 'intercept' which allows custom options.-interceptWith :: WS.ConnectionOptions+websocketsOr :: WS.ConnectionOptions+ -> WS.ServerApp+ -> Wai.Application+ -> Wai.Application+websocketsOr opts app backup req =+ case websocketsApp opts app req of+ Nothing -> backup req+ Just res -> return res++--------------------------------------------------------------------------------+websocketsApp :: WS.ConnectionOptions -> WS.ServerApp -> Wai.Request- -> Maybe (Source IO ByteString -> Warp.Connection -> IO ())-interceptWith opts app req = case lookup "upgrade" (Wai.requestHeaders req) of- Just s- | BC.map toLower s == "websocket" -> Just $ runWebSockets opts req' app- | otherwise -> Nothing- _ -> Nothing- where- req' = WS.RequestHead- (Wai.rawPathInfo req `BC.append` Wai.rawQueryString req)- (Wai.requestHeaders req)- (Wai.isSecure req)+ -> Maybe Wai.Response+websocketsApp opts app req+ | isWebSocketsReq req =+ Just $ flip Wai.responseRaw backup $ \src sink ->+ runWebSockets opts req' app src sink+ | otherwise = Nothing+ where+ req' = getRequestHead req+ backup = Wai.responseLBS status500 [("Content-Type", "text/plain")]+ "The web application attempted to send a WebSockets response, but WebSockets are not supported by your WAI handler." --------------------------------------------------------------------------------+getRequestHead :: Wai.Request -> WS.RequestHead+getRequestHead req = WS.RequestHead+ (Wai.rawPathInfo req `BC.append` Wai.rawQueryString req)+ (Wai.requestHeaders req)+ (Wai.isSecure req)++-------------------------------------------------------------------------------- ---- | Internal function to run the WebSocket io-streams using the conduit library runWebSockets :: WS.ConnectionOptions -> WS.RequestHead- -> WS.ServerApp+ -> (WS.PendingConnection -> IO a) -> Source IO ByteString- -> Warp.Connection- -> IO ()-runWebSockets opts req app _ conn = do+ -> Sink ByteString IO ()+ -> IO a+runWebSockets opts req app src sink = do - (is, os) <- liftIO $ connectionToStreams conn+ is <- srcToInput src+ os <- sinkToOutput sink >>= Streams.builderStream - let pc = WS.PendingConnection + let pc = WS.PendingConnection { WS.pendingOptions = opts , WS.pendingRequest = req , WS.pendingOnAccept = \_ -> return ()@@ -62,24 +77,21 @@ , WS.pendingOut = os } - liftIO $ app pc+ app pc ---------------------------------------------------------------------------------- | Converts a 'Connection' to an 'InputStream' \/ 'OutputStream' pair. Note that,--- as is usually the case in @io-streams@, writing a 'Nothing' to the generated--- 'OutputStream' does not cause the underlying 'Connection' to be closed.-connectionToStreams :: Warp.Connection- -> IO (InputStream ByteString, OutputStream Builder)-connectionToStreams connection = do- is <- Streams.makeInputStream input- os <- Streams.makeOutputStream output- return $! (is, os)- - where- input = do- s <- Warp.connRecv connection- return $! if BC.null s then Nothing else Just s+srcToInput :: Source IO ByteString -> IO (InputStream ByteString)+srcToInput src0 = do+ (rsrc0, ()) <- src0 $$+ return ()+ ref <- newIORef rsrc0+ Streams.makeInputStream $ do+ rsrc <- readIORef ref+ (rsrc', mbs) <- rsrc $$++ await+ writeIORef ref rsrc'+ return mbs - output Nothing = return $! ()- output (Just s') = if BC.null s then return $! () else Warp.connSendAll connection s- where s = Builder.toByteString s'+sinkToOutput :: Sink ByteString IO () -> IO (OutputStream ByteString)+sinkToOutput sink =+ Streams.makeOutputStream output+ where+ output Nothing = return ()+ output (Just bs) = yield bs $$ sink
server.lhs view
@@ -78,8 +78,7 @@ > state <- newMVar newServerState > Warp.runSettings Warp.defaultSettings > { Warp.settingsPort = 9160-> , Warp.settingsIntercept = WaiWS.intercept (application state)-> } staticApp+> } $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp > staticApp :: Network.Wai.Application > staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
wai-websockets.cabal view
@@ -1,5 +1,5 @@ Name: wai-websockets-Version: 2.0.0.1+Version: 2.1.0 Synopsis: Provide a bridge betweeen WAI and the websockets package. License: MIT License-file: LICENSE@@ -20,14 +20,14 @@ Build-Depends: base >= 3 && < 5 , bytestring >= 0.9.1.4 , conduit >= 0.5 && < 1.1- , wai >= 2.0 && < 2.1+ , wai >= 2.1 && < 2.2 , blaze-builder >= 0.2.1.4 && < 0.4 , case-insensitive >= 0.2 , network >= 2.2.1.5 , transformers >= 0.2 && < 0.4 , websockets >= 0.8- , warp >= 2.0 && < 2.1 , io-streams >= 1.1 && < 1.2+ , http-types Exposed-modules: Network.Wai.Handler.WebSockets ghc-options: -Wall @@ -51,6 +51,7 @@ , text , file-embed , io-streams+ , http-types ghc-options: -Wall -threaded main-is: server.lhs