Fix timeouts/allow authority override

* For timeouts, the gRPC spec does not allow spaces * For some deployments it is useful to be able to specify the HTTP2 :authority pseudo-header separate from the address. Co-authored-by: Justin Le <[email protected]>
well-typed · Dec 2, 2023 · 1c9c2ce · 1c9c2ce
1 parent 5d8f95e
commit 1c9c2ce
Show file tree

Hide file tree

Showing 12 changed files with 127 additions and 129 deletions.
diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml
@@ -160,6 +160,11 @@ jobs:
           echo "package grapesy" >> cabal.project
           echo "    ghc-options: -Werror=missing-methods" >> cabal.project
           cat >> cabal.project <<EOF
+          source-repository-package
+            type:     git
+            location: https://github.com/edsko/http2-tls
+            tag:      1c94ec1b5f43b241c9bfb4c1a38d150f4faf9c45
+
           package grapesy
             tests:       True
             flags:       +build-demo +build-stress-test

diff --git a/cabal.project b/cabal.project
@@ -3,3 +3,9 @@ packages: .
 package grapesy
   tests: True
   flags: +build-demo +build-stress-test
+
+-- https://github.com/kazu-yamamoto/http2-tls/pull/6
+source-repository-package
+  type: git
+  location: https://github.com/edsko/http2-tls
+  tag: 1c94ec1b5f43b241c9bfb4c1a38d150f4faf9c45
diff --git a/cabal.project.ci b/cabal.project.ci
@@ -4,3 +4,9 @@ package grapesy
   tests: True
   flags: +build-demo +build-stress-test
   ghc-options: -Werror
+
+-- https://github.com/kazu-yamamoto/http2-tls/pull/6
+source-repository-package
+  type: git
+  location: https://github.com/edsko/http2-tls
+  tag: 1c94ec1b5f43b241c9bfb4c1a38d150f4faf9c45
diff --git a/demo-client/Demo/Client/Cmdline.hs b/demo-client/Demo/Client/Cmdline.hs
@@ -129,18 +129,23 @@ parseServer =
                    , Opt.help "Connect over TLS"
                    ])
               *> parseServerValidation)
+      <*> (Opt.optional $ Opt.option Opt.str $ mconcat [
+              Opt.long "authority"
+            , Opt.help "Override the HTTP2 :authority pseudo-header"
+            ])
   where
     mkServer ::
          String                          -- Host
       -> Maybe Word                      -- Port
       -> Maybe Client.ServerValidation   -- Secure?
+      -> Maybe String
       -> Client.Server
-    mkServer host mPort Nothing =
+    mkServer host mPort Nothing mAuth =
         Client.ServerInsecure $
-          Client.Authority host (fromMaybe 50051 mPort)
-    mkServer host mPort (Just validation) =
+          Client.Address host (fromMaybe 50051 mPort) mAuth
+    mkServer host mPort (Just validation) mAuth =
         Client.ServerSecure validation def $
-          Client.Authority host (fromMaybe 50052 mPort)
+          Client.Address host (fromMaybe 50052 mPort) mAuth
 
 parseServerValidation :: Opt.Parser Client.ServerValidation
 parseServerValidation = asum [

diff --git a/docs/demo-client.md b/docs/demo-client.md
@@ -52,6 +52,12 @@ a self-signed certificate, the above will result in
 demo-client: HandshakeFailed (Error_Protocol ("certificate has unknown CA",True,UnknownCa))
 ```
 
+You might see an error such as this on the Python side (if using):
+
+```
+Handshake failed with fatal error SSL_ERROR_SSL: error:10000070:SSL routines:OPENSSL_internal:BAD_PACKET_LENGTH
+```
+
 There are two ways to address this. We can disable certificate validation
 altogether:
 
@@ -63,7 +69,8 @@ cabal run demo-client -- sayHello \
 ```
 
 or we can define our own roots; for example, we can declare the demo server's
-own certificate as a root:
+own certificate as a root (this works with both the Python demo server as well
+as our own):
 
 ```
 cabal run demo-client -- sayHello \

diff --git a/src/Network/GRPC/Client.hs b/src/Network/GRPC/Client.hs
@@ -13,7 +13,7 @@ module Network.GRPC.Client (
 
     -- ** Connection parameters
   , Scheme(..)
-  , Authority(..)
+  , Address(..)
 
     -- ** Secure connection (TLS)
   , ServerValidation(..)

diff --git a/src/Network/GRPC/Client/Connection.hs b/src/Network/GRPC/Client/Connection.hs
@@ -49,6 +49,7 @@ import Network.GRPC.Util.Session qualified as Session
 import Network.GRPC.Util.TLS (ServerValidation(..), SslKeyLog(..))
 import Network.GRPC.Util.TLS qualified as Util.TLS
 import Network.TLS (TLSException)
+import Data.ByteString.UTF8 qualified as BS.Strict.UTF8
 
 {-------------------------------------------------------------------------------
   Connection API
@@ -241,10 +242,10 @@ isFinalException err
 
 data Server =
     -- | Make insecure connection (without TLS) to the given server
-    ServerInsecure Authority
+    ServerInsecure Address
 
     -- | Make secure connection (with TLS) to the given server
-  | ServerSecure ServerValidation SslKeyLog Authority
+  | ServerSecure ServerValidation SslKeyLog Address
   deriving stock (Show)
 
 {-------------------------------------------------------------------------------
@@ -416,18 +417,18 @@ stayConnected connParams server connVar connCanClose =
 
         mRes <- try $
           case server of
-            ServerInsecure auth -> runTCPClient auth $ \sock ->
+            ServerInsecure addr -> runTCPClient addr $ \sock ->
               bracket (HTTP2.Client.allocSimpleConfig sock writeBufferSize)
                       HTTP2.Client.freeSimpleConfig $ \conf ->
                 HTTP2.Client.run
-                      (clientConfig auth Http)
+                      (clientConfig addr Http)
                       conf
                     $ \sendRequest _aux -> do
                   traceWith tracer $ ClientDebugConnectedInsecure
                   let conn = Session.ConnectionToServer sendRequest
                   atomically $ writeTVar connVar $ ConnectionReady connClosed conn
                   takeMVar connCanClose
-            ServerSecure validation sslKeyLog auth -> do
+            ServerSecure validation sslKeyLog addr -> do
               keyLogger <- Util.TLS.keyLogger sslKeyLog
               caStore   <- Util.TLS.validationCAStore validation
               let settings :: HTTP2.TLS.Client.Settings
@@ -442,9 +443,10 @@ stayConnected connParams server connVar connCanClose =
                       }
 
               HTTP2.TLS.Client.run
+                    (clientConfig addr Https)
                     settings
-                    (authorityHost auth)
-                    (fromIntegral $ authorityPort auth)
+                    (addressHost addr)
+                    (fromIntegral $ addressPort addr)
                   $ \sendRequest _aux -> do
                 traceWith tracer $ ClientDebugConnectedSecure
                 let conn = Session.ConnectionToServer sendRequest
@@ -482,9 +484,9 @@ stayConnected connParams server connVar connCanClose =
                 threadDelay $ round $ delay * 1_000_000
                 loop reconnectPolicy'
 
-    runTCPClient :: Authority -> (Socket -> IO a) -> IO a
+    runTCPClient :: Address -> (Socket -> IO a) -> IO a
     runTCPClient auth =
-        Run.runTCPClient (authorityHost auth) (show $ authorityPort auth)
+        Run.runTCPClient (addressHost auth) (show $ addressPort auth)
 
     -- See docs of 'confBufferSize', but importantly: "this value is announced
     -- via SETTINGS_MAX_FRAME_SIZE to the peer."
@@ -493,15 +495,24 @@ stayConnected connParams server connVar connCanClose =
     writeBufferSize :: HPACK.BufferSize
     writeBufferSize = 4096
 
-    -- TODO: This is currently only used for the HTTP case, not HTTPS
-    clientConfig :: Authority -> Scheme -> HTTP2.Client.ClientConfig
-    clientConfig auth scheme = HTTP2.Client.defaultClientConfig {
-          HTTP2.Client.scheme    = rawScheme serverPseudoHeaders
-        , HTTP2.Client.authority = rawAuthority serverPseudoHeaders
+    clientConfig :: Address -> Scheme -> HTTP2.Client.ClientConfig
+    clientConfig addr scheme =
+        ( case scheme of
+            Http  -> HTTP2.Client.defaultClientConfig
+            Https -> HTTP2.TLS.Client.defaultClientConfig
+                       HTTP2.TLS.Client.defaultSettings
+        ) {
+          HTTP2.Client.authority =
+            -- The spec mandates the use of UTF8
+            -- <https://www.rfc-editor.org/rfc/rfc3986#section-3.2.2>
+            BS.Strict.UTF8.fromString $
+              case addressAuthority addr of
+                -- We omit the port number in the authority, for compatibility
+                -- with TLS SNI as well as the gRPC spec (the HTTP2 spec says
+                -- the port number is optional in the authority).
+                Nothing   -> addressHost addr
+                Just auth -> auth
         }
-      where
-        serverPseudoHeaders :: RawServerHeaders
-        serverPseudoHeaders = buildServerHeaders $ ServerHeaders scheme auth
 
     tracer :: Tracer IO ClientDebugMsg
     tracer = connDebugTracer connParams
diff --git a/src/Network/GRPC/Server/Connection.hs b/src/Network/GRPC/Server/Connection.hs
@@ -85,13 +85,10 @@ path = resourcePath . connectionResource
 
 getResourceHeaders :: HTTP2.Request -> Either OutOfSpecError ResourceHeaders
 getResourceHeaders req =
-    -- TODO: We should not parse the full pseudo headers
-    case parsePseudoHeaders (rawPseudoHeaders req) of
-      Left (InvalidScheme    x) -> Left $ bad "invalid scheme"    x
-      Left (InvalidAuthority x) -> Left $ bad "invalid authority" x
-      Left (InvalidPath      x) -> Left $ bad "invalid path"      x
-      Left (InvalidMethod    x) -> Left $ httpMethodNotAllowed    x
-      Right hdrs                -> return hdrs
+    case parseResourceHeaders (rawResourceHeaders req) of
+      Left (InvalidPath   x) -> Left $ bad "invalid path"   x
+      Left (InvalidMethod x) -> Left $ httpMethodNotAllowed x
+      Right hdrs             -> return hdrs
   where
     bad :: Builder -> Strict.ByteString -> OutOfSpecError
     bad msg arg = httpBadRequest $ mconcat [
@@ -100,16 +97,10 @@ getResourceHeaders req =
         , Builder.byteString arg
         ]
 
-rawPseudoHeaders :: HTTP2.Request -> RawPseudoHeaders
-rawPseudoHeaders req = RawPseudoHeaders {
-      rawServerHeaders = RawServerHeaders {
-          rawScheme    = fromMaybe "" $ HTTP2.requestScheme    req
-        , rawAuthority = fromMaybe "" $ HTTP2.requestAuthority req
-        }
-    , rawResourceHeaders = RawResourceHeaders {
-          rawPath   = fromMaybe "" $ HTTP2.requestPath   req
-        , rawMethod = fromMaybe "" $ HTTP2.requestMethod req
-        }
+rawResourceHeaders :: HTTP2.Request -> RawResourceHeaders
+rawResourceHeaders req = RawResourceHeaders {
+      rawPath   = fromMaybe "" $ HTTP2.requestPath   req
+    , rawMethod = fromMaybe "" $ HTTP2.requestMethod req
     }
 
 {-------------------------------------------------------------------------------

diff --git a/src/Network/GRPC/Spec.hs b/src/Network/GRPC/Spec.hs
@@ -50,18 +50,15 @@ module Network.GRPC.Spec (
   , ServerHeaders(..)
   , ResourceHeaders(..)
   , Path(..)
-  , Authority(..)
+  , Address(..)
   , Scheme(..)
   , Method(..)
   , rpcPath
     -- ** Serialization
-  , RawPseudoHeaders(..)
-  , RawServerHeaders(..)
   , RawResourceHeaders(..)
-  , InvalidPseudoHeaders(..)
+  , InvalidResourceHeaders(..)
   , buildResourceHeaders
-  , buildServerHeaders
-  , parsePseudoHeaders
+  , parseResourceHeaders
     -- ** Headers
   , buildRequestHeaders
   , parseRequestHeaders