Created
April 13, 2020 11:47
-
-
Save Woody88/b6749cca380aa1e29f9d7adce924b100 to your computer and use it in GitHub Desktop.
Wai Websockets
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
websocketsOr :: WS.ConnectionOptions | |
-> WS.ServerApp | |
-> Wai.Application | |
-> Wai.Application | |
websocketsOr opts app backup req sendResponse = | |
case websocketsApp opts app req of | |
Nothing -> backup req sendResponse | |
Just res -> sendResponse res | |
websocketsApp :: WS.ConnectionOptions | |
-> WS.ServerApp | |
-> Wai.Request | |
-> Maybe Wai.Response | |
websocketsApp opts app request | |
| isWebSocketsReq request = do | |
Just $ Wai.responseSocket \socket -> | |
runWebSockets opts (getRequestHead request) app socket | |
| otherwise = Nothing | |
getRequestHead :: Wai.Request -> WS.RequestHead | |
getRequestHead (Request req) = RequestHead | |
{ path: req.rawPathInfo <> "/" <> req.rawQueryString | |
, headers: req.requestHeaders | |
, secure: req.isSecure | |
} | |
-- | Returns whether or not the given 'Wai.Request' is a WebSocket request. | |
isWebSocketsReq :: Wai.Request -> Boolean | |
isWebSocketsReq (Request req) = | |
upgradeRequestHeader == (Just $ caseI "websocket") | |
where | |
caseI = CaseInsensitiveString | |
requestHeaders = Map.fromFoldable $ req.requestHeaders | |
upgradeRequestHeader = map caseI (Map.lookup H.hUpgrade requestHeaders) | |
runWebSockets :: forall a. | |
WS.ConnectionOptions | |
-> WS.RequestHead | |
-> (WS.PendingConnection -> Effect a) | |
-> Net.Socket | |
-> Effect a | |
runWebSockets options request app socket = do | |
wss <- WSS.createServer NoServer mempty | |
app pc | |
where | |
pc = WS.PendingConnection | |
{ options | |
, request | |
, onAccept: \_ -> pure unit | |
, socket | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment