mirror of
https://github.com/unclechu/gRPC-haskell.git
synced 2024-06-29 07:58:35 +02:00
399 lines
15 KiB
Plaintext
399 lines
15 KiB
Plaintext
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Network.GRPC.Unsafe.Security where
|
|
|
|
import Control.Exception (bracket)
|
|
import Data.ByteString (ByteString, useAsCString, packCString, packCStringLen)
|
|
import Data.Coerce (coerce)
|
|
import Foreign.C.String (CString)
|
|
import Foreign.C.Types
|
|
import Foreign.Storable
|
|
import Foreign.Marshal.Alloc (free)
|
|
import Foreign.Ptr (nullPtr, FunPtr, Ptr, castPtr)
|
|
|
|
#include <grpc/grpc.h>
|
|
#include <grpc/grpc_security.h>
|
|
#include <grpc_haskell.h>
|
|
|
|
{#import Network.GRPC.Unsafe#}
|
|
{#import Network.GRPC.Unsafe.ChannelArgs#}
|
|
{#import Network.GRPC.Unsafe.Metadata#}
|
|
{#import Network.GRPC.Unsafe.Op#}
|
|
|
|
{#context prefix = "grpc_"#}
|
|
|
|
-- * Types
|
|
|
|
-- | Context for auth. This is essentially just a set of key-value pairs that
|
|
-- can be mutated.
|
|
-- Note: it appears that any keys set or modified on this object do not
|
|
-- appear in the AuthContext of the peer, so you must send along auth info
|
|
-- in the metadata. It's currently unclear to us what
|
|
-- the purpose of modifying this is, but we offer the ability for the sake of
|
|
-- completeness.
|
|
{#pointer *auth_context as ^ newtype#}
|
|
|
|
deriving instance Show AuthContext
|
|
|
|
instance Storable AuthContext where
|
|
sizeOf (AuthContext p) = sizeOf p
|
|
alignment (AuthContext p) = alignment p
|
|
peek p = AuthContext <$> peek (castPtr p)
|
|
poke p (AuthContext r) = poke (castPtr p) r
|
|
|
|
{#pointer *auth_property_iterator as ^ newtype#}
|
|
|
|
{#pointer *call_credentials as ^ newtype#}
|
|
|
|
{#pointer *channel_credentials as ^ newtype#}
|
|
|
|
{#pointer *server_credentials as ^ newtype#}
|
|
|
|
withAuthPropertyIterator :: AuthContext
|
|
-> (AuthPropertyIterator -> IO a)
|
|
-> IO a
|
|
withAuthPropertyIterator ctx = bracket (authContextPropertyIterator ctx)
|
|
(free . coerce)
|
|
|
|
-- | Represents one key/value pair in an 'AuthContext'.
|
|
data AuthProperty = AuthProperty
|
|
{authPropName :: ByteString,
|
|
authPropValue :: ByteString}
|
|
deriving (Show, Eq)
|
|
|
|
marshalAuthProperty :: Ptr AuthProperty -> IO AuthProperty
|
|
marshalAuthProperty p = do
|
|
n <- packCString =<< ({# get auth_property->name #} p)
|
|
vl <- fromIntegral <$> {# get auth_property->value_length #} p
|
|
v <- packCStringLen . (,vl) =<< {#get auth_property->value #} p
|
|
return $ AuthProperty n v
|
|
|
|
-- | The context which a client-side auth metadata plugin sees when it runs.
|
|
data AuthMetadataContext = AuthMetadataContext
|
|
{serviceURL :: ByteString,
|
|
-- ^ The URL of the service the current call is going to.
|
|
methodName :: ByteString,
|
|
-- ^ The method that is being invoked with the current call. It appears that
|
|
-- the gRPC 0.15 core is not populating this correctly, because it's an empty
|
|
-- string in my tests so far.
|
|
channelAuthContext :: AuthContext
|
|
}
|
|
deriving Show
|
|
|
|
authMetadataContextMarshal :: Ptr AuthMetadataContext -> IO AuthMetadataContext
|
|
authMetadataContextMarshal p =
|
|
AuthMetadataContext
|
|
<$> (({#get auth_metadata_context->service_url #} p) >>= packCString)
|
|
<*> (({#get auth_metadata_context->method_name #} p) >>= packCString)
|
|
<*> ({#get auth_metadata_context->channel_auth_context#} p)
|
|
|
|
{#pointer *metadata_credentials_plugin as ^ newtype#}
|
|
|
|
{#pointer *auth_metadata_processor as ^ newtype#}
|
|
|
|
{#enum ssl_client_certificate_request_type as ^ {underscoreToCase}
|
|
deriving (Eq, Ord, Bounded, Show)#}
|
|
|
|
-- * Auth Contexts
|
|
|
|
-- | If used, the 'AuthContext' must be released with 'AuthContextRelease'.
|
|
{#fun unsafe call_auth_context as ^
|
|
{`Call'} -> `AuthContext'#}
|
|
|
|
{#fun unsafe auth_context_release as ^
|
|
{`AuthContext'} -> `()'#}
|
|
|
|
{#fun unsafe auth_context_add_cstring_property as addAuthProperty'
|
|
{`AuthContext',
|
|
useAsCString* `ByteString',
|
|
useAsCString* `ByteString'}
|
|
-> `()'#}
|
|
|
|
-- | Adds a new property to the given 'AuthContext'.
|
|
addAuthProperty :: AuthContext -> AuthProperty -> IO ()
|
|
addAuthProperty ctx prop =
|
|
addAuthProperty' ctx (authPropName prop) (authPropValue prop)
|
|
|
|
{-
|
|
TODO: The functions for getting and setting peer identities cause
|
|
unpredictable crashes when used in conjunction with other, more general
|
|
auth property getter/setter functions. If we end needing these, we should
|
|
investigate further.
|
|
|
|
coercePack :: Ptr a -> IO ByteString
|
|
coercePack = packCString . coerce
|
|
|
|
{#fun unsafe grpc_auth_context_peer_identity_property_name
|
|
as getPeerIdentityPropertyName
|
|
{`AuthContext'} -> `ByteString' coercePack* #}
|
|
|
|
{#fun unsafe auth_context_set_peer_identity_property_name
|
|
as setPeerIdentity
|
|
{`AuthContext', useAsCString* `ByteString'} -> `()'#}
|
|
|
|
{#fun unsafe auth_context_peer_identity as getPeerIdentity
|
|
{`AuthContext'} -> `ByteString' coercePack* #}
|
|
-}
|
|
-- * Property Iteration
|
|
|
|
{#fun unsafe auth_context_property_iterator_ as ^
|
|
{`AuthContext'} -> `AuthPropertyIterator'#}
|
|
|
|
{#fun unsafe auth_property_iterator_next as ^
|
|
{`AuthPropertyIterator'} -> `Ptr AuthProperty' coerce#}
|
|
|
|
getAuthProperties :: AuthContext -> IO [AuthProperty]
|
|
getAuthProperties ctx = withAuthPropertyIterator ctx $ \i -> do
|
|
go i
|
|
where go :: AuthPropertyIterator -> IO [AuthProperty]
|
|
go i = do p <- authPropertyIteratorNext i
|
|
if p == nullPtr
|
|
then return []
|
|
else do props <- go i
|
|
prop <- marshalAuthProperty p
|
|
return (prop:props)
|
|
|
|
-- * Channel Credentials
|
|
|
|
{#fun unsafe channel_credentials_release as ^
|
|
{`ChannelCredentials'} -> `()'#}
|
|
|
|
{#fun unsafe composite_channel_credentials_create as ^
|
|
{`ChannelCredentials', `CallCredentials',unReserved `Reserved'}
|
|
-> `ChannelCredentials'#}
|
|
|
|
{#fun unsafe ssl_credentials_create_internal as ^
|
|
{`CString', `CString', `CString'} -> `ChannelCredentials'#}
|
|
|
|
sslChannelCredentialsCreate :: Maybe ByteString
|
|
-> Maybe ByteString
|
|
-> Maybe ByteString
|
|
-> IO ChannelCredentials
|
|
sslChannelCredentialsCreate (Just s) Nothing Nothing =
|
|
useAsCString s $ \s' -> sslCredentialsCreateInternal s' nullPtr nullPtr
|
|
sslChannelCredentialsCreate Nothing (Just s1) (Just s2) =
|
|
useAsCString s1 $ \s1' -> useAsCString s2 $ \s2' ->
|
|
sslCredentialsCreateInternal nullPtr s1' s2'
|
|
sslChannelCredentialsCreate (Just s1) (Just s2) (Just s3) =
|
|
useAsCString s1 $ \s1' -> useAsCString s2 $ \s2' -> useAsCString s3 $ \s3' ->
|
|
sslCredentialsCreateInternal s1' s2' s3'
|
|
sslChannelCredentialsCreate (Just s1) _ _ =
|
|
useAsCString s1 $ \s1' ->
|
|
sslCredentialsCreateInternal s1' nullPtr nullPtr
|
|
sslChannelCredentialsCreate _ _ _ =
|
|
sslCredentialsCreateInternal nullPtr nullPtr nullPtr
|
|
|
|
withChannelCredentials :: Maybe ByteString
|
|
-> Maybe ByteString
|
|
-> Maybe ByteString
|
|
-> (ChannelCredentials -> IO a)
|
|
-> IO a
|
|
withChannelCredentials x y z = bracket (sslChannelCredentialsCreate x y z)
|
|
channelCredentialsRelease
|
|
|
|
-- * Call Credentials
|
|
|
|
{#fun call_set_credentials as ^
|
|
{`Call', `CallCredentials'} -> `CallError'#}
|
|
|
|
{#fun unsafe call_credentials_release as ^
|
|
{`CallCredentials'} -> `()'#}
|
|
|
|
{#fun unsafe composite_call_credentials_create as ^
|
|
{`CallCredentials', `CallCredentials', unReserved `Reserved'}
|
|
-> `CallCredentials'#}
|
|
|
|
-- * Server Credentials
|
|
|
|
{#fun unsafe server_credentials_release as ^
|
|
{`ServerCredentials'} -> `()'#}
|
|
|
|
{#fun ssl_server_credentials_create_internal as ^
|
|
{`CString',
|
|
useAsCString* `ByteString',
|
|
useAsCString* `ByteString',
|
|
`SslClientCertificateRequestType'}
|
|
-> `ServerCredentials'#}
|
|
|
|
sslServerCredentialsCreate :: Maybe ByteString
|
|
-- ^ PEM encoding of the client root certificates.
|
|
-- Can be 'Nothing' if SSL authentication of
|
|
-- clients is not desired.
|
|
-> ByteString
|
|
-- ^ Server private key.
|
|
-> ByteString
|
|
-- ^ Server certificate.
|
|
-> SslClientCertificateRequestType
|
|
-- ^ How to handle client certificates.
|
|
-> IO ServerCredentials
|
|
sslServerCredentialsCreate Nothing k c t =
|
|
sslServerCredentialsCreateInternal nullPtr k c t
|
|
sslServerCredentialsCreate (Just cc) k c t =
|
|
useAsCString cc $ \cc' -> sslServerCredentialsCreateInternal cc' k c t
|
|
|
|
withServerCredentials :: Maybe ByteString
|
|
-- ^ PEM encoding of the client root certificates.
|
|
-- Can be 'Nothing' if SSL authentication of
|
|
-- clients is not desired.
|
|
-> ByteString
|
|
-- ^ Server private key.
|
|
-> ByteString
|
|
-- ^ Server certificate.
|
|
-> SslClientCertificateRequestType
|
|
-- ^ How to handle client certificates.
|
|
-> (ServerCredentials -> IO a)
|
|
-> IO a
|
|
withServerCredentials a b c d = bracket (sslServerCredentialsCreate a b c d)
|
|
serverCredentialsRelease
|
|
|
|
-- * Creating Secure Clients/Servers
|
|
|
|
{#fun server_add_secure_http2_port as ^
|
|
{`Server',useAsCString* `ByteString', `ServerCredentials'} -> `Int'#}
|
|
|
|
{#fun secure_channel_create as ^
|
|
{`ChannelCredentials',useAsCString* `ByteString', `GrpcChannelArgs', unReserved `Reserved'}
|
|
-> `Channel'#}
|
|
|
|
-- * Custom metadata processing -- server side
|
|
|
|
-- | Type synonym for the raw function pointer we pass to C to handle custom
|
|
-- server-side metadata auth processing.
|
|
type CAuthProcess = Ptr ()
|
|
-> AuthContext
|
|
-> MetadataKeyValPtr
|
|
-> CSize
|
|
-> FunPtr CDoneCallback
|
|
-> Ptr ()
|
|
-> IO ()
|
|
|
|
foreign import ccall "wrapper"
|
|
mkAuthProcess :: CAuthProcess -> IO (FunPtr CAuthProcess)
|
|
|
|
type CDoneCallback = Ptr ()
|
|
-> MetadataKeyValPtr
|
|
-> CSize
|
|
-> MetadataKeyValPtr
|
|
-> CSize
|
|
-> CInt -- ^ statuscode
|
|
-> CString -- ^ status details
|
|
-> IO ()
|
|
|
|
foreign import ccall "dynamic"
|
|
unwrapDoneCallback :: FunPtr CDoneCallback -> CDoneCallback
|
|
|
|
{#fun server_credentials_set_auth_metadata_processor_ as ^
|
|
{`ServerCredentials', `AuthMetadataProcessor'} -> `()'#}
|
|
|
|
foreign import ccall "grpc_haskell.h mk_auth_metadata_processor"
|
|
mkAuthMetadataProcessor :: FunPtr CAuthProcess -> IO AuthMetadataProcessor
|
|
|
|
data AuthProcessorResult = AuthProcessorResult
|
|
{ resultConsumedMetadata :: MetadataMap
|
|
-- ^ Metadata to remove from the request before passing to the handler.
|
|
, resultResponseMetadata :: MetadataMap
|
|
-- ^ Metadata to add to the response.
|
|
, resultStatus :: StatusCode
|
|
-- ^ StatusOk if auth was successful. Using any other status code here will
|
|
-- cause the request to be rejected without reaching a handler.
|
|
-- For rejected requests, it's suggested that this
|
|
-- be StatusUnauthenticated or StatusPermissionDenied.
|
|
-- NOTE: if you are using the low-level interface and the request is rejected,
|
|
-- then handling functions in the low-level
|
|
-- interface such as 'serverHandleNormalCall' will not unblock until they
|
|
-- receive another request that is not rejected. So, if you write a buggy
|
|
-- auth plugin that rejects all requests, your server could hang.
|
|
, resultStatusDetails :: StatusDetails}
|
|
|
|
-- | A custom auth metadata processor. This can be used to implement customized
|
|
-- auth schemes based on the metadata in the request.
|
|
type ProcessMeta = AuthContext
|
|
-> MetadataMap
|
|
-> IO AuthProcessorResult
|
|
|
|
convertProcessor :: ProcessMeta -> CAuthProcess
|
|
convertProcessor f = \_state authCtx inMeta numMeta callBack userDataPtr -> do
|
|
meta <- getAllMetadata inMeta (fromIntegral numMeta)
|
|
AuthProcessorResult{..} <- f authCtx meta
|
|
let cb = unwrapDoneCallback callBack
|
|
let status = (fromEnum resultStatus)
|
|
withPopulatedMetadataKeyValPtr resultConsumedMetadata $ \(conMeta, conLen) ->
|
|
withPopulatedMetadataKeyValPtr resultResponseMetadata $ \(resMeta, resLen) ->
|
|
useAsCString (unStatusDetails resultStatusDetails) $ \dtls -> do
|
|
cb userDataPtr
|
|
conMeta
|
|
(fromIntegral conLen)
|
|
resMeta
|
|
(fromIntegral resLen)
|
|
(fromIntegral status)
|
|
dtls
|
|
|
|
-- | Sets the custom metadata processor for the given server credentials.
|
|
setMetadataProcessor :: ServerCredentials -> ProcessMeta -> IO ()
|
|
setMetadataProcessor creds processor = do
|
|
let rawProcessor = convertProcessor processor
|
|
rawProcessorPtr <- mkAuthProcess rawProcessor
|
|
metaProcessor <- mkAuthMetadataProcessor rawProcessorPtr
|
|
serverCredentialsSetAuthMetadataProcessor creds metaProcessor
|
|
|
|
-- * Client-side metadata plugins
|
|
|
|
type CGetMetadata = Ptr AuthMetadataContext
|
|
-> FunPtr CGetMetadataCallBack
|
|
-> Ptr ()
|
|
-- ^ user data ptr (opaque, but must be passed on)
|
|
-> IO ()
|
|
|
|
foreign import ccall "wrapper"
|
|
mkCGetMetadata :: CGetMetadata -> IO (FunPtr CGetMetadata)
|
|
|
|
type CGetMetadataCallBack = Ptr ()
|
|
-> MetadataKeyValPtr
|
|
-> CSize
|
|
-> CInt
|
|
-> CString
|
|
-> IO ()
|
|
|
|
foreign import ccall "dynamic"
|
|
unwrapGetMetadataCallback :: FunPtr CGetMetadataCallBack
|
|
-> CGetMetadataCallBack
|
|
|
|
data ClientMetadataCreateResult = ClientMetadataCreateResult
|
|
{ clientResultMetadata :: MetadataMap
|
|
-- ^ Additional metadata to add to the call.
|
|
, clientResultStatus :: StatusCode
|
|
-- ^ if not 'StatusOk', causes the call to fail with the given status code.
|
|
-- NOTE: if the auth fails, the call will not get sent to the server. So, if
|
|
-- you're writing a test, your server might wait for a request forever.
|
|
, clientResultDetails :: StatusDetails }
|
|
|
|
-- | Optional plugin for attaching custom auth metadata to each call.
|
|
type ClientMetadataCreate = AuthMetadataContext
|
|
-> IO ClientMetadataCreateResult
|
|
|
|
convertMetadataCreate :: ClientMetadataCreate -> CGetMetadata
|
|
convertMetadataCreate f = \authCtxPtr doneCallback userDataPtr -> do
|
|
authCtx <- authMetadataContextMarshal authCtxPtr
|
|
ClientMetadataCreateResult{..} <- f authCtx
|
|
let cb = unwrapGetMetadataCallback doneCallback
|
|
withPopulatedMetadataKeyValPtr clientResultMetadata $ \(meta,metaLen) ->
|
|
useAsCString (unStatusDetails clientResultDetails) $ \details -> do
|
|
let status = fromIntegral $ fromEnum clientResultStatus
|
|
cb userDataPtr meta (fromIntegral metaLen) status details
|
|
|
|
foreign import ccall "grpc_haskell.h mk_metadata_client_plugin"
|
|
mkMetadataClientPlugin :: FunPtr CGetMetadata -> IO MetadataCredentialsPlugin
|
|
|
|
{#fun metadata_credentials_create_from_plugin_ as ^
|
|
{`MetadataCredentialsPlugin'} -> `CallCredentials' #}
|
|
|
|
createCustomCallCredentials :: ClientMetadataCreate -> IO CallCredentials
|
|
createCustomCallCredentials create = do
|
|
let rawCreate = convertMetadataCreate create
|
|
rawCreatePtr <- mkCGetMetadata rawCreate
|
|
plugin <- mkMetadataClientPlugin rawCreatePtr
|
|
metadataCredentialsCreateFromPlugin plugin
|