Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

supporting HTTP/2. #399

Merged
merged 13 commits into from Jul 16, 2015
@@ -239,13 +239,27 @@ runTLSSocket' tlsset@TLSSettings{..} set credential sock app =
, TLS.serverSupported = def {
TLS.supportedVersions = tlsAllowedVersions
, TLS.supportedCiphers = tlsCiphers
, TLS.supportedHashSignatures = [
(TLS.HashSHA256, TLS.SignatureRSA)
, (TLS.HashSHA1, TLS.SignatureRSA)
]
}
, TLS.serverShared = def {
TLS.sharedCredentials = TLS.Credentials [credential]
}
, TLS.serverHooks = tlsServerHooks
, TLS.serverHooks = tlsServerHooks {
TLS.onALPNClientSuggest = Just alpn
}
}

alpn :: [S.ByteString] -> IO S.ByteString
alpn xs
| "h2" `elem` xs = return "h2"
| "h2-16" `elem` xs = return "h2-16"
| "h2-15" `elem` xs = return "h2-15"
| "h2-14" `elem` xs = return "h2-14"
| otherwise = return "http/1.1"

----------------------------------------------------------------

getter :: TLS.TLSParams params => TLSSettings -> Socket -> params -> IO (IO (Connection, Transport), SockAddr)
@@ -275,21 +289,24 @@ httpOverTls TLSSettings{..} s bs0 params = do
TLS.contextHookSetLogging ctx tlsLogging
TLS.handshake ctx
writeBuf <- allocateBuffer bufferSize
-- Creating a cache for leftover input data.
ref <- I.newIORef ""
tls <- getTLSinfo ctx
return (conn ctx writeBuf, tls)
return (conn ctx writeBuf ref, tls)
where
backend recvN = TLS.Backend {
TLS.backendFlush = return ()
, TLS.backendClose = sClose s
, TLS.backendSend = sendAll s
, TLS.backendRecv = recvN
}
conn ctx writeBuf = Connection {
conn ctx writeBuf ref = Connection {
connSendMany = TLS.sendData ctx . L.fromChunks
, connSendAll = sendall
, connSendFile = sendfile
, connClose = close
, connRecv = recv
, connRecv = recv ref
, connRecvBuf = recvBuf ref

This comment has been minimized.

Copy link
@alexanderkjeldaas

alexanderkjeldaas Jul 14, 2015

Contributor

document the ref, recvBuf or recv functions?

This comment has been minimized.

Copy link
@kazu-yamamoto

kazu-yamamoto Jul 15, 2015

Author Contributor

Network.Wai.Handler.Warp.Types says:

    -- | The connection receiving function. This returns "" for EOF.
    , connRecv        :: Recv
    -- | The connection receiving function. This tries to fill the buffer.
    --   This returns when the buffer is filled or reaches EOF.
    , connRecvBuf     :: RecvBuf

ref implements a cache for leftover input data.

, connWriteBuffer = writeBuf
, connBufferSize = bufferSize
}
@@ -302,7 +319,18 @@ httpOverTls TLSSettings{..} s bs0 params = do
void (tryIO $ TLS.bye ctx) `finally`
TLS.contextClose ctx

recv = handle onEOF go
-- TLS version of recv with a cache for leftover input data.
-- The cache is shared with recvBuf.
recv cref = do
cached <- I.readIORef cref
if cached /= "" then do
I.writeIORef cref ""
return cached
else
recv'

-- TLS version of recv (decrypting) without a cache.
recv' = handle onEOF go
where
onEOF e
| Just TLS.Error_EOF <- fromException e = return S.empty
@@ -314,6 +342,37 @@ httpOverTls TLSSettings{..} s bs0 params = do
else
return x

-- TLS version of recvBuf with a cache for leftover input data.
recvBuf cref buf siz = do
cached <- I.readIORef cref
(ret, leftover) <- fill cached buf siz recv'
I.writeIORef cref leftover
return ret

fill :: S.ByteString -> Buffer -> BufSize -> Recv -> IO (Bool,S.ByteString)

This comment has been minimized.

Copy link
@alexanderkjeldaas

alexanderkjeldaas Jul 14, 2015

Contributor

document this function?

fill bs0 buf0 siz0 recv
| siz0 <= len0 = do
let (bs, leftover) = S.splitAt siz0 bs0
void $ copy buf0 bs
return (True, leftover)
| otherwise = do
buf <- copy buf0 bs0
loop buf (siz0 - len0)
where
len0 = S.length bs0
loop _ 0 = return (True, "")
loop buf siz = do
bs <- recv
let len = S.length bs
if len == 0 then return (False, "")
else if (len <= siz) then do
buf' <- copy buf bs
loop buf' (siz - len)
else do
let (bs1,bs2) = S.splitAt siz bs
void $ copy buf bs1
return (True, bs2)

getTLSinfo :: TLS.Context -> IO Transport
getTLSinfo ctx = do
proto <- TLS.getNegotiatedProtocol ctx
@@ -0,0 +1,61 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where

import Control.Concurrent (forkIO, killThread)
import qualified Control.Exception as E
import Control.Monad (when, unless, replicateM)
import Data.ByteString (ByteString)
import Network.HTTP2
import Network.Socket (SockAddr)
import Network.Wai
import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
import Network.Wai.Handler.Warp.HTTP2.Receiver
import Network.Wai.Handler.Warp.HTTP2.Request
import Network.Wai.Handler.Warp.HTTP2.Sender
import Network.Wai.Handler.Warp.HTTP2.Types
import Network.Wai.Handler.Warp.HTTP2.Worker
import qualified Network.Wai.Handler.Warp.Settings as S (Settings)
import Network.Wai.Handler.Warp.Types

----------------------------------------------------------------

http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
http2 conn ii addr transport settings readN app = do
checkTLS
ok <- checkPreface
when ok $ do
ctx <- newContext
let responder = response ctx
mkreq = mkRequest settings addr
tid <- forkIO $ frameReceiver ctx mkreq readN
-- fixme: 10 is hard-coded
-- To prevent thread-leak, we executed the fixed number of threads
-- statically at this moment. But ResponseStream occupies one
-- worker thread. So, this should be dynamic.
tids <- replicateM 10 $ forkIO $ worker ctx settings tm app responder
-- frameSender is the main thread because it ensures to send
-- a goway frame.
frameSender ctx conn ii settings `E.finally` do
clearContext ctx
mapM_ killThread (tid:tids)
where
tm = timeoutManager ii
checkTLS = case transport of
TCP -> return () -- direct
tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"
tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3
checkPreface = do
preface <- readN connectionPrefaceLength
if connectionPreface /= preface then do
goaway conn ProtocolError "Preface mismatch"
return False
else
return True

-- connClose must not be called here since Run:fork calls it
goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
goaway Connection{..} etype debugmsg = connSendAll bytestream
where
bytestream = goawayFrame 0 etype debugmsg
@@ -0,0 +1,35 @@
{-# LANGUAGE OverloadedStrings #-}

module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where

import Data.ByteString (ByteString)
import Network.HTTP2

----------------------------------------------------------------

goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString
goawayFrame sid etype debugmsg = encodeFrame einfo frame
where
einfo = encodeInfo id 0
frame = GoAwayFrame sid etype debugmsg

resetFrame :: ErrorCodeId -> StreamId -> ByteString
resetFrame etype sid = encodeFrame einfo frame
where
einfo = encodeInfo id sid
frame = RSTStreamFrame etype

settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist
where
einfo = encodeInfo func 0

pingFrame :: ByteString -> ByteString
pingFrame bs = encodeFrame einfo $ PingFrame bs
where
einfo = encodeInfo setAck 0

windowUpdateFrame :: StreamId -> WindowSize -> ByteString
windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz
where
einfo = encodeInfo id sid
@@ -0,0 +1,49 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}

module Network.Wai.Handler.Warp.HTTP2.HPACK where

import Control.Arrow (first)
import qualified Control.Exception as E
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Char8 as B8
import Data.CaseInsensitive (foldedCase)
import Data.IORef (readIORef, writeIORef)
import Network.HPACK
import qualified Network.HTTP.Types as H
import Network.HTTP2
import Network.Wai
import Network.Wai.Handler.Warp.HTTP2.Types
import Network.Wai.Handler.Warp.Header
import Network.Wai.Handler.Warp.Response
import qualified Network.Wai.Handler.Warp.Settings as S
import Network.Wai.Handler.Warp.Types

hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response
-> IO Builder
hpackEncodeHeader Context{encodeDynamicTable} ii settings rsp = do
hdr1 <- addServerAndDate hdr0
let hdr2 = (":status", status) : map (first foldedCase) hdr1
ehdrtbl <- readIORef encodeDynamicTable
(ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr2
writeIORef encodeDynamicTable ehdrtbl'
return builder
where
hdr0 = responseHeaders rsp
status = B8.pack $ show $ H.statusCode $ responseStatus rsp
dc = dateCacher ii
rspidxhdr = indexResponseHeader hdr0
defServer = S.settingsServerName settings
addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr


----------------------------------------------------------------

hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList
hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
hdrtbl <- readIORef decodeDynamicTable
(hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
writeIORef decodeDynamicTable hdrtbl'
return hdr
where
cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
ProTip! Use n and p to navigate between commits in a pull request.
You can’t perform that action at this time.