diff --git a/core/src/Network/GRPC/LowLevel/Client.hs b/core/src/Network/GRPC/LowLevel/Client.hs index c78e4255..4b05a7ed 100644 --- a/core/src/Network/GRPC/LowLevel/Client.hs +++ b/core/src/Network/GRPC/LowLevel/Client.hs @@ -62,11 +62,8 @@ data ClientConfig = ClientConfig {clientServerEndpoint :: Endpoint, -- channel on the client. Supplying an empty -- list will cause the channel to use gRPC's -- default options. - 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. + clientSSLConfig :: ClientSSLConfig, + -- 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 @@ -84,19 +81,18 @@ addMetadataCreds c (Just create) = do createChannel :: ClientConfig -> C.GrpcChannelArgs -> IO C.Channel createChannel ClientConfig{..} chanargs = case clientSSLConfig of - Nothing -> C.grpcInsecureChannelCreate e chanargs C.reserved - Just (ClientSSLConfig rootCertPath Nothing plugin) -> + (ClientSSLConfig rootCertPath Nothing plugin) -> do rootCert <- mapM B.readFile rootCertPath C.withChannelCredentials rootCert Nothing Nothing $ \creds -> do creds' <- addMetadataCreds creds plugin - C.secureChannelCreate creds' e chanargs C.reserved - Just (ClientSSLConfig x (Just (ClientSSLKeyCertPair y z)) plugin) -> + C.grpcChannelCreate e creds' chanargs + (ClientSSLConfig x (Just (ClientSSLKeyCertPair y z)) plugin) -> do rootCert <- mapM B.readFile x privKey <- Just <$> B.readFile y clientCert <- Just <$> B.readFile z C.withChannelCredentials rootCert privKey clientCert $ \creds -> do creds' <- addMetadataCreds creds plugin - C.secureChannelCreate creds' e chanargs C.reserved + C.grpcChannelCreate e creds' chanargs where (Endpoint e) = clientServerEndpoint createClient :: GRPC -> ClientConfig -> IO Client diff --git a/core/src/Network/GRPC/LowLevel/Server.hs b/core/src/Network/GRPC/LowLevel/Server.hs index fc718a4c..6b83d1a4 100644 --- a/core/src/Network/GRPC/LowLevel/Server.hs +++ b/core/src/Network/GRPC/LowLevel/Server.hs @@ -132,27 +132,23 @@ 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 :: Maybe ServerSSLConfig - -- ^ Server-side SSL configuration. If 'Nothing', the server will use an - -- insecure connection. + , sslConfig :: ServerSSLConfig + -- ^ Server-side SSL configuration. } serverEndpoint :: ServerConfig -> Endpoint serverEndpoint ServerConfig{..} = endpoint host port addPort :: C.Server -> ServerConfig -> IO Int -addPort server conf@ServerConfig{..} = - case sslConfig of - Nothing -> C.grpcServerAddInsecureHttp2Port 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.serverAddSecureHttp2Port server e creds +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 where e = unEndpoint $ serverEndpoint conf startServer :: GRPC -> ServerConfig -> IO Server diff --git a/core/src/Network/GRPC/Unsafe.chs b/core/src/Network/GRPC/Unsafe.chs index 8967537e..9823ecee 100644 --- a/core/src/Network/GRPC/Unsafe.chs +++ b/core/src/Network/GRPC/Unsafe.chs @@ -189,14 +189,6 @@ castPeek p = do useAsCString* `ByteString', useAsCString* `ByteString', `CTimeSpecPtr',unReserved `Reserved'} -> `Call'#} --- | Create a channel (on the client) to the server. The first argument is --- host and port, e.g. @"localhost:50051"@. The gRPC docs say that most clients --- are expected to pass a 'nullPtr' for the 'ChannelArgsPtr'. We currently don't --- expose any functions for creating channel args, since they are entirely --- undocumented. -{#fun grpc_insecure_channel_create as ^ - {useAsCString* `ByteString', `GrpcChannelArgs', unReserved `Reserved'} -> `Channel'#} - {#fun grpc_channel_register_call as ^ {`Channel', useAsCString* `ByteString',useAsCString* `ByteString',unReserved `Reserved'} -> `CallHandle' CallHandle#} @@ -258,9 +250,6 @@ getPeerPeek cstr = do {#fun grpc_server_register_completion_queue as ^ {`Server', `CompletionQueue', unReserved `Reserved'} -> `()'#} -{#fun grpc_server_add_insecure_http2_port as ^ - {`Server', useAsCString* `ByteString'} -> `Int'#} - -- | Starts a server. To shut down the server, call these in order: -- 'grpcServerShutdownAndNotify', 'grpcServerCancelAllCalls', -- 'grpcServerDestroy'. After these are done, shut down and destroy the server's diff --git a/core/src/Network/GRPC/Unsafe/Security.chs b/core/src/Network/GRPC/Unsafe/Security.chs index 7de77f18..16361394 100644 --- a/core/src/Network/GRPC/Unsafe/Security.chs +++ b/core/src/Network/GRPC/Unsafe/Security.chs @@ -252,11 +252,11 @@ withServerCredentials a b c d = bracket (sslServerCredentialsCreate a b c d) -- * Creating Secure Clients/Servers -{#fun server_add_secure_http2_port as ^ +{#fun grpc_server_add_http2_port as ^ {`Server',useAsCString* `ByteString', `ServerCredentials'} -> `Int'#} -{#fun secure_channel_create as ^ - {`ChannelCredentials',useAsCString* `ByteString', `GrpcChannelArgs', unReserved `Reserved'} +{#fun grpc_channel_create as ^ + {useAsCString* `ByteString', `ChannelCredentials', `GrpcChannelArgs'} -> `Channel'#} -- * Custom metadata processing -- server side diff --git a/core/tests/LowLevelTests.hs b/core/tests/LowLevelTests.hs index 516f5aed..e0e0702a 100644 --- a/core/tests/LowLevelTests.hs +++ b/core/tests/LowLevelTests.hs @@ -156,32 +156,19 @@ testPayload = return ("reply test", dummyMeta, StatusOk, "details string") r @?= Right () + testSSL :: TestTree testSSL = csTest' "request/response using SSL" client server where - clientConf = stdClientConf - {clientSSLConfig = Just (ClientSSLConfig - (Just "tests/ssl/localhost.crt") - Nothing - Nothing) - } - client = TestClient clientConf $ \c -> do + client = TestClient stdClientConf $ \c -> do rm <- clientRegisterMethodNormal c "/foo" clientRequest c rm 10 "hi" mempty >>= do checkReqRslt $ \NormalRequestResult{..} -> do rspCode @?= StatusOk rspBody @?= "reply test" - serverConf' = defServerConf - { sslConfig = Just (ServerSSLConfig - Nothing - "tests/ssl/localhost.key" - "tests/ssl/localhost.crt" - SslDontRequestClientCertificate - Nothing) - } - server = TestServer serverConf' $ \s -> do + server = TestServer defServerConf $ \s -> do r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{} body -> do body @?= "hi" return ("reply test", mempty, StatusOk, "") @@ -198,10 +185,10 @@ testServerAuthProcessorCancel = csTest' "request rejection by auth processor" client server where clientConf = stdClientConf - {clientSSLConfig = Just (ClientSSLConfig - (Just "tests/ssl/localhost.crt") - Nothing - Nothing) + {clientSSLConfig = ClientSSLConfig + (Just "tests/ssl/localhost.crt") + Nothing + Nothing } client = TestClient clientConf $ \c -> do rm <- clientRegisterMethodNormal c "/foo" @@ -220,12 +207,8 @@ testServerAuthProcessorCancel = return $ AuthProcessorResult mempty mempty status details serverConf' = defServerConf - { sslConfig = Just (ServerSSLConfig - Nothing - "tests/ssl/localhost.key" - "tests/ssl/localhost.crt" - SslDontRequestClientCertificate - serverProcessor) + { sslConfig = defServerSSLConf + { customMetadataProcessor = serverProcessor } } server = TestServer serverConf' $ \s -> do r <- U.serverHandleNormalCall s mempty $ \U.ServerCall{..} _body -> do @@ -249,10 +232,10 @@ testAuthMetadataTransfer = addedProp @?= Just (AuthProperty "foo1" "bar1") return $ ClientMetadataCreateResult [("foo","bar")] StatusOk "" clientConf = stdClientConf - {clientSSLConfig = Just (ClientSSLConfig - (Just "tests/ssl/localhost.crt") - Nothing - (Just plugin)) + {clientSSLConfig = ClientSSLConfig + (Just "tests/ssl/localhost.crt") + Nothing + (Just plugin) } client = TestClient clientConf $ \c -> do rm <- clientRegisterMethodNormal c "/foo" @@ -273,12 +256,12 @@ testAuthMetadataTransfer = return $ AuthProcessorResult mempty mempty StatusOk "" serverConf' = defServerConf - { sslConfig = Just (ServerSSLConfig - Nothing - "tests/ssl/localhost.key" - "tests/ssl/localhost.crt" - SslDontRequestClientCertificate - serverProcessor) + { sslConfig = 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 @@ -302,10 +285,10 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do clientPlugin _ = return $ ClientMetadataCreateResult [("foo","bar")] StatusOk "" clientConf = stdClientConf - {clientSSLConfig = Just (ClientSSLConfig - (Just "tests/ssl/localhost.crt") - Nothing - (Just clientPlugin)) + {clientSSLConfig = ClientSSLConfig + (Just "tests/ssl/localhost.crt") + Nothing + (Just clientPlugin) } client = do threadDelaySecs 3 @@ -322,12 +305,12 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do return $ AuthProcessorResult mempty mempty StatusOk "" server1ServerConf = defServerConf - {sslConfig = Just (ServerSSLConfig - Nothing - "tests/ssl/localhost.key" - "tests/ssl/localhost.crt" - SslDontRequestClientCertificate - (Just server1ServerPlugin)), + {sslConfig = ServerSSLConfig + Nothing + "tests/ssl/localhost.key" + "tests/ssl/localhost.crt" + SslDontRequestClientCertificate + (Just server1ServerPlugin), methodsToRegisterNormal = ["/foo"] } @@ -335,10 +318,10 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do return $ ClientMetadataCreateResult [("foo1","bar1")] StatusOk "" server1ClientConf = stdClientConf - {clientSSLConfig = Just (ClientSSLConfig - (Just "tests/ssl/localhost.crt") - Nothing - (Just server1ClientPlugin)), + {clientSSLConfig = ClientSSLConfig + (Just "tests/ssl/localhost.crt") + Nothing + (Just server1ClientPlugin), clientServerEndpoint = "localhost:50052" } @@ -364,12 +347,12 @@ testAuthMetadataPropagate = testCase "auth metadata inherited by children" $ do return $ AuthProcessorResult mempty mempty StatusOk "" server2ServerConf = defServerConf - {sslConfig = Just (ServerSSLConfig - Nothing - "tests/ssl/localhost.key" - "tests/ssl/localhost.crt" - SslDontRequestClientCertificate - (Just server2ServerPlugin)), + {sslConfig = ServerSSLConfig + Nothing + "tests/ssl/localhost.key" + "tests/ssl/localhost.crt" + SslDontRequestClientCertificate + (Just server2ServerPlugin), methodsToRegisterNormal = ["/foo"], port = 50052 } @@ -673,7 +656,7 @@ testCustomUserAgent = where clientArgs = [UserAgentPrefix "prefix!", UserAgentSuffix "suffix!"] client = - TestClient (ClientConfig "localhost:50051" clientArgs Nothing Nothing) $ + TestClient (ClientConfig "localhost:50051" clientArgs defClientSSLConf Nothing) $ \c -> do rm <- clientRegisterMethodNormal c "/foo" void $ clientRequest c rm 4 "" mempty server = TestServer (serverConf (["/foo"],[],[],[])) $ \s -> do @@ -696,7 +679,7 @@ testClientCompression = TestClient (ClientConfig "localhost:50051" [CompressionAlgArg GrpcCompressDeflate] - Nothing + defClientSSLConf Nothing) $ \c -> do rm <- clientRegisterMethodNormal c "/foo" void $ clientRequest c rm 1 "hello" mempty @@ -713,7 +696,7 @@ testClientServerCompression = where cconf = ClientConfig "localhost:50051" [CompressionAlgArg GrpcCompressDeflate] - Nothing + defClientSSLConf Nothing client = TestClient cconf $ \c -> do rm <- clientRegisterMethodNormal c "/foo" @@ -729,7 +712,7 @@ testClientServerCompression = 50051 ["/foo"] [] [] [] [CompressionAlgArg GrpcCompressDeflate] - Nothing + defServerSSLConf server = TestServer sconf $ \s -> do let rm = head (normalMethods s) serverHandleNormalCall s rm dummyMeta $ \sc -> do @@ -743,7 +726,7 @@ testClientServerCompressionLvl = where cconf = ClientConfig "localhost:50051" [CompressionLevelArg GrpcCompressLevelHigh] - Nothing + defClientSSLConf Nothing client = TestClient cconf $ \c -> do rm <- clientRegisterMethodNormal c "/foo" @@ -759,7 +742,7 @@ testClientServerCompressionLvl = 50051 ["/foo"] [] [] [] [CompressionLevelArg GrpcCompressLevelLow] - Nothing + defServerSSLConf server = TestServer sconf $ \s -> do let rm = head (normalMethods s) serverHandleNormalCall s rm dummyMeta $ \sc -> do @@ -776,7 +759,7 @@ testClientMaxReceiveMessageLengthChannelArg = do where -- The server always sends a 4-byte payload pay = "four" - server = TestServer (ServerConfig "localhost" 50051 ["/foo"] [] [] [] [] Nothing) $ \s -> do + server = TestServer (ServerConfig "localhost" 50051 ["/foo"] [] [] [] [] defServerSSLConf) $ \s -> do let rm = head (normalMethods s) void $ serverHandleNormalCall s rm mempty $ \sc -> do payload sc @?= pay @@ -786,7 +769,7 @@ testClientMaxReceiveMessageLengthChannelArg = do rm <- clientRegisterMethodNormal c "/foo" clientRequest c rm 1 pay mempty >>= k where - conf = ClientConfig "localhost:50051" [MaxReceiveMessageLength n] Nothing Nothing + conf = ClientConfig "localhost:50051" [MaxReceiveMessageLength n] defClientSSLConf Nothing -- Expect success when the max recv payload size is set to 4 bytes, and we -- are sent 4. @@ -884,7 +867,10 @@ stdTestClient :: (Client -> IO ()) -> TestClient stdTestClient = TestClient stdClientConf stdClientConf :: ClientConfig -stdClientConf = ClientConfig "localhost:50051" [] Nothing Nothing +stdClientConf = ClientConfig "localhost:50051" [] defClientSSLConf Nothing + +defClientSSLConf :: ClientSSLConfig +defClientSSLConf = ClientSSLConfig (Just "tests/ssl/localhost.crt") Nothing Nothing data TestServer = TestServer ServerConfig (Server -> IO ()) @@ -893,7 +879,10 @@ runTestServer (TestServer conf f) = runManaged $ mgdGRPC >>= mgdServer conf >>= liftIO . f defServerConf :: ServerConfig -defServerConf = ServerConfig "localhost" 50051 [] [] [] [] [] Nothing +defServerConf = ServerConfig "localhost" 50051 [] [] [] [] [] defServerSSLConf + +defServerSSLConf :: ServerSSLConfig +defServerSSLConf = ServerSSLConfig Nothing "tests/ssl/localhost.key" "tests/ssl/localhost.crt" SslDontRequestClientCertificate Nothing serverConf :: ([MethodName],[MethodName],[MethodName],[MethodName]) -> ServerConfig diff --git a/core/tests/LowLevelTests/Op.hs b/core/tests/LowLevelTests/Op.hs index 09b42f4d..0c86a8b6 100644 --- a/core/tests/LowLevelTests/Op.hs +++ b/core/tests/LowLevelTests/Op.hs @@ -76,10 +76,17 @@ withClientServerUnaryCall grpc f = do f (c, s, cc, sc) serverConf :: ServerConfig -serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] Nothing +serverConf = ServerConfig "localhost" 50051 [("/foo")] [] [] [] [] serverSSLConf + +serverSSLConf :: ServerSSLConfig +serverSSLConf = ServerSSLConfig Nothing "tests/ssl/localhost.key" "tests/ssl/localhost.crt" SslDontRequestClientCertificate Nothing + clientConf :: ClientConfig -clientConf = ClientConfig "localhost:50051" [] Nothing Nothing +clientConf = ClientConfig "localhost:50051" [] clientSSLConf Nothing + +clientSSLConf :: ClientSSLConfig +clientSSLConf = ClientSSLConfig (Just "tests/ssl/localhost.crt") Nothing Nothing clientEmptySendOps :: [Op] clientEmptySendOps = diff --git a/src/Network/GRPC/HighLevel/Server.hs b/src/Network/GRPC/HighLevel/Server.hs index 480efb6a..adec5e55 100644 --- a/src/Network/GRPC/HighLevel/Server.hs +++ b/src/Network/GRPC/HighLevel/Server.hs @@ -222,7 +222,7 @@ data ServerOptions = ServerOptions -- ^ Optional custom suffix to add to the user agent string. , optInitialMetadata :: MetadataMap -- ^ Metadata to send at the beginning of each call. - , optSSLConfig :: Maybe ServerSSLConfig + , optSSLConfig :: ServerSSLConfig -- ^ Security configuration. , optLogger :: String -> IO () -- ^ Logging function to use to log errors in handling calls.