supporting HTTP/2.

warp-tls/Network/Wai/Handler/WarpTLS.hs

@@ -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
       , 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)
+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

warp/Network/Wai/Handler/Warp/HTTP2.hs

@@ -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

warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hs

@@ -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

warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs

@@ -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"