Do not make secure connections mandatory

Instead of making secure connections mandatory, use insecure credentials to keep existing API unchanged.
awakesecurity · Nov 8, 2023 · fe3f50f · fe3f50f
1 parent f4c6a3c
commit fe3f50f
Show file tree

Hide file tree

Showing 6 changed files with 104 additions and 80 deletions.
diff --git a/core/src/Network/GRPC/LowLevel/Client.hs b/core/src/Network/GRPC/LowLevel/Client.hs
@@ -62,8 +62,11 @@ data ClientConfig = ClientConfig {clientServerEndpoint :: Endpoint,
                                   -- channel on the client. Supplying an empty
                                   -- list will cause the channel to use gRPC's
                                   -- default options.
-                                  clientSSLConfig :: ClientSSLConfig,
-                                  -- Use the supplied config to connect using SSL.
+                                  clientSSLConfig :: Maybe ClientSSLConfig,
+                                  -- ^ If 'Nothing', the client will use an
+                                  -- insecure connection to the server.
+                                  -- Otherwise, will use the supplied config to
+                                  -- connect using SSL.
                                   clientAuthority :: Maybe ByteString
                                   -- ^ If 'Nothing', the :authority pseudo-header will
                                   -- be the endpoint host. Otherwise, the :authority
@@ -81,12 +84,15 @@ addMetadataCreds c (Just create) = do
 createChannel :: ClientConfig -> C.GrpcChannelArgs -> IO C.Channel
 createChannel ClientConfig{..} chanargs =
   case clientSSLConfig of
-    (ClientSSLConfig rootCertPath Nothing plugin) ->
+    Nothing ->
+      C.withInsecureChannelCredentials $ \creds ->
+        C.grpcChannelCreate e creds chanargs
+    Just (ClientSSLConfig rootCertPath Nothing plugin) ->
       do rootCert <- mapM B.readFile rootCertPath
          C.withChannelCredentials rootCert Nothing Nothing $ \creds -> do
            creds' <- addMetadataCreds creds plugin
            C.grpcChannelCreate e creds' chanargs
-    (ClientSSLConfig x (Just (ClientSSLKeyCertPair y z)) plugin) ->
+    Just (ClientSSLConfig x (Just (ClientSSLKeyCertPair y z)) plugin) ->
       do rootCert <- mapM B.readFile x
          privKey <- Just <$> B.readFile y
          clientCert <- Just <$> B.readFile z

diff --git a/core/src/Network/GRPC/LowLevel/Server.hs b/core/src/Network/GRPC/LowLevel/Server.hs
@@ -132,23 +132,27 @@ data ServerConfig = ServerConfig
   , serverArgs        :: [C.Arg]
   -- ^ Optional arguments for setting up the channel on the server. Supplying an
   -- empty list will cause the channel to use gRPC's default options.
-  , sslConfig :: ServerSSLConfig
-  -- ^ Server-side SSL configuration.
+  , sslConfig :: Maybe ServerSSLConfig
+  -- ^ Server-side SSL configuration. If 'Nothing', the server will use an
+  -- insecure connection.
   }
 
 serverEndpoint :: ServerConfig -> Endpoint
 serverEndpoint ServerConfig{..} = endpoint host port
 
 addPort :: C.Server -> ServerConfig -> IO Int
-addPort server conf@ServerConfig{sslConfig=ServerSSLConfig{..}} = do
-  crc <- mapM B.readFile clientRootCert
-  spk <- B.readFile serverPrivateKey
-  sc <- B.readFile serverCert
-  C.withServerCredentials crc spk sc clientCertRequest $ \creds -> do
-    case customMetadataProcessor of
-      Just p -> C.setMetadataProcessor creds p
-      Nothing -> return ()
-    C.grpcServerAddHttp2Port server e creds
+addPort server conf@ServerConfig{..} =
+  case sslConfig of
+    Nothing -> C.withInsecureServerCredentials $ C.grpcServerAddHttp2Port server e
+    Just ServerSSLConfig{..} ->
+      do crc <- mapM B.readFile clientRootCert
+         spk <- B.readFile serverPrivateKey
+         sc <- B.readFile serverCert
+         C.withServerCredentials crc spk sc clientCertRequest $ \creds -> do
+           case customMetadataProcessor of
+             Just p -> C.setMetadataProcessor creds p
+             Nothing -> return ()
+           C.grpcServerAddHttp2Port server e creds
   where e = unEndpoint $ serverEndpoint conf
 
 startServer :: GRPC -> ServerConfig -> IO Server

diff --git a/core/src/Network/GRPC/Unsafe/Security.chs b/core/src/Network/GRPC/Unsafe/Security.chs
@@ -169,6 +169,8 @@ getAuthProperties ctx = withAuthPropertyIterator ctx $ \i -> do
 {#fun unsafe ssl_credentials_create_internal as ^
   {`CString', `CString', `CString'} -> `ChannelCredentials'#}
 
+{#fun insecure_credentials_create as ^ {} -> `ChannelCredentials'#}
+
 sslChannelCredentialsCreate :: Maybe ByteString
                                -> Maybe ByteString
                                -> Maybe ByteString
@@ -195,6 +197,9 @@ withChannelCredentials :: Maybe ByteString
 withChannelCredentials x y z = bracket (sslChannelCredentialsCreate x y z)
                                        channelCredentialsRelease
 
+withInsecureChannelCredentials :: (ChannelCredentials -> IO a) -> IO a
+withInsecureChannelCredentials = bracket insecureCredentialsCreate channelCredentialsRelease
+
 -- * Call Credentials
 
 {#fun call_set_credentials as ^
@@ -219,6 +224,8 @@ withChannelCredentials x y z = bracket (sslChannelCredentialsCreate x y z)
    `SslClientCertificateRequestType'}
   -> `ServerCredentials'#}
 
+{#fun insecure_server_credentials_create as ^ {} -> `ServerCredentials'#}
+
 sslServerCredentialsCreate :: Maybe ByteString
                               -- ^ PEM encoding of the client root certificates.
                               -- Can be 'Nothing' if SSL authentication of
@@ -259,6 +266,9 @@ withServerCredentials a b c d = bracket (sslServerCredentialsCreate a b c d)
   {useAsCString* `ByteString', `ChannelCredentials', `GrpcChannelArgs'}
   -> `Channel'#}
 
+withInsecureServerCredentials :: (ServerCredentials -> IO a) -> IO a
+withInsecureServerCredentials = bracket insecureServerCredentialsCreate serverCredentialsRelease
+
 -- * Custom metadata processing -- server side
 
 -- | Type synonym for the raw function pointer we pass to C to handle custom

diff --git a/core/tests/LowLevelTests.hs b/core/tests/LowLevelTests.hs
@@ -156,19 +156,32 @@ testPayload =
         return ("reply test", dummyMeta, StatusOk, "details string")
       r @?= Right ()
 
-
 testSSL :: TestTree
 testSSL =
   csTest' "request/response using SSL" client server
   where
-    client = TestClient stdClientConf $ \c -> do
+    clientConf = stdClientConf
+                 {clientSSLConfig = Just (ClientSSLConfig
+                                            (Just "tests/ssl/localhost.crt")
+                                            Nothing
+                                            Nothing)
+                }
+    client = TestClient clientConf $ \c -> do
       rm <- clientRegisterMethodNormal c "/foo"
       clientRequest c rm 10 "hi" mempty >>= do
         checkReqRslt $ \NormalRequestResult{..} -> do
           rspCode @?= StatusOk
           rspBody @?= "reply test"
 
-    server = TestServer defServerConf $ \s -> do
+    serverConf' = defServerConf
+                  { sslConfig = Just (ServerSSLConfig
+                                        Nothing
+                                        "tests/ssl/localhost.key"
+                                        "tests/ssl/localhost.crt"
+                                        SslDontRequestClientCertificate
+                                        Nothing)
+                  }
+    server = TestServer serverConf' $ \s -> do
       r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{} body -> do
         body @?= "hi"
         return ("reply test", mempty, StatusOk, "")
@@ -185,10 +198,10 @@ testServerAuthProcessorCancel =
   csTest' "request rejection by auth processor" client server
   where
     clientConf = stdClientConf
-                 {clientSSLConfig = ClientSSLConfig
-                                      (Just "tests/ssl/localhost.crt")
-                                      Nothing
-                                      Nothing
+                 {clientSSLConfig = Just (ClientSSLConfig
+                                            (Just "tests/ssl/localhost.crt")
+                                            Nothing
+                                            Nothing)
                 }
     client = TestClient clientConf $ \c -> do
       rm <- clientRegisterMethodNormal c "/foo"
@@ -207,8 +220,12 @@ testServerAuthProcessorCancel =
       return $ AuthProcessorResult mempty mempty status details
 
     serverConf' = defServerConf
-                  { sslConfig = defServerSSLConf
-                    { customMetadataProcessor = serverProcessor }
+                  { sslConfig = Just (ServerSSLConfig
+                                        Nothing
+                                        "tests/ssl/localhost.key"
+                                        "tests/ssl/localhost.crt"
+                                        SslDontRequestClientCertificate
+                                        serverProcessor)
                   }
     server = TestServer serverConf' $ \s -> do
       r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} _body -> do
@@ -232,10 +249,10 @@ testAuthMetadataTransfer =
       addedProp @?= Just (AuthProperty "foo1" "bar1")
       return $ ClientMetadataCreateResult [("foo","bar")] StatusOk ""
     clientConf = stdClientConf
-                 {clientSSLConfig = ClientSSLConfig
-                                       (Just "tests/ssl/localhost.crt")
-                                       Nothing
-                                       (Just plugin)
+                 {clientSSLConfig = Just (ClientSSLConfig
+                                            (Just "tests/ssl/localhost.crt")
+                                            Nothing
+                                            (Just plugin))
                 }
     client = TestClient clientConf $ \c -> do
       rm <- clientRegisterMethodNormal c "/foo"
@@ -256,12 +273,12 @@ testAuthMetadataTransfer =
       return $ AuthProcessorResult mempty mempty StatusOk ""
 
     serverConf' = defServerConf
-                  { sslConfig = ServerSSLConfig
-                                  Nothing
-                                  "tests/ssl/localhost.key"
-                                  "tests/ssl/localhost.crt"
-                                  SslDontRequestClientCertificate
-                                  serverProcessor
+                  { sslConfig = Just (ServerSSLConfig
+                                        Nothing
+                                        "tests/ssl/localhost.key"
+                                        "tests/ssl/localhost.crt"
+                                        SslDontRequestClientCertificate
+                                        serverProcessor)
                   }
     server = TestServer serverConf' $ \s -> do
       r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{} body -> do
@@ -285,10 +302,10 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do
     clientPlugin _ =
       return $ ClientMetadataCreateResult [("foo","bar")] StatusOk ""
     clientConf = stdClientConf
-                 {clientSSLConfig = ClientSSLConfig
-                                      (Just "tests/ssl/localhost.crt")
-                                      Nothing
-                                      (Just clientPlugin)
+                 {clientSSLConfig = Just (ClientSSLConfig
+                                            (Just "tests/ssl/localhost.crt")
+                                            Nothing
+                                            (Just clientPlugin))
                 }
     client = do
       threadDelaySecs 3
@@ -305,23 +322,23 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do
       return $ AuthProcessorResult mempty mempty StatusOk ""
 
     server1ServerConf = defServerConf
-                 {sslConfig = ServerSSLConfig
-                                Nothing
-                                "tests/ssl/localhost.key"
-                                "tests/ssl/localhost.crt"
-                                SslDontRequestClientCertificate
-                                (Just server1ServerPlugin),
+                 {sslConfig = Just (ServerSSLConfig
+                                      Nothing
+                                      "tests/ssl/localhost.key"
+                                      "tests/ssl/localhost.crt"
+                                      SslDontRequestClientCertificate
+                                      (Just server1ServerPlugin)),
                   methodsToRegisterNormal = ["/foo"]
                 }
 
     server1ClientPlugin _ =
       return $ ClientMetadataCreateResult [("foo1","bar1")] StatusOk ""
 
     server1ClientConf = stdClientConf
-                 {clientSSLConfig = ClientSSLConfig
-                                       (Just "tests/ssl/localhost.crt")
-                                       Nothing
-                                       (Just server1ClientPlugin),
+                 {clientSSLConfig = Just (ClientSSLConfig
+                                            (Just "tests/ssl/localhost.crt")
+                                            Nothing
+                                            (Just server1ClientPlugin)),
                   clientServerEndpoint = "localhost:50052"
                 }
 
@@ -347,12 +364,12 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do
       return $ AuthProcessorResult mempty mempty StatusOk ""
 
     server2ServerConf = defServerConf
-                 {sslConfig = ServerSSLConfig
-                                Nothing
-                                "tests/ssl/localhost.key"
-                                "tests/ssl/localhost.crt"
-                                SslDontRequestClientCertificate
-                                (Just server2ServerPlugin),
+                 {sslConfig = Just (ServerSSLConfig
+                                      Nothing
+                                      "tests/ssl/localhost.key"
+                                      "tests/ssl/localhost.crt"
+                                      SslDontRequestClientCertificate
+                                      (Just server2ServerPlugin)),
                   methodsToRegisterNormal = ["/foo"],
                   port = 50052
                 }
@@ -656,7 +673,7 @@ testCustomUserAgent =
   where
     clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"]
     client =
-      TestClient (ClientConfig "localhost:50051" clientArgs defClientSSLConf Nothing) $
+      TestClient (ClientConfig "localhost:50051" clientArgs Nothing Nothing) $
         \c -> do rm <- clientRegisterMethodNormal c "/foo"
                  void $ clientRequest c rm 4 "" mempty
     server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do
@@ -679,7 +696,7 @@ testClientCompression =
       TestClient (ClientConfig
                    "localhost:50051"
                    [CompressionAlgArg GrpcCompressDeflate]
-                   defClientSSLConf
+                   Nothing
                    Nothing) $ \c -> do
         rm <- clientRegisterMethodNormal c "/foo"
         void $ clientRequest c rm 1 "hello" mempty
@@ -696,7 +713,7 @@ testClientServerCompression =
   where
     cconf = ClientConfig "localhost:50051"
                          [CompressionAlgArg GrpcCompressDeflate]
-                         defClientSSLConf
+                         Nothing
                          Nothing
     client = TestClient cconf $ \c -> do
       rm <- clientRegisterMethodNormal c "/foo"
@@ -712,7 +729,7 @@ testClientServerCompression =
                          50051
                          ["/foo"] [] [] []
                          [CompressionAlgArg GrpcCompressDeflate]
-                         defServerSSLConf
+                         Nothing
     server = TestServer sconf $ \s -> do
       let rm = head (normalMethods s)
       serverHandleNormalCall s rm dummyMeta $ \sc -> do
@@ -726,7 +743,7 @@ testClientServerCompressionLvl =
   where
     cconf = ClientConfig "localhost:50051"
                          [CompressionLevelArg GrpcCompressLevelHigh]
-                         defClientSSLConf
+                         Nothing
                          Nothing
     client = TestClient cconf $ \c -> do
       rm <- clientRegisterMethodNormal c "/foo"
@@ -742,7 +759,7 @@ testClientServerCompressionLvl =
                          50051
                          ["/foo"] [] [] []
                          [CompressionLevelArg GrpcCompressLevelLow]
-                         defServerSSLConf
+                         Nothing
     server = TestServer sconf $ \s -> do
       let rm = head (normalMethods s)
       serverHandleNormalCall s rm dummyMeta $ \sc -> do
@@ -759,7 +776,7 @@ testClientMaxReceiveMessageLengthChannelArg = do
   where
     -- The server always sends a 4-byte payload
     pay    = "four"
-    server = TestServer (ServerConfig "localhost" 50051 ["/foo"] [] [] [] [] defServerSSLConf) $ \s -> do
+    server = TestServer (ServerConfig "localhost" 50051 ["/foo"] [] [] [] [] Nothing) $ \s -> do
       let rm = head (normalMethods s)
       void $ serverHandleNormalCall s rm mempty $ \sc -> do
         payload sc @?= pay
@@ -769,7 +786,7 @@ testClientMaxReceiveMessageLengthChannelArg = do
       rm <- clientRegisterMethodNormal c "/foo"
       clientRequest c rm 1 pay mempty >>= k
       where
-        conf = ClientConfig "localhost:50051" [MaxReceiveMessageLength n] defClientSSLConf Nothing
+        conf = ClientConfig "localhost:50051" [MaxReceiveMessageLength n] Nothing Nothing
 
     -- Expect success when the max recv payload size is set to 4 bytes, and we
     -- are sent 4.
@@ -867,10 +884,7 @@ stdTestClient :: (Client -> IO ()) -> TestClient
 stdTestClient = TestClient stdClientConf
 
 stdClientConf :: ClientConfig
-stdClientConf = ClientConfig "localhost:50051" [] defClientSSLConf Nothing
-
-defClientSSLConf :: ClientSSLConfig
-defClientSSLConf = ClientSSLConfig (Just "tests/ssl/localhost.crt") Nothing Nothing
+stdClientConf = ClientConfig "localhost:50051" [] Nothing Nothing
 
 data TestServer = TestServer ServerConfig (Server -> IO ())
 
@@ -879,10 +893,7 @@ runTestServer (TestServer conf f) =
   runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f
 
 defServerConf :: ServerConfig
-defServerConf = ServerConfig "localhost" 50051 [] [] [] [] [] defServerSSLConf
-
-defServerSSLConf :: ServerSSLConfig
-defServerSSLConf = ServerSSLConfig Nothing "tests/ssl/localhost.key" "tests/ssl/localhost.crt" SslDontRequestClientCertificate Nothing
+defServerConf = ServerConfig "localhost" 50051 [] [] [] [] [] Nothing
 
 serverConf :: ([MethodName],[MethodName],[MethodName],[MethodName])
               -> ServerConfig

diff --git a/core/tests/LowLevelTests/Op.hs b/core/tests/LowLevelTests/Op.hs
@@ -76,17 +76,10 @@ withClientServerUnaryCall grpc f = do
           f (c, s, cc, sc)
 
 serverConf :: ServerConfig
-serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] serverSSLConf
-
-serverSSLConf :: ServerSSLConfig
-serverSSLConf = ServerSSLConfig Nothing "tests/ssl/localhost.key" "tests/ssl/localhost.crt" SslDontRequestClientCertificate Nothing
-
+serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] Nothing
 
 clientConf :: ClientConfig
-clientConf = ClientConfig "localhost:50051" [] clientSSLConf Nothing
-
-clientSSLConf :: ClientSSLConfig
-clientSSLConf = ClientSSLConfig (Just "tests/ssl/localhost.crt") Nothing Nothing
+clientConf = ClientConfig "localhost:50051" [] Nothing Nothing
 
 clientEmptySendOps :: [Op]
 clientEmptySendOps =