Skip to content

Commit

Permalink
cbits: Adjust to removal of insecure build.
Browse files Browse the repository at this point in the history 
See grpc/grpc#25586
  • Loading branch information
@jsoo1
jsoo1 committed Nov 8, 2023
1 parent e1e3292 commit f4c6a3c
Show file tree
Hide file tree
Showing 7 changed files with 85 additions and 108 deletions.
16 changes: 6 additions & 10 deletions core/src/Network/GRPC/LowLevel/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down
26 changes: 11 additions & 15 deletions core/src/Network/GRPC/LowLevel/Server.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
11 changes: 0 additions & 11 deletions core/src/Network/GRPC/Unsafe.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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#}
Expand Down Expand Up @@ -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
Expand Down
6 changes: 3 additions & 3 deletions core/src/Network/GRPC/Unsafe/Security.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
121 changes: 55 additions & 66 deletions core/tests/LowLevelTests.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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, "")
Expand All @@ -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"
Expand All @@ -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
Expand All @@ -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"
Expand All @@ -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
Expand All @@ -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
Expand All @@ -322,23 +305,23 @@ 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"]
}

server1ClientPlugin _ =
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"
}

Expand All @@ -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
}
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -713,7 +696,7 @@ testClientServerCompression =
where
cconf = ClientConfig "localhost:50051"
[CompressionAlgArg GrpcCompressDeflate]
Nothing
defClientSSLConf
Nothing
client = TestClient cconf $ \c -> do
rm <- clientRegisterMethodNormal c "/foo"
Expand All @@ -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
Expand All @@ -743,7 +726,7 @@ testClientServerCompressionLvl =
where
cconf = ClientConfig "localhost:50051"
[CompressionLevelArg GrpcCompressLevelHigh]
Nothing
defClientSSLConf
Nothing
client = TestClient cconf $ \c -> do
rm <- clientRegisterMethodNormal c "/foo"
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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.
Expand Down Expand Up @@ -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 ())

Expand All @@ -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
Expand Down
Loading

0 comments on commit f4c6a3c

Please sign in to comment.