diff --git a/Changelog.markdown b/Changelog.markdown --- a/Changelog.markdown +++ b/Changelog.markdown @@ -1,3 +1,8 @@ +# v0.5.0 (2025-08-31) + +* add encryption support via TLS +* add optional authentication support via mutual TLS + # v0.4.0 (2025-03-29) * add ability to serve and connect to IPv6 and Unix domain sockets (#5) diff --git a/curryer-rpc.cabal b/curryer-rpc.cabal --- a/curryer-rpc.cabal +++ b/curryer-rpc.cabal @@ -1,5 +1,5 @@ Name: curryer-rpc -Version: 0.4.0 +Version: 0.5.0 License: PublicDomain Build-Type: Simple Homepage: https://github.com/agentm/curryer @@ -32,12 +32,20 @@ , uuid , fast-builder , binary + , text , containers , stm-containers , hashable , time , network-byte-order , stm + , tls >= 2.1.11 + , data-default + , streaming-commons + , crypton-x509-store + , crypton-x509-system + , crypton-x509 + , asn1-types Hs-Source-Dirs: ./src Default-Language: Haskell2010 ghc-options: -Wall -fwarn-unused-binds -fwarn-unused-imports @@ -45,6 +53,7 @@ Network.RPC.Curryer.Server Network.RPC.Curryer.Client Network.RPC.Curryer.StreamlyAdditions + Network.RPC.Curryer.StreamlyTLS Test-Suite test type: exitcode-stdio-1.0 @@ -64,7 +73,11 @@ , streamly-core >= 0.1.0 , bytestring , streamly-bytestring >= 0.2.1 - other-modules: Curryer.Test.Basic + , directory + , process + , filepath + , tls + other-modules: Curryer.Test.Basic, Curryer.Test.TLS Benchmark perf Default-Language: Haskell2010 diff --git a/examples/SimpleKeyValueClient.hs b/examples/SimpleKeyValueClient.hs --- a/examples/SimpleKeyValueClient.hs +++ b/examples/SimpleKeyValueClient.hs @@ -23,7 +23,7 @@ main = do opts <- getRecord "SimpleKeyValueClient" -- connect to the remote server (in this case on the localhost address) - conn <- connectIPv4 [] localHostAddr 8765 + conn <- connectIPv4 [] UnencryptedConnectionConfig localHostAddr 8765 case opts of Get k -> do --call the remote function and validate the result diff --git a/examples/SimpleKeyValueServer.hs b/examples/SimpleKeyValueServer.hs --- a/examples/SimpleKeyValueServer.hs +++ b/examples/SimpleKeyValueServer.hs @@ -19,7 +19,7 @@ main :: IO () main = do kvmap <- M.newIO - void $ serveIPv4 kvRequestHandlers kvmap localHostAddr 8765 Nothing + void $ serveIPv4 kvRequestHandlers kvmap UnencryptedConnectionConfig localHostAddr 8765 Nothing -- setup incoming request handlers to operate on the server's state kvRequestHandlers :: RequestHandlers (M.Map String String) diff --git a/src/Network/RPC/Curryer/Client.hs b/src/Network/RPC/Curryer/Client.hs --- a/src/Network/RPC/Curryer/Client.hs +++ b/src/Network/RPC/Curryer/Client.hs @@ -1,9 +1,10 @@ {-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs #-} module Network.RPC.Curryer.Client where -import Network.RPC.Curryer.Server +import Network.RPC.Curryer.Server (UUID(..), ConnectionError(..), SocketContext(..), BinaryMessage, HostAddressTuple, HostAddressTuple6, ServerHostName, ServerServiceName, Locking(..), Envelope(..), MessageType(..), withLock, lockingSocket, drainSocketMessages, openEnvelope, msgDeserialise, msgSerialise, fingerprint, sendEnvelope, newLock) import Network.Socket as Socket (Socket, PortNumber, SockAddr(..), close, Family(..), SocketType(..), tupleToHostAddress, tupleToHostAddress6) import Streamly.Internal.Network.Socket (SockSpec(..)) import qualified Streamly.Internal.Network.Socket as SINS +import qualified Network.RPC.Curryer.StreamlyTLS as STLS import Codec.Winery import Control.Concurrent.Async import qualified Data.UUID.V4 as UUIDBase @@ -13,11 +14,14 @@ import Data.Time.Clock import System.Timeout import Control.Monad +import Network.TLS +import Data.X509.CertificateStore +import System.X509 type SyncMap = STMMap.Map UUID (MVar (Either ConnectionError BinaryMessage), UTCTime) -- | Represents a remote connection to server. -data Connection = Connection { _conn_sockLock :: Locking Socket, +data Connection = Connection { _conn_sockContext :: SocketContext, _conn_asyncThread :: Async (), _conn_syncmap :: SyncMap } @@ -28,14 +32,35 @@ type ClientAsyncRequestHandlers = [ClientAsyncRequestHandler] +-- | Specifies whether the connection should be encrypted with TLS (preferred) or unencrypted. +data ClientConnectionConfig = + UnencryptedConnectionConfig | + EncryptedConnectionConfig ClientTLSConfig + deriving Show + +-- | Client-side encryption TLS configuration. +data ClientTLSConfig = ClientTLSConfig + { tlsCertInfo :: ClientTLSCertInfo, + tlsServerHostName :: ServerHostName, + tlsServerServiceName :: ServerServiceName + } deriving Show + +-- | Client-side TLS keys and certificate information for use with optional mutual TLS. +data ClientTLSCertInfo = ClientTLSCertInfo + { + x509PublicPrivateFilePaths :: Maybe (FilePath, FilePath), + x509CertFilePath :: Maybe FilePath -- ^ if Nothing, use system's certificate store + } deriving Show + -- | Connect to a remote server over IPv4. Wraps `connect`. connectIPv4 :: ClientAsyncRequestHandlers -> + ClientConnectionConfig -> HostAddressTuple -> PortNumber -> IO Connection -connectIPv4 asyncHandlers hostaddr portnum = - connect asyncHandlers sockSpec sockAddr +connectIPv4 asyncHandlers config hostaddr portnum = + connect asyncHandlers config sockSpec sockAddr where sockSpec = SINS.SockSpec { sockFamily = AF_INET, sockType = Stream, @@ -46,11 +71,12 @@ -- | Connect to a remote server over IPv6. Wraps `connect`. connectIPv6 :: ClientAsyncRequestHandlers -> + ClientConnectionConfig -> HostAddressTuple6 -> PortNumber -> IO Connection -connectIPv6 asyncHandlers hostaddr portnum = - connect asyncHandlers sockSpec sockAddr +connectIPv6 asyncHandlers config hostaddr portnum = + connect asyncHandlers config sockSpec sockAddr where sockSpec = SINS.SockSpec { sockFamily = AF_INET6, sockType = Stream, @@ -58,12 +84,13 @@ sockOpts = [] } sockAddr = SockAddrInet6 portnum 0 (tupleToHostAddress6 hostaddr) 0 +-- | Connect to a server running on localhost using Unix domain sockets. connectUnixDomain :: ClientAsyncRequestHandlers -> FilePath -> IO Connection connectUnixDomain asyncHandlers socketPath = - connect asyncHandlers sockSpec sockAddr + connect asyncHandlers UnencryptedConnectionConfig sockSpec sockAddr where sockSpec = SINS.SockSpec { sockFamily = AF_UNIX, sockType = Stream, @@ -74,16 +101,18 @@ -- | Connects to a remote server with specific async callbacks registered. connect :: ClientAsyncRequestHandlers -> + ClientConnectionConfig -> SINS.SockSpec -> SockAddr -> IO Connection -connect asyncHandlers sockSpec sockAddr = do +connect asyncHandlers config sockSpec sockAddr = do sock <- SINS.connect sockSpec sockAddr syncmap <- STMMap.newIO - asyncThread <- async (clientAsync sock syncmap asyncHandlers) - sockLock <- newLock sock + sockCtx <- setupClientSocket config sock + asyncThread <- async (clientAsync sockCtx syncmap asyncHandlers) + pure (Connection { - _conn_sockLock = sockLock, + _conn_sockContext = sockCtx, _conn_asyncThread = asyncThread, _conn_syncmap = syncmap }) @@ -91,19 +120,21 @@ -- | Close the connection and release all connection resources. close :: Connection -> IO () close conn = do - withLock (_conn_sockLock conn) $ \sock -> + withLock (lockingSocket (_conn_sockContext conn)) $ \sock -> do + case _conn_sockContext conn of + UnencryptedSocketContext{} -> pure () + EncryptedSocketContext _ tlsCtx -> bye tlsCtx Socket.close sock cancel (_conn_asyncThread conn) -- | async thread for handling client-side incoming messages- dispatch to proper waiting thread or asynchronous notifications handler -clientAsync :: - Socket -> +clientAsync :: + SocketContext -> SyncMap -> ClientAsyncRequestHandlers -> IO () -clientAsync sock syncmap asyncHandlers = do - lsock <- newLock sock - drainSocketMessages sock (clientEnvelopeHandler asyncHandlers lsock syncmap) +clientAsync sockCtx syncmap asyncHandlers = do + drainSocketMessages sockCtx (clientEnvelopeHandler asyncHandlers (lockingSocket sockCtx) syncmap) consumeResponse :: UUID -> STMMap.Map UUID (MVar a, b) -> a -> IO () consumeResponse msgId syncMap val = do @@ -162,7 +193,7 @@ responseMVar <- newEmptyMVar now <- getCurrentTime atomically $ STMMap.insert (responseMVar, now) requestID mVarMap - sendEnvelope envelope (_conn_sockLock conn) + sendEnvelope envelope (_conn_sockContext conn) let timeoutMicroseconds = case mTimeout of Just timeout' -> timeout' + 100 --add 100 ms to account for unknown network latency @@ -186,6 +217,46 @@ requestID <- UUID <$> UUIDBase.nextRandom let envelope = Envelope fprint (RequestMessage 0) requestID (msgSerialise msg) fprint = fingerprint msg - sendEnvelope envelope (_conn_sockLock conn) + sendEnvelope envelope (_conn_sockContext conn) pure (Right ()) +-- | Post-TCP connection client socket setup, especially for TLS handshake. +setupClientSocket :: ClientConnectionConfig -> Socket -> IO SocketContext +setupClientSocket config sock = do + sockLock <- newLock sock + case config of + UnencryptedConnectionConfig{} -> pure (UnencryptedSocketContext sockLock) + EncryptedConnectionConfig tlsConfig -> do + let serverHostTuple = (tlsServerHostName tlsConfig, + tlsServerServiceName tlsConfig) + mCred <- do + let mKeyPaths = x509PublicPrivateFilePaths (tlsCertInfo tlsConfig) + case mKeyPaths of + Nothing -> pure Nothing + Just (pubKeyPath, privKeyPath) -> do + eCred <- credentialLoadX509 pubKeyPath privKeyPath + case eCred of + Left err -> error err + Right cred -> + pure (Just cred) + mCAStore <- case x509CertFilePath (tlsCertInfo tlsConfig) of + Nothing -> Just <$> getSystemCertificateStore + Just certPath -> do + mCAStore <- readCertificateStore certPath + case mCAStore of + Nothing -> error ("failed to load certificate store at " <> certPath) + Just caStore -> + pure (Just caStore) + tlsCtx <- STLS.clientHandshake sock serverHostTuple mCred mCAStore + pure (EncryptedSocketContext sockLock tlsCtx) + +defaultClientConnectionConfig :: ClientConnectionConfig +defaultClientConnectionConfig = + EncryptedConnectionConfig (ClientTLSConfig { + tlsCertInfo = ClientTLSCertInfo { + x509PublicPrivateFilePaths = Nothing, + x509CertFilePath = Nothing + }, + tlsServerHostName = "localhost", + tlsServerServiceName = mempty + }) diff --git a/src/Network/RPC/Curryer/Server.hs b/src/Network/RPC/Curryer/Server.hs --- a/src/Network/RPC/Curryer/Server.hs +++ b/src/Network/RPC/Curryer/Server.hs @@ -16,7 +16,7 @@ import GHC.Fingerprint import Data.Typeable import Control.Concurrent.MVar (MVar, newMVar, withMVar) -import Control.Exception +import Control.Exception as Exc import Data.Function ((&)) import Data.Word import qualified Data.ByteString as BS @@ -28,18 +28,23 @@ import qualified Streamly.External.ByteString as StreamlyBS import Streamly.Data.Stream.Prelude as Stream hiding (foldr) import Streamly.Internal.Data.Binary.Parser (word32be) +import qualified Streamly.Data.Unfold as UF import qualified Data.Binary as B import qualified Data.UUID as UUIDBase import qualified Data.UUID.V4 as UUIDBase import Control.Monad import Data.Functor import Control.Applicative +import System.IO (hPutStr, stderr) import qualified Network.RPC.Curryer.StreamlyAdditions as SA +import qualified Network.RPC.Curryer.StreamlyTLS as STLS import Data.Hashable import System.Timeout import qualified Network.ByteOrder as BO - +import qualified Network.TLS as TLS +import Data.X509.CertificateStore +import System.X509 #define CURRYER_SHOW_BYTES 0 #define CURRYER_PASS_SCHEMA 0 @@ -84,6 +89,33 @@ lockless :: Locking a -> a lockless (Locking _ a) = a +-- | Server-side TLS key/certificate information. +data ServerTLSCertInfo = ServerTLSCertInfo + { + x509PublicFilePath :: FilePath, + x509PrivateFilePath :: FilePath, + x509CertFilePath :: Maybe FilePath -- ^ if Nothing, use the system's certificate store + } deriving Show + +-- | Server-side TLS configuration. +data ServerTLSConfig = ServerTLSConfig + { tlsCertInfo :: ServerTLSCertInfo, + tlsServerHostName :: ServerHostName, + tlsServerServiceName :: ServerServiceName + } deriving Show + +type ServerHostName = HostName +type ServerServiceName = BS.ByteString + +-- | Specify whether server should listen for unencrypted connections or TLS-encrypted connections (preferred). +data ServerConnectionConfig = UnencryptedConnectionConfig | + EncryptedConnectionConfig ServerTLSConfig ClientAuth + deriving Show + +-- | Specify whether the server should require a client-provided certificate for login (preferred) or whether anonymous clients should be granted access, too. +data ClientAuth = ClientAuthRequired | AcceptAnonymousClient + deriving (Eq, Show) + type Timeout = Word32 type BinaryMessage = BS.ByteString @@ -124,20 +156,38 @@ -- | create an asynchronous request handler where the client does not expect nor await a response AsyncRequestHandler :: forall a serverState. Serialise a => (ConnectionState serverState -> a -> IO ()) -> RequestHandler serverState +type ClientConnectionId = UUIDBase.UUID + -- | Server state sent in via `serve` and passed to `RequestHandler`s. data ConnectionState a = ConnectionState { connectionServerState :: a, - connectionSocket :: Locking Socket + connectionClientId :: ClientConnectionId, -- ^ uniquely identifies the client in callbacks + connectionSocketContext :: SocketContext, + connectionRoleName :: Maybe STLS.RoleName -- ^ if a client certificate is provided during the TLS handshake, the connection role is the organization unit, if available } +data SocketContext = UnencryptedSocketContext (Locking Socket) | + EncryptedSocketContext (Locking Socket) TLS.Context + +instance Eq SocketContext where + UnencryptedSocketContext lockSockA == UnencryptedSocketContext lockSockB = + lockless lockSockA == lockless lockSockB + EncryptedSocketContext lockSockA _ == EncryptedSocketContext lockSockB _ = + lockless lockSockA == lockless lockSockB + _ == _ = False + +lockingSocket :: SocketContext -> Locking Socket +lockingSocket (UnencryptedSocketContext ls) = ls +lockingSocket (EncryptedSocketContext ls _tlsCtx) = ls + -- | Used by server-side request handlers to send additional messages to the client. This is useful for sending asynchronous responses to the client outside of the normal request-response flow. The locking socket can be found in the ConnectionState when a request handler is called. -sendMessage :: Serialise a => Locking Socket -> a -> IO () -sendMessage lockSock msg = do +sendMessage :: Serialise a => SocketContext -> a -> IO () +sendMessage sockCtx msg = do requestID <- UUID <$> UUIDBase.nextRandom let env = Envelope (fingerprint msg) (RequestMessage timeout') requestID (msgSerialise msg) timeout' = 0 - sendEnvelope env lockSock + sendEnvelope env sockCtx --avoid orphan instance newtype UUID = UUID { _unUUID :: UUIDBase.UUID } @@ -269,9 +319,9 @@ defaultSocketOptions = [(ReuseAddr, 1), (NoDelay, 1)] -- | Listen for new connections and handle requests on an IPv4 address. Wraps `serve1. -serveIPv4 :: RequestHandlers s -> s -> HostAddressTuple -> PortNumber -> Maybe (MVar SockAddr) -> IO Bool -serveIPv4 handlers state hostaddr port mSockLock = - serve handlers state sockSpec sockAddr mSockLock +serveIPv4 :: RequestHandlers s -> s -> ServerConnectionConfig -> HostAddressTuple -> PortNumber -> Maybe (MVar SockAddr) -> IO Bool +serveIPv4 handlers state config hostaddr port = + serve handlers state config sockSpec sockAddr where sockAddr = SockAddrInet port (tupleToHostAddress hostaddr) sockSpec = SockSpec { sockFamily = AF_INET, @@ -281,9 +331,9 @@ } -- | Listen for IPv6 RPC requests. Wraps `serve`. -serveIPv6 :: RequestHandlers s -> s -> HostAddressTuple6 -> PortNumber -> Maybe (MVar SockAddr) -> IO Bool -serveIPv6 handlers state hostaddr port mSockLock = - serve handlers state sockSpec sockAddr mSockLock +serveIPv6 :: RequestHandlers s -> s -> ServerConnectionConfig -> HostAddressTuple6 -> PortNumber -> Maybe (MVar SockAddr) -> IO Bool +serveIPv6 handlers state config hostaddr port = + serve handlers state config sockSpec sockAddr where flowInfo = 0 scopeInfo = 0 @@ -296,8 +346,8 @@ -- | Listen for Unix domain socket RPC requests. Wraps `serve`. serveUnixDomain :: RequestHandlers s -> s -> FilePath -> Maybe (MVar SockAddr) -> IO Bool -serveUnixDomain handlers state socketPath mSockLock = - serve handlers state sockSpec sockAddr mSockLock +serveUnixDomain handlers state socketPath = + serve handlers state UnencryptedConnectionConfig sockSpec sockAddr where sockSpec = SockSpec { sockFamily = AF_UNIX, sockType = Stream, @@ -307,21 +357,45 @@ -- | Listen for new connections and handle requests which are passed the server state 's'. The MVar SockAddr can be be optionally used to know when the server is ready for processing requests. serve :: - RequestHandlers s-> + RequestHandlers s -> s -> + ServerConnectionConfig -> SockSpec -> SockAddr -> Maybe (MVar SockAddr) -> IO Bool -serve userMsgHandlers serverState sockSpec sockAddr mSockLock = do - let handleSock sock = do - lockingSocket <- newLock sock - drainSocketMessages sock (serverEnvelopeHandler lockingSocket userMsgHandlers serverState) +serve userMsgHandlers serverState config sockSpec sockAddr mSockLock = do + let handleSock sock = Exc.handle (excHandler sock) $ do + (sockCtx, mRoleName) <- setupServerSocket config sock + clientId <- UUIDBase.nextRandom + drainSocketMessages sockCtx (serverEnvelopeHandler sockCtx clientId mRoleName userMsgHandlers serverState) + excHandler sock (exc :: TLS.TLSException) = do + hPutStr stderr (show exc) + Socket.close sock Stream.unfold (SA.acceptorOnSockSpec sockSpec mSockLock) sockAddr & Stream.parMapM id handleSock & Stream.fold FL.drain pure True +-- | Negotiate TLS on the socket, if necessary. If ClientAuth is True, then all clients are required to present a certificate for mutual TLS (anonymous clients will be rejected during the TLS handshake). +setupServerSocket :: ServerConnectionConfig -> Socket -> IO (SocketContext, Maybe STLS.RoleName) +setupServerSocket config sock = do + sockLock <- newLock sock + case config of + UnencryptedConnectionConfig{} -> pure (UnencryptedSocketContext sockLock, Nothing) + EncryptedConnectionConfig tlsConfig clientAuth -> do + let mCertPath = x509CertFilePath (tlsCertInfo tlsConfig) + creds <- STLS.readCreds (x509PublicFilePath (tlsCertInfo tlsConfig)) (x509PrivateFilePath (tlsCertInfo tlsConfig)) + caStore <- case mCertPath of + Just certPath -> do + mCAStore <- readCertificateStore certPath + case mCAStore of + Nothing -> error ("failed to load certificate store at " <> certPath) + Just caStore -> pure caStore + Nothing -> getSystemCertificateStore + (tlsCtx, mRoleName) <- STLS.serverHandshake sock creds (clientAuth /= AcceptAnonymousClient) (Just caStore) + pure (EncryptedSocketContext sockLock tlsCtx, mRoleName) + openEnvelope :: forall s. (Serialise s, Typeable s) => Envelope -> Maybe s openEnvelope (Envelope eprint _ _ bytes) = if eprint == fingerprint (undefined :: s) then @@ -348,16 +422,17 @@ Just decoded -> Just (dispatchf, decoded) -- | Called by `serve` to process incoming envelope requests. Never returns, so use `async` to spin it off on another thread. -serverEnvelopeHandler :: - Locking Socket +serverEnvelopeHandler :: SocketContext + -> ClientConnectionId + -> Maybe STLS.RoleName -> RequestHandlers s -> s -> Envelope -> IO () -serverEnvelopeHandler _ _ _ (Envelope _ TimeoutResponseMessage _ _) = pure () -serverEnvelopeHandler _ _ _ (Envelope _ ExceptionResponseMessage _ _) = pure () -serverEnvelopeHandler _ _ _ (Envelope _ ResponseMessage _ _) = pure () -serverEnvelopeHandler sockLock msgHandlers serverState envelope@(Envelope _ (RequestMessage timeoutms) msgId _) = do +serverEnvelopeHandler _ _ _ _ _ (Envelope _ TimeoutResponseMessage _ _) = pure () +serverEnvelopeHandler _ _ _ _ _ (Envelope _ ExceptionResponseMessage _ _) = pure () +serverEnvelopeHandler _ _ _ _ _ (Envelope _ ResponseMessage _ _) = pure () +serverEnvelopeHandler sockCtx clientId mRoleName msgHandlers serverState envelope@(Envelope _ (RequestMessage timeoutms) msgId _) = do --find first matching handler let runTimeout :: IO b -> IO (Maybe b) runTimeout m = @@ -371,7 +446,9 @@ sState = ConnectionState { connectionServerState = serverState, - connectionSocket = sockLock + connectionClientId = clientId, + connectionSocketContext = sockCtx, + connectionRoleName = mRoleName } firstMatcher (RequestHandler msghandler) Nothing = @@ -386,7 +463,7 @@ Envelope (fingerprint response) ResponseMessage msgId (msgSerialise response) Nothing -> Envelope (fingerprint TimeoutError) TimeoutResponseMessage msgId BS.empty - sendEnvelope envelopeResponse sockLock + sendEnvelope envelopeResponse sockCtx pure (Just ()) firstMatcher (AsyncRequestHandler msghandler) Nothing = case matchEnvelope envelope msghandler of @@ -399,33 +476,44 @@ case eExc of Left exc -> let env = Envelope (fingerprint (show exc)) ExceptionResponseMessage msgId (msgSerialise (show exc)) in - sendEnvelope env sockLock + sendEnvelope env sockCtx Right () -> pure () type EnvelopeHandler = Envelope -> IO () -drainSocketMessages :: Socket -> EnvelopeHandler -> IO () -drainSocketMessages sock envelopeHandler = do - SP.unfold SSock.reader sock - & P.parseMany envelopeP - & SP.catRights - & SP.parMapM (SP.ordered False) envelopeHandler - & SP.fold FL.drain +drainSocketMessages :: SocketContext -> EnvelopeHandler -> IO () +drainSocketMessages sockCtx envelopeHandler = do + + let socketReader :: UF.Unfold IO Socket Word8 + socketReader = case sockCtx of + UnencryptedSocketContext{} -> SSock.reader + EncryptedSocketContext _lsock tlsCtx -> + STLS.tlsReader tlsCtx + sock = lockless (lockingSocket sockCtx) + SP.unfold socketReader sock + & P.parseMany envelopeP + & SP.catRights + & SP.parMapM (SP.ordered False) envelopeHandler + & SP.fold FL.drain --send length-tagged bytestring, perhaps should be in network byte order? -sendEnvelope :: Envelope -> Locking Socket -> IO () -sendEnvelope envelope sockLock = do +sendEnvelope :: Envelope -> SocketContext -> IO () +sendEnvelope envelope sockCtx = do let envelopebytes = encodeEnvelope envelope --Socket.sendAll syscalls send() on a loop until all the bytes are sent, so we need socket locking here to account for serialized messages of size > PIPE_BUF - withLock sockLock $ \socket' -> do + withLock (lockingSocket sockCtx) $ \socket' -> do {-traceShowM ("sendEnvelope"::String, ("type"::String, envMessageType envelope), socket', ("envelope len out"::String, BS.length envelopebytes), "payloadbytes"::String, envPayload envelope )-} - Socket.sendAll socket' envelopebytes + case sockCtx of + UnencryptedSocketContext{} -> + Socket.sendAll socket' envelopebytes + EncryptedSocketContext _ls tlsCtx -> + TLS.sendData tlsCtx (BSL.fromStrict envelopebytes) traceBytes "sendEnvelope" envelopebytes fingerprint :: Typeable a => a -> Fingerprint diff --git a/src/Network/RPC/Curryer/StreamlyAdditions.hs b/src/Network/RPC/Curryer/StreamlyAdditions.hs --- a/src/Network/RPC/Curryer/StreamlyAdditions.hs +++ b/src/Network/RPC/Curryer/StreamlyAdditions.hs @@ -9,7 +9,7 @@ import Streamly.Network.Socket hiding (acceptor) import qualified Streamly.Internal.Data.Stream as D import Streamly.Internal.Data.Unfold (Unfold(..)) -import Control.Monad (when) +import Control.Monad (unless) --import Streamly.Internal.Network.Socket as INS acceptorOnSockSpec @@ -41,10 +41,10 @@ Just mvar -> putMVar mvar sockAddr Nothing -> pure () pure sock - + step :: MonadIO m => Socket -> m (D.Step Socket (Socket, SockAddr)) step listener = do - r <- liftIO (Net.accept listener `onException` Net.close listener) - return $ D.Yield r listener + (sock, sockAddr) <- liftIO $ Net.accept listener `onException` Net.close listener + return $ D.Yield (sock, sockAddr) listener initListener :: Int -> SockSpec -> SockAddr -> IO Socket initListener listenQLen sockSpec addr = @@ -56,7 +56,7 @@ where use sock = do - when (not (null (sockOpts sockSpec))) $ mapM_ (uncurry (setSocketOption sock)) (sockOpts sockSpec) + unless (null (sockOpts sockSpec)) $ mapM_ (uncurry (setSocketOption sock)) (sockOpts sockSpec) bind sock addr Net.listen sock listenQLen diff --git a/src/Network/RPC/Curryer/StreamlyTLS.hs b/src/Network/RPC/Curryer/StreamlyTLS.hs new file mode 100644 --- /dev/null +++ b/src/Network/RPC/Curryer/StreamlyTLS.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} +module Network.RPC.Curryer.StreamlyTLS where +--import Network.RPC.Curryer.StreamlyAdditions (initListener) +import Network.TLS as TLS +import Network.Socket hiding (socket) +--import Control.Monad.IO.Class +--import Streamly.Network.Socket (SockSpec) +--import Control.Concurrent (MVar, putMVar) +import qualified Streamly.Data.Array as A +import Streamly.Internal.Data.Unfold (Unfold(..)) +import Streamly.External.ByteString (toArray) +import Streamly.Data.Array (Array) +import qualified Streamly.Internal.Data.Unfold as UF +import qualified Network.TLS.Extra as TLSExtra +--import qualified Network.Socket as Net +import qualified Streamly.Internal.Data.Stream as D +import Data.Default +--import Control.Exception (onException) +import Network.Socket.ByteString (sendAll, recv) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Word (Word8) +import Data.X509.CertificateStore +import Data.X509 +import Data.ASN1.Types.String +import Control.Concurrent.MVar +import Control.Monad (void, when) +import Data.Maybe + +clientHandshake :: Socket -> (HostName, ByteString) -> Maybe Credential -> Maybe CertificateStore -> IO TLS.Context +clientHandshake socket (serverHostName, serverService) mCred mCertStore = do + let backend = TLS.Backend { backendFlush = pure (), + backendClose = pure (), + backendSend = sendAll socket, + backendRecv = recvExact socket + } + params = (defaultParamsClient serverHostName serverService) + { +-- clientDebug = defaultDebugParams { debugError = \x -> putStrLn ("client debug: " <> x) }, + clientShared = defaultShared { sharedCAStore = fromMaybe mempty mCertStore + }, + clientSupported = defaultSupported { supportedVersions = [TLS13] }, + clientHooks = defaultClientHooks { + onCertificateRequest = \_ -> pure mCred + } + } + ctx <- TLS.contextNew backend params + TLS.handshake ctx + pure ctx + +type RoleName = String + +serverHandshake :: Socket -> TLS.Credentials -> Bool -> Maybe CertificateStore -> IO (TLS.Context, Maybe RoleName) +serverHandshake socket creds requireClientAuth mCertStore = do + roleName <- newMVar Nothing + let backend = TLS.Backend { backendFlush = pure (), + backendClose = pure (), + backendSend = sendAll socket, + backendRecv = recvExact socket + } + certStore = fromMaybe mempty mCertStore + validationCache = sharedValidationCache defaultShared + params = defaultParamsServer + { serverWantClientCert = requireClientAuth + , serverSupported = def + { supportedCiphers = TLSExtra.ciphersuite_default, + supportedVersions = [TLS13] + } + , serverShared = def + { sharedCredentials = creds, + sharedCAStore = certStore + } +-- , serverDebug = defaultDebugParams { debugError = \x -> putStrLn ("server: " <> x) } + , serverHooks = defaultServerHooks { + onClientCertificate = \certChain -> do + --extract role from client certificate and save it + valRes <- validateClientCertificate certStore validationCache certChain + when (valRes == CertificateUsageAccept) $ + void $ swapMVar roleName (extractRoleFromCertChain certChain) + pure valRes + } + } + ctx <- TLS.contextNew backend params + TLS.handshake ctx + roleName' <- takeMVar roleName + pure (ctx, roleName') + +extractRoleFromCertChain :: CertificateChain -> Maybe String +extractRoleFromCertChain (CertificateChain [signedClientCert]) = + let clientCert = signedObject (getSigned signedClientCert) + dnElements = certSubjectDN clientCert + mOUElement = getDnElement DnOrganizationUnit dnElements + in + asn1CharacterToString =<< mOUElement +extractRoleFromCertChain _ = Nothing + + +-- | TLS requires exactly the number of bytes requested to be returned. +recvExact :: Socket -> Int -> IO ByteString +recvExact socket i = do + loop id i + where + loop front rest + | rest < 0 = error "StreamlyTLS.recvExact: rest < 0" + | rest == 0 = return $ BS.concat $ front [] + | otherwise = do + next <- safeRecv socket rest + if BS.length next == 0 + then + return $ BS.concat $ front [] + else loop (front . (next:)) $ rest - BS.length next + +#if defined(__GLASGOW_HASKELL__) && WINDOWS +-- Socket recv and accept calls on Windows platform cannot be interrupted when compiled with -threaded. +-- See https://ghc.haskell.org/trac/ghc/ticket/5797 for details. +-- The following enables simple workaround +#define SOCKET_ACCEPT_RECV_WORKAROUND +#endif + +safeRecv :: Socket -> Int -> IO ByteString +#ifndef SOCKET_ACCEPT_RECV_WORKAROUND +safeRecv = recv +#else +safeRecv s buf = do + var <- newEmptyMVar + forkIO $ recv s buf `E.catch` (\(_::IOException) -> return S8.empty) >>= putMVar var + takeMVar var +#endif + + +tlsReader :: TLS.Context -> UF.Unfold IO Socket Word8 +tlsReader ctx = UF.many A.reader (chunkTLSReader ctx) + +-- | Read from TLS socket as soon as it is created. +chunkTLSReader :: TLS.Context -> UF.Unfold IO Socket (Array Word8) +chunkTLSReader ctx = Unfold step inject + where + step () = do + bs <- recvData ctx + if BS.length bs == 0 then + pure D.Stop + else do + pure (D.Yield (toArray bs) ()) + inject _sock = pure () + +data TlsCertData = TlsCertData { getTLSCert :: IO ByteString + , getTLSChainCerts :: IO [ByteString] + , getTLSKey :: IO ByteString } + +readCreds :: FilePath -> FilePath -> IO TLS.Credentials +readCreds certPath keyPath = do + eCred <- credentialLoadX509 certPath keyPath + case eCred of + Left err -> error (show err) + Right cred -> pure (Credentials [cred]) diff --git a/test/Curryer/Test/Basic.hs b/test/Curryer/Test/Basic.hs --- a/test/Curryer/Test/Basic.hs +++ b/test/Curryer/Test/Basic.hs @@ -14,8 +14,8 @@ import Data.List import Data.Text (Text, pack) -import Network.RPC.Curryer.Server -import Network.RPC.Curryer.Client +import Network.RPC.Curryer.Server as S +import Network.RPC.Curryer.Client as C -- TODO: add test for nested calls @@ -87,7 +87,7 @@ maybe (pure ()) (\mvar -> putMVar mvar v) mAsyncMVar -- an async hello to the server generates an async hello to the client , AsyncRequestHandler $ \sState (AsyncHelloReq s) -> do - sendMessage (connectionSocket sState) (AsyncHelloReq s) + sendMessage (connectionSocketContext sState) (AsyncHelloReq s) , RequestHandler $ \_ (RoundtripStringReq s) -> pure s , RequestHandler $ \_ (DelayMicrosecondsReq ms) -> do @@ -104,10 +104,10 @@ testSimpleCall = do readyVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) --wait for server to be ready (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port replicateM_ 5 $ do --make five AddTwo calls to shake out parallelism bugs x <- call conn (AddTwoNumbersReq 1 1) assertEqual "server request+response" (Right (2 :: Int)) x @@ -123,9 +123,9 @@ let clientAsyncHandlers = [ClientAsyncRequestHandler (\(AsyncHelloReq s) -> putMVar receivedAsyncMessageVar s)] - server <- async (serveIPv4 (testServerRequestHandlers (Just receivedAsyncMessageVar)) emptyServerState localHostAddr 0 (Just portReadyVar)) + server <- async (serveIPv4 (testServerRequestHandlers (Just receivedAsyncMessageVar)) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just portReadyVar)) (SockAddrInet port _) <- takeMVar portReadyVar - conn <- connectIPv4 clientAsyncHandlers localHostAddr port + conn <- connectIPv4 clientAsyncHandlers C.UnencryptedConnectionConfig localHostAddr port Right () <- asyncCall conn (AsyncHelloReq "welcome") asyncMessage <- takeMVar receivedAsyncMessageVar assertEqual "async message" "welcome" asyncMessage @@ -142,10 +142,10 @@ portReadyVar <- newEmptyMVar receivedAsyncMessageVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers (Just receivedAsyncMessageVar)) emptyServerState localHostAddr 0 (Just portReadyVar)) + server <- async (serveIPv4 (testServerRequestHandlers (Just receivedAsyncMessageVar)) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just portReadyVar)) (SockAddrInet port _) <- takeMVar portReadyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port --send an async message, wait for an async response to confirm receipt Right () <- asyncCall conn (TestCallMeBackReq "hi server") asyncMessage <- takeMVar receivedAsyncMessageVar @@ -157,10 +157,10 @@ testSyncClientCallTimeout = do readyVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) --wait for server to be ready (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port x <- callTimeout @_ @Int (Just 500) conn (DelayMicrosecondsReq 1000) assertEqual "client sync timeout" (Left TimeoutError) x close conn @@ -170,10 +170,10 @@ testSyncException = do readyVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port ret <- call conn ThrowServerSideExceptionReq case ret of Left (ExceptionError actualExc) -> @@ -189,9 +189,9 @@ testMultithreadedClient = do readyVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port let bigString = replicate (1024 * 1000) 'x' replicateM_ 10 $ do ret <- call conn (RoundtripStringReq bigString) @@ -209,9 +209,9 @@ modifyTVar (connectionServerState sState) (+ 1)) ] serverState <- newTVarIO @Int 1 - server <- async (serveIPv4 serverHandlers serverState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 serverHandlers serverState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port ret <- call conn ChangeServerState assertEqual "server ret" (Right ()) ret serverState' <- readTVarIO serverState @@ -228,9 +228,9 @@ throw TimeoutException >> pure (1 :: Int) ) ] - server <- async (serveIPv4 serverHandlers () localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 serverHandlers () S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port ret <- call @_ @Int conn ThrowTimeout assertEqual "handler timeout exception" (Left TimeoutError) ret close conn @@ -246,10 +246,10 @@ testComplexADT = do let arg = SomeTextCon (pack "sduofhsldkfsldkfjsldkfjsdlkfjsdlfksdjlfksjdflksdjflksdjfjlsdjlfjdklskfjlsdlfk") (SomeIntCon 0 (EndCon)) readyVar <- newEmptyMVar - server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState localHostAddr 0 (Just readyVar)) + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr 0 (Just readyVar)) --wait for server to be ready (SockAddrInet port _) <- takeMVar readyVar - conn <- connectIPv4 [] localHostAddr port + conn <- connectIPv4 [] C.UnencryptedConnectionConfig localHostAddr port replicateM_ 5 $ do --make five AddTwo calls to shake out parallelism bugs res <- call conn (RoundtripSomeADTReq arg) assertEqual "complex ADT" (Right arg) res @@ -260,10 +260,10 @@ testIPv6Server = do readyVar <- newEmptyMVar - server <- async (serveIPv6 (testServerRequestHandlers Nothing) emptyServerState localHostAddr6 0 (Just readyVar)) + server <- async (serveIPv6 (testServerRequestHandlers Nothing) emptyServerState S.UnencryptedConnectionConfig localHostAddr6 0 (Just readyVar)) --wait for server to be ready (SockAddrInet6 port _ _ _) <- takeMVar readyVar - conn <- connectIPv6 [] localHostAddr6 port + conn <- connectIPv6 [] C.UnencryptedConnectionConfig localHostAddr6 port replicateM_ 5 $ do --make five AddTwo calls to shake out parallelism bugs x <- call conn (AddTwoNumbersReq 1 1) assertEqual "server request+response" (Right (2 :: Int)) x diff --git a/test/Curryer/Test/TLS.hs b/test/Curryer/Test/TLS.hs new file mode 100644 --- /dev/null +++ b/test/Curryer/Test/TLS.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE DerivingStrategies, DerivingVia, DeriveGeneric, ScopedTypeVariables #-} +module Curryer.Test.TLS where +import Test.Tasty +import Test.Tasty.HUnit +import Codec.Winery +import GHC.Generics +import Control.Concurrent.MVar +import Network.Socket (SockAddr(..)) +import Control.Concurrent.Async +import Control.Monad +import System.Directory +import System.Process +import System.FilePath +import Control.Exception +import Network.TLS (TLSException) + +import Network.RPC.Curryer.Server as S +import Network.RPC.Curryer.Client as C + +{- Setup in test/Curryer/Test/: +mkdir ca ca/certs ca/private ca/newcerts client_certs server +echo 01 > ca/serial +touch ca/index.txt +cp /usr/lib/ssl/openssl.cnf . +#modify openssl.cnf +dir = /root/mtls +new_certs_dir = $dir/certs +certificate = $dir/certs/cacert.pem +countryName_default +stateOrProvinceName_default +localityName_default +0.organizationName_default +organizationalUnitName_default +# back to shell +# Generate the private key for the CA certificate +openssl genrsa -out ca/private/cakey.pem 4096 +# Create the CA certificate +openssl req -new -x509 -days 3650 -config openssl.cnf -key ca/private/cakey.pem -out ca/certs/cacert.pem +# Generate the private key for the client. +openssl genrsa -out client_certs/client.key.pem 4096 +# Generating a Certificate Signing Request (CSR) for the Client +# Remember to revise the Common Name (CN) to match the client's hostname, e.g., "client.yourdomain.com." +openssl req -new -key client_certs/client.key.pem -out ca/client.csr +# Creating the Client Certificate +openssl ca -config openssl.cnf -days 1650 -notext -batch -in ca/client.csr -out client_certs/client.cert.pem +# Generate the private key for the server +openssl genrsa -out server/server.key.pem 4096 +# Generating a Certificate Signing Request (CSR) for the Server. +# Remember to revise the Common Name (CN) to match the server's hostname, e.g., "server.yourdomain.com." +openssl req -new -key server/server.key.pem -out server/server.csr +# Creating the Server Certificate +openssl ca -config openssl.cnf -days 1650 -notext -batch -in server/server.csr -out server.cert.pem + +#validate tls connection +#open server tls socket +openssl s_server -accept 3000 -CAfile ca/certs/cacert.pem -cert server_certs/server.cert.pem -key /root/server_certs/server.key.pem -state +#connect client tls socket +openssl s_client -connect 127.0.0.1:3000 -key client_certs/client.key.pem -cert client_certs/client.cert.pem -CAfile ca/certs/cacert.pem -state + +-} + +testTree :: TestTree +testTree = withResource setupOpenSSL cleanupOpenSSL $ \_certdir -> + testGroup "tls" [ + testCase "simple request and response" testSimpleCall, + testCase "mutual TLS" testMutualTLS, + testCase "test rejected anonymous client" testRejectedAnonymousClient + ] + +setupOpenSSL :: IO FilePath +setupOpenSSL = do + let top = "test/Curryer/Test/pems" + topExists <- doesPathExist top + when topExists (removeDirectoryRecursive top) + createDirectory top + forM_ ["client", "server", "ca", "ca/private", "ca/newcerts", "ca/certs"] $ \d -> + createDirectoryIfMissing True (top d) + writeFile (top "ca/serial") "01" + writeFile (top "ca/index.txt") "" + --openssl.cnf is in the repo already + -- CA + -- generate the private key for the self-signed certificate authority + let serverSubject = "/C=US/ST=DC/O=testo/CN=localhost" + clientSubject = "/C=US/ST=DC/O=testo/OU=testou/CN=localclient" + sslconfig = "test/Curryer/Test/openssl.cnf" + callProcess "openssl" ["genrsa", "-out", top "ca/private/cakey.pem", "4096"] + callProcess "openssl" ["req", "-new", "-x509", "-nodes", "-days", "3650", + "-config", sslconfig, + "-key", top "ca/private/cakey.pem", + "-out", top "ca/certs/cacert.pem", + "-subj", serverSubject] + -- SERVER + -- generate the server's private key + callProcess "openssl" ["genrsa", "-out", top "server/server.key.pem", "4096"] + -- generate CSR + callProcess "openssl" ["req", "-new", + "-key", top "server/server.key.pem", + "-out", top "server/server.csr", + "-subj", serverSubject] + -- generate server certificate + callProcess "openssl" ["ca", + "-config", sslconfig, + "-days", "1650", + "-notext", "-batch", "-in", top "server/server.csr", + "-out", top "server/server.cert.pem"] + + -- CLIENT + -- generate private key + callProcess "openssl" ["genrsa", "-out", top "client/client.key.pem", "4096"] + -- generate client CSR + callProcess "openssl" ["req", "-new", + "-key", top "client/client.key.pem", + "-out", top "ca/client.csr", "-nodes", "-subj", clientSubject] + -- generate client certificate + callProcess "openssl" ["ca", "-config", sslconfig, + "-days", "1650", + "-notext", "-batch", + "-in", top "ca/client.csr", + "-out", top "client/client.cert.pem"] + pure top + +cleanupOpenSSL :: FilePath -> IO () +cleanupOpenSSL certdir = + removeDirectoryRecursive certdir + +data AddTwoNumbersReq = AddTwoNumbersReq Int Int + deriving (Generic, Show) + deriving Serialise via WineryVariant AddTwoNumbersReq + +data GetRoleName = GetRoleName + deriving (Generic, Show) + deriving Serialise via WineryVariant GetRoleName + +testServerRequestHandlers :: Maybe (MVar String) -> RequestHandlers () +testServerRequestHandlers _mAsyncMVar = + [ RequestHandler $ \_ (AddTwoNumbersReq x y) -> pure (x + y), + RequestHandler $ \state GetRoleName -> do + --print ("request roleName"::String, connectionRoleName state) + pure (connectionRoleName state)] + + +serverConnectionConfig :: ServerConnectionConfig +serverConnectionConfig = S.EncryptedConnectionConfig + (ServerTLSConfig + {S.tlsCertInfo = certInfo, + S.tlsServerHostName = "localhost", + S.tlsServerServiceName = mempty}) AcceptAnonymousClient + where + certInfo = ServerTLSCertInfo { + x509PublicFilePath = "./test/Curryer/Test/pems/server/server.cert.pem", + S.x509CertFilePath = Just "./test/Curryer/Test/pems/ca/certs/cacert.pem", + x509PrivateFilePath = "./test/Curryer/Test/pems/server/server.key.pem" + } + +mTLSServerConnectionConfig :: ServerConnectionConfig +mTLSServerConnectionConfig = S.EncryptedConnectionConfig + (ServerTLSConfig + {S.tlsCertInfo = certInfo, + S.tlsServerHostName = "localhost", + S.tlsServerServiceName = mempty}) ClientAuthRequired + where + certInfo = ServerTLSCertInfo { + x509PublicFilePath = "./test/Curryer/Test/pems/server/server.cert.pem", + S.x509CertFilePath = Just "./test/Curryer/Test/pems/ca/certs/cacert.pem", + x509PrivateFilePath = "./test/Curryer/Test/pems/server/server.key.pem" + } + +mTLSClientConnectionConfig :: ClientConnectionConfig +mTLSClientConnectionConfig = C.EncryptedConnectionConfig + (ClientTLSConfig {C.tlsCertInfo = certData, + C.tlsServerHostName = "localhost", + C.tlsServerServiceName = mempty}) + where + certData = ClientTLSCertInfo { + x509PublicPrivateFilePaths = Just ("./test/Curryer/Test/pems/client/client.cert.pem", + "./test/Curryer/Test/pems/client/client.key.pem"), + C.x509CertFilePath = Just "./test/Curryer/Test/pems/ca/certs/cacert.pem" + } + +clientConnectionConfig :: ClientConnectionConfig +clientConnectionConfig = C.EncryptedConnectionConfig + (ClientTLSConfig {C.tlsCertInfo = certData, + C.tlsServerHostName = "localhost", + C.tlsServerServiceName = mempty}) + where + certData = ClientTLSCertInfo { + x509PublicPrivateFilePaths = Nothing, + C.x509CertFilePath = Just "./test/Curryer/Test/pems/ca/certs/cacert.pem" + } + +-- test an anonymous client connecting to a self-signed cert server +testSimpleCall :: Assertion +testSimpleCall = do + readyVar <- newEmptyMVar + let emptyServerState = () + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState serverConnectionConfig localHostAddr 0 (Just readyVar)) + --wait for server to be ready + (SockAddrInet port _) <- takeMVar readyVar + conn <- connectIPv4 [] clientConnectionConfig localHostAddr port + replicateM_ 5 $ do --make five AddTwo calls to shake out parallelism bugs + x <- call conn (AddTwoNumbersReq 1 1) + assertEqual "server request+response" (Right (2 :: Int)) x + close conn + cancel server + +-- test a mutual TLS RPC call +testMutualTLS :: Assertion +testMutualTLS = do + readyVar <- newEmptyMVar + let emptyServerState = () + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState mTLSServerConnectionConfig localHostAddr 0 (Just readyVar)) + --wait for server to be ready + (SockAddrInet port _) <- takeMVar readyVar + conn <- connectIPv4 [] mTLSClientConnectionConfig localHostAddr port + x <- call conn GetRoleName + assertEqual "get role name" (Right (Just "testou" :: Maybe String)) x + close conn + cancel server + +-- setup server expecting client certificate but the client does not provide one +testRejectedAnonymousClient :: Assertion +testRejectedAnonymousClient = do + readyVar <- newEmptyMVar + let emptyServerState = () + server <- async (serveIPv4 (testServerRequestHandlers Nothing) emptyServerState mTLSServerConnectionConfig localHostAddr 0 (Just readyVar)) + --wait for server to be ready + (SockAddrInet port _) <- takeMVar readyVar + res <- try $ do + connectIPv4 [] clientConnectionConfig localHostAddr port + case res of + Left (_exc :: TLSException) -> pure () --expected failure + Right _ -> assertFailure "expected connection failure" + cancel server diff --git a/test/Driver.hs b/test/Driver.hs --- a/test/Driver.hs +++ b/test/Driver.hs @@ -1,9 +1,11 @@ import Test.Tasty import Curryer.Test.Basic as Basic +import Curryer.Test.TLS as TLS main :: IO () main = defaultMain curryerTestTree curryerTestTree :: TestTree -curryerTestTree = testGroup "curryer" [Basic.testTree] +curryerTestTree = testGroup "curryer" [Basic.testTree, + TLS.testTree]