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.

@alexanderkjeldaas

alexanderkjeldaas Jul 14, 2015

Contributor

document the ref, recvBuf or recv functions?

@alexanderkjeldaas

alexanderkjeldaas Jul 14, 2015

Contributor

document the ref, recvBuf or recv functions?

This comment has been minimized.

@kazu-yamamoto

kazu-yamamoto Jul 15, 2015

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.

@kazu-yamamoto

kazu-yamamoto Jul 15, 2015

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.

@alexanderkjeldaas

alexanderkjeldaas Jul 14, 2015

Contributor

document this function?

@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"
Oops, something went wrong.