diff --git a/libs/wire-api-federation/default.nix b/libs/wire-api-federation/default.nix index 9c2429d49f..35d74d4b0c 100644 --- a/libs/wire-api-federation/default.nix +++ b/libs/wire-api-federation/default.nix @@ -15,7 +15,6 @@ , errors , exceptions , gitignoreSource -, HsOpenSSL , hspec , hspec-discover , http-media @@ -68,7 +67,6 @@ mkDerivation { either errors exceptions - HsOpenSSL http-media http-types http2 diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs index 0d2b32f987..fb77e352a0 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Client.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Client.hs @@ -47,7 +47,6 @@ import Data.Domain import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Streaming.Network -import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text import qualified Data.Text.Lazy.Encoding as LText @@ -59,9 +58,8 @@ import qualified Network.HTTP.Media as HTTP import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP2.Client as HTTP2 import qualified Network.Socket as NS +import qualified Network.TLS as TLS import qualified Network.Wai.Utilities.Error as Wai -import OpenSSL.Session (SSL, SSLContext) -import qualified OpenSSL.Session as SSL import Servant.Client import Servant.Client.Core import Servant.Types.SourceT @@ -124,7 +122,7 @@ connectSocket hostname port = $ getSocketFamilyTCP hostname port NS.AF_UNSPEC performHTTP2Request :: - Maybe SSLContext -> + Maybe TLS.ClientParams -> HTTP2.Request -> ByteString -> Int -> @@ -140,42 +138,34 @@ performHTTP2Request mtlsConfig req hostname port = try $ do pure $ resp $> foldMap byteString b withHTTP2Request :: - Maybe SSLContext -> + Maybe TLS.ClientParams -> HTTP2.Request -> ByteString -> Int -> (StreamingResponse -> IO a) -> IO a -withHTTP2Request mSSLCtx req hostname port k = do +withHTTP2Request mtlsConfig req hostname port k = do let clientConfig = HTTP2.ClientConfig - { HTTP2.scheme = "https", - HTTP2.authority = hostname, - HTTP2.cacheLimit = 20 - } + "https" + hostname + {- cacheLimit: -} 20 E.handle (E.throw . FederatorClientHTTP2Exception) $ bracket (connectSocket hostname port) NS.close $ \sock -> do - let withHTTP2Config k' = case mSSLCtx of + let withHTTP2Config k' = case mtlsConfig of Nothing -> bracket (HTTP2.allocSimpleConfig sock 4096) HTTP2.freeSimpleConfig k' - Just sslCtx -> do - ssl <- E.handle (E.throw . FederatorClientTLSException) $ do - ssl <- SSL.connection sslCtx sock - -- We need to strip trailing dot because openssl doesn't ignore - -- it. https://github.com/openssl/openssl/issues/11560 - let hostnameStr = - Text.unpack $ case Text.decodeUtf8 hostname of - (Text.stripSuffix "." -> Just withoutTrailingDot) -> withoutTrailingDot - noTrailingDot -> noTrailingDot - SSL.setTlsextHostName ssl hostnameStr - SSL.enableHostnameValidation ssl hostnameStr - SSL.connect ssl - pure ssl - bracket (allocTLSConfig ssl 4096) freeTLSConfig k' + -- FUTUREWORK(federation): Use openssl + Just tlsConfig -> do + ctx <- E.handle (E.throw . FederatorClientTLSException) $ do + ctx <- TLS.contextNew sock tlsConfig + TLS.handshake ctx + pure ctx + bracket (allocTLSConfig ctx 4096) freeTLSConfig k' withHTTP2Config $ \conf -> do HTTP2.run clientConfig conf $ \sendRequest -> sendRequest req $ \resp -> do let headers = headersFromTable (HTTP2.responseHeaders resp) - result = fromAction BS.null $ HTTP2.getResponseBodyChunk resp + result = fromAction BS.null (HTTP2.getResponseBodyChunk resp) case HTTP2.responseStatus resp of Nothing -> E.throw FederatorClientNoStatusCode Just status -> @@ -361,23 +351,31 @@ versionNegotiation = freeTLSConfig :: HTTP2.Config -> IO () freeTLSConfig cfg = free (HTTP2.confWriteBuffer cfg) -allocTLSConfig :: SSL -> HTTP2.BufferSize -> IO HTTP2.Config -allocTLSConfig ssl bufsize = do +allocTLSConfig :: TLS.Context -> HTTP2.BufferSize -> IO HTTP2.Config +allocTLSConfig ctx bufsize = do buf <- mallocBytes bufsize timmgr <- System.TimeManager.initialize $ 30 * 1000000 + ref <- newIORef mempty let readData :: Int -> IO ByteString - -- Sometimes the frame header says that the payload length is 0. Reading 0 - -- bytes multiple times seems to be causing errors in openssl. I cannot - -- figure out why. The previous implementation didn't try to read from the - -- socket when trying to read 0 bytes, so special handling for 0 maintains - -- that behaviour. - readData 0 = pure "" - readData n = SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty + readData n = do + chunk <- readIORef ref + if BS.length chunk >= n + then case BS.splitAt n chunk of + (result, chunk') -> do + writeIORef ref chunk' + pure result + else do + chunk' <- TLS.recvData ctx + if BS.null chunk' + then pure chunk + else do + modifyIORef ref (<> chunk') + readData n pure HTTP2.Config { HTTP2.confWriteBuffer = buf, HTTP2.confBufferSize = bufsize, - HTTP2.confSendAll = SSL.write ssl, + HTTP2.confSendAll = TLS.sendData ctx . LBS.fromStrict, HTTP2.confReadN = readData, HTTP2.confPositionReadMaker = HTTP2.defaultPositionReadMaker, HTTP2.confTimeoutManager = timmgr diff --git a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs index 6cc12cdeda..b56149ae48 100644 --- a/libs/wire-api-federation/src/Wire/API/Federation/Error.hs +++ b/libs/wire-api-federation/src/Wire/API/Federation/Error.hs @@ -85,8 +85,8 @@ import Imports import Network.HTTP.Types.Status import qualified Network.HTTP.Types.Status as HTTP import qualified Network.HTTP2.Frame as HTTP2 +import Network.TLS import qualified Network.Wai.Utilities.Error as Wai -import OpenSSL.Session (SomeSSLException) import Servant.Client import Wire.API.Error @@ -94,7 +94,7 @@ import Wire.API.Error data FederatorClientHTTP2Error = FederatorClientNoStatusCode | FederatorClientHTTP2Exception HTTP2.HTTP2Error - | FederatorClientTLSException SomeSSLException + | FederatorClientTLSException TLSException | FederatorClientConnectionError IOException deriving (Show, Typeable) @@ -213,7 +213,7 @@ federationRemoteHTTP2Error (FederatorClientTLSException e) = Wai.mkError (HTTP.mkStatus 525 "SSL Handshake Failure") "federation-tls-error" - (LT.pack (displayException e)) + (LT.fromStrict (displayTLSException e)) federationRemoteHTTP2Error (FederatorClientConnectionError e) = Wai.mkError federatorConnectionRefusedStatus @@ -241,6 +241,22 @@ federationRemoteResponseError status = <> LT.pack (show (HTTP.statusCode status)) ) +displayTLSException :: TLSException -> Text +displayTLSException (Terminated _ reason err) = T.pack reason <> ": " <> displayTLSError err +displayTLSException (HandshakeFailed err) = T.pack "handshake failed: " <> displayTLSError err +displayTLSException ConnectionNotEstablished = T.pack "connection not established" + +displayTLSError :: TLSError -> Text +displayTLSError (Error_Misc msg) = T.pack msg +displayTLSError (Error_Protocol (msg, _, _)) = "protocol error: " <> T.pack msg +displayTLSError (Error_Certificate msg) = "certificate error: " <> T.pack msg +displayTLSError (Error_HandshakePolicy msg) = "handshake policy error: " <> T.pack msg +displayTLSError Error_EOF = "end-of-file error" +displayTLSError (Error_Packet msg) = "packet error: " <> T.pack msg +displayTLSError (Error_Packet_unexpected actual expected) = + "unexpected packet: " <> T.pack expected <> ", " <> "got " <> T.pack actual +displayTLSError (Error_Packet_Parsing msg) = "packet parsing error: " <> T.pack msg + federationServantErrorToWai :: ClientError -> Wai.Error federationServantErrorToWai (DecodeFailure msg _) = federationInvalidBody msg -- the following error is never thrown by federator client diff --git a/libs/wire-api-federation/wire-api-federation.cabal b/libs/wire-api-federation/wire-api-federation.cabal index 42151f8e48..3b6c4cf79c 100644 --- a/libs/wire-api-federation/wire-api-federation.cabal +++ b/libs/wire-api-federation/wire-api-federation.cabal @@ -86,7 +86,6 @@ library , either , errors , exceptions - , HsOpenSSL , http-media , http-types , http2 diff --git a/services/federator/default.nix b/services/federator/default.nix index 3c46834024..f274290059 100644 --- a/services/federator/default.nix +++ b/services/federator/default.nix @@ -25,7 +25,6 @@ , filepath , gitignoreSource , hinotify -, HsOpenSSL , hspec , http-client , http-client-openssl @@ -105,7 +104,6 @@ mkDerivation { extended filepath hinotify - HsOpenSSL http-client http-client-openssl http-media @@ -168,7 +166,6 @@ mkDerivation { extended filepath hinotify - HsOpenSSL hspec http-client http-client-openssl @@ -236,7 +233,6 @@ mkDerivation { extended filepath hinotify - HsOpenSSL http-client http-client-openssl http-media diff --git a/services/federator/exec/Main.hs b/services/federator/exec/Main.hs index f0badd532e..bc35cda243 100644 --- a/services/federator/exec/Main.hs +++ b/services/federator/exec/Main.hs @@ -22,11 +22,10 @@ where import Federator.Run (run) import Imports -import OpenSSL import Util.Options (getOptions) main :: IO () -main = withOpenSSL $ do +main = do let desc = "Federation Service" defaultPath = "/etc/wire/federator/conf/federator.yaml" options <- getOptions desc Nothing defaultPath diff --git a/services/federator/federator.cabal b/services/federator/federator.cabal index c72fbcb7a9..ddd6c4f882 100644 --- a/services/federator/federator.cabal +++ b/services/federator/federator.cabal @@ -116,7 +116,6 @@ library , extended , filepath , hinotify - , HsOpenSSL , http-client , http-client-openssl , http-media @@ -211,11 +210,63 @@ executable federator -Wredundant-constraints build-depends: - base + aeson + , async + , base + , bilge + , binary + , bytestring + , bytestring-conversion + , constraints + , containers + , data-default + , dns + , dns-util + , either + , exceptions + , extended , federator - , HsOpenSSL + , filepath + , hinotify + , http-client + , http-client-openssl + , http-media + , http-types + , http2 , imports + , kan-extensions + , lens + , metrics-core + , metrics-wai + , mtl + , network + , network-uri + , pem + , polysemy + , polysemy-wire-zoo + , retry + , servant + , servant-client-core + , streaming-commons + , string-conversions + , text + , time-manager + , tinylog + , tls , types-common + , unix + , uri-bytestring + , uuid + , wai + , wai-utilities + , warp + , warp-tls + , wire-api + , wire-api-federation + , x509 + , x509-store + , x509-system + , x509-validation default-language: Haskell2010 @@ -272,7 +323,7 @@ executable federator-integration ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path - -Wredundant-constraints -threaded -with-rtsopts=-N1 + -Wredundant-constraints build-depends: aeson @@ -296,7 +347,6 @@ executable federator-integration , federator , filepath , hinotify - , HsOpenSSL , hspec , http-client , http-client-openssl @@ -428,7 +478,6 @@ test-suite federator-tests , federator , filepath , hinotify - , HsOpenSSL , http-client , http-client-openssl , http-media diff --git a/services/federator/src/Federator/Env.hs b/services/federator/src/Federator/Env.hs index 3ffb798c9b..1ce2a6c162 100644 --- a/services/federator/src/Federator/Env.hs +++ b/services/federator/src/Federator/Env.hs @@ -24,15 +24,21 @@ module Federator.Env where import Bilge (RequestId) import Control.Lens (makeLenses) import Data.Metrics (Metrics) +import Data.X509.CertificateStore import Federator.Options (RunSettings) import Imports import Network.DNS.Resolver (Resolver) import qualified Network.HTTP.Client as HTTP -import OpenSSL.Session (SSLContext) +import qualified Network.TLS as TLS import qualified System.Logger.Class as LC import Util.Options import Wire.API.Federation.Component +data TLSSettings = TLSSettings + { _caStore :: CertificateStore, + _creds :: TLS.Credential + } + data Env = Env { _metrics :: Metrics, _applog :: LC.Logger, @@ -41,7 +47,8 @@ data Env = Env _runSettings :: RunSettings, _service :: Component -> Endpoint, _httpManager :: HTTP.Manager, - _sslContext :: IORef SSLContext + _tls :: IORef TLSSettings } +makeLenses ''TLSSettings makeLenses ''Env diff --git a/services/federator/src/Federator/InternalServer.hs b/services/federator/src/Federator/InternalServer.hs index 76d0fdd443..e43fbdd6fb 100644 --- a/services/federator/src/Federator/InternalServer.hs +++ b/services/federator/src/Federator/InternalServer.hs @@ -1,5 +1,5 @@ {-# LANGUAGE PartialTypeSignatures #-} -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures -Wno-unused-imports #-} -- This file is part of the Wire Server implementation. -- @@ -20,22 +20,58 @@ module Federator.InternalServer where +import Control.Exception (bracketOnError) +import qualified Control.Exception as E +import Control.Lens (view) import Data.Binary.Builder import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LBS +import Data.Default +import Data.Domain (domainText) +import Data.Either.Validation (Validation (..)) import qualified Data.Text as Text -import Federator.Env +import qualified Data.Text.Encoding as Text +import Data.X509.CertificateStore +import Federator.App (runAppT) +import Federator.Discovery (DiscoverFederator, DiscoveryFailure (DiscoveryFailureDNSError, DiscoveryFailureSrvNotAvailable), runFederatorDiscovery) +import Federator.Env (Env, TLSSettings, applog, caStore, dnsResolver, runSettings, tls) import Federator.Error.ServerError import Federator.Options (RunSettings) import Federator.Remote import Federator.Response import Federator.Validation +import Foreign (mallocBytes) +import Foreign.Marshal (free) import Imports +import Network.HPACK (BufferSize) +import Network.HTTP.Client.Internal (openSocketConnection) +import Network.HTTP.Client.OpenSSL (withOpenSSL) import qualified Network.HTTP.Types as HTTP +import qualified Network.HTTP2.Client as HTTP2 +import Network.Socket (Socket) +import qualified Network.Socket as NS +import Network.TLS +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp import Polysemy import Polysemy.Error +import qualified Polysemy.Error as Polysemy +import Polysemy.IO (embedToMonadIO) import Polysemy.Input +import qualified Polysemy.Input as Polysemy +import qualified Polysemy.Resource as Polysemy +import Polysemy.TinyLog (TinyLog) +import qualified Polysemy.TinyLog as Log +import Servant.Client.Core +import qualified System.TimeManager as T +import qualified System.X509 as TLS import Wire.API.Federation.Component +import Wire.Network.DNS.Effect (DNSLookup) +import qualified Wire.Network.DNS.Effect as Lookup +import Wire.Network.DNS.SRV (SrvTarget (..)) data RequestData = RequestData { rdTargetDomain :: Text, diff --git a/services/federator/src/Federator/Monitor.hs b/services/federator/src/Federator/Monitor.hs index 6a6bcce8df..af5049d2f8 100644 --- a/services/federator/src/Federator/Monitor.hs +++ b/services/federator/src/Federator/Monitor.hs @@ -23,20 +23,20 @@ module Federator.Monitor where import Control.Exception (bracket, throw) +import Federator.Env (TLSSettings (..)) import Federator.Monitor.Internal import Federator.Options (RunSettings (..)) import Imports -import OpenSSL.Session (SSLContext) import qualified Polysemy import qualified Polysemy.Error as Polysemy import System.Logger (Logger) -mkTLSSettingsOrThrow :: RunSettings -> IO SSLContext -mkTLSSettingsOrThrow = Polysemy.runM . runEither . Polysemy.runError @FederationSetupError . mkSSLContext +mkTLSSettingsOrThrow :: RunSettings -> IO TLSSettings +mkTLSSettingsOrThrow = Polysemy.runM . runEither . Polysemy.runError @FederationSetupError . mkTLSSettings where runEither = (either (Polysemy.embed @IO . throw) pure =<<) -withMonitor :: Logger -> IORef SSLContext -> RunSettings -> IO a -> IO a +withMonitor :: Logger -> IORef TLSSettings -> RunSettings -> IO a -> IO a withMonitor logger tlsVar rs action = bracket ( runSemDefault diff --git a/services/federator/src/Federator/Monitor/Internal.hs b/services/federator/src/Federator/Monitor/Internal.hs index d49248472f..34f85a0b6f 100644 --- a/services/federator/src/Federator/Monitor/Internal.hs +++ b/services/federator/src/Federator/Monitor/Internal.hs @@ -24,13 +24,15 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text +import qualified Data.X509 as X509 +import Data.X509.CertificateStore +import Federator.Env (TLSSettings (..)) import Federator.Options (RunSettings (..)) import GHC.Foreign (peekCStringLen, withCStringLen) import GHC.IO.Encoding (getFileSystemEncoding) import Imports -import OpenSSL.Session (SSLContext) -import qualified OpenSSL.Session as SSL -import Polysemy (Embed, Member, Members, Sem, embed) +import qualified Network.TLS as TLS +import Polysemy (Embed, Member, Sem, embed) import qualified Polysemy import qualified Polysemy.Error as Polysemy import Polysemy.Final (Final) @@ -43,12 +45,13 @@ import System.Logger (Logger) import qualified System.Logger.Message as Log import System.Posix.ByteString (RawFilePath) import System.Posix.Files +import System.X509 import Wire.Arbitrary import qualified Wire.Sem.Logger.TinyLog as Log data Monitor = Monitor { monINotify :: INotify, - monTLS :: IORef SSLContext, + monTLS :: IORef TLSSettings, monWatches :: IORef Watches, monSettings :: RunSettings, monHandler :: WatchedPath -> Event -> IO (), @@ -153,7 +156,7 @@ mkMonitor :: Member (Polysemy.Error FederationSetupError) r1 ) => (Sem r1 () -> IO ()) -> - IORef SSLContext -> + IORef TLSSettings -> RunSettings -> Sem r Monitor mkMonitor runSem tlsVar rs = do @@ -224,9 +227,9 @@ applyAction :: Action -> Sem r () applyAction monitor ReloadSettings = do - sslCtx' <- mkSSLContext (monSettings monitor) + tls' <- mkTLSSettings (monSettings monitor) Log.info $ Log.msg ("updating TLS settings" :: Text) - embed @IO $ atomicWriteIORef (monTLS monitor) sslCtx' + embed @IO $ atomicWriteIORef (monTLS monitor) tls' applyAction monitor (ReplaceWatch path) = do watches <- readIORef (monWatches monitor) case Map.lookup path watches of @@ -336,86 +339,63 @@ watchedDirs resolve path = do pure (dirs0 ++ dirs1) data FederationSetupError - = InvalidCAStore FilePath String + = InvalidCAStore FilePath | InvalidClientCertificate String - | InvalidClientPrivateKey String - | CertificateAndPrivateKeyDoNotMatch FilePath FilePath - | SSLException SSL.SomeSSLException deriving (Show) instance Exception FederationSetupError showFederationSetupError :: FederationSetupError -> Text -showFederationSetupError (InvalidCAStore path msg) = "invalid CA store: " <> Text.pack path <> ", error: " <> Text.pack msg +showFederationSetupError (InvalidCAStore path) = "invalid CA store: " <> Text.pack path showFederationSetupError (InvalidClientCertificate msg) = Text.pack msg -showFederationSetupError (InvalidClientPrivateKey msg) = Text.pack msg -showFederationSetupError (CertificateAndPrivateKeyDoNotMatch cert key) = Text.pack $ "Certificate and private key do not match, certificate: " <> cert <> ", private key: " <> key -showFederationSetupError (SSLException exc) = Text.pack $ "Unexpected SSL Exception: " <> displayException exc -mkSSLContext :: +mkTLSSettings :: ( Member (Embed IO) r, Member (Polysemy.Error FederationSetupError) r ) => RunSettings -> - Sem r SSLContext -mkSSLContext settings = do - ctx <- mkSSLContextWithoutCert settings - - Polysemy.fromExceptionVia @SomeException (InvalidClientCertificate . displayException) $ - SSL.contextSetCertificateFile ctx (clientCertificate settings) - - Polysemy.fromExceptionVia @SomeException (InvalidClientPrivateKey . displayException) $ - SSL.contextSetPrivateKeyFile ctx (clientPrivateKey settings) - - privateKeyCheck <- Polysemy.fromExceptionVia @SSL.SomeSSLException SSLException $ SSL.contextCheckPrivateKey ctx - unless privateKeyCheck $ do - Polysemy.throw $ CertificateAndPrivateKeyDoNotMatch (clientCertificate settings) (clientPrivateKey settings) - - pure ctx - -mkSSLContextWithoutCert :: Members '[Embed IO, Polysemy.Error FederationSetupError] r => RunSettings -> Sem r SSLContext -mkSSLContextWithoutCert settings = do - ctx <- embed $ SSL.context - embed $ do - SSL.contextAddOption ctx SSL.SSL_OP_ALL - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv2 - SSL.contextAddOption ctx SSL.SSL_OP_NO_SSLv3 - SSL.contextAddOption ctx SSL.SSL_OP_NO_TLSv1 - - -- Settings TLS13 ciphers requires another call to openssl, this has not - -- been implemented in HsOpenSSL yet. - SSL.contextSetCiphers ctx blessedTLS12Ciphers - - SSL.contextSetALPNProtos ctx ["h2"] - - SSL.contextSetVerificationMode ctx $ - SSL.VerifyPeer - { -- vpFailIfNoPeerCert and vpClientOnce are only relevant for servers - SSL.vpFailIfNoPeerCert = False, - SSL.vpClientOnce = False, - SSL.vpCallback = Nothing - } - forM_ (remoteCAStore settings) $ \caStorePath -> - Polysemy.fromExceptionVia @SomeException (InvalidCAStore caStorePath . displayException) $ - SSL.contextSetCAFile ctx caStorePath - - when (useSystemCAStore settings) $ - embed (SSL.contextSetDefaultVerifyPaths ctx) - - pure ctx - --- Context and possible future work see --- https://wearezeta.atlassian.net/browse/FS-33 --- https://wearezeta.atlassian.net/browse/FS-444 --- https://wearezeta.atlassian.net/browse/FS-443 --- --- The current list is compliant with TR-02102-2 --- https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html -blessedTLS12Ciphers :: String -blessedTLS12Ciphers = - intercalate - ":" - [ -- For TLS 1.2 (copied from nginx ingress config): - "ECDHE-ECDSA-AES256-GCM-SHA384", - "ECDHE-RSA-AES256-GCM-SHA384" - ] + Sem r TLSSettings +mkTLSSettings settings = + TLSSettings + <$> mkCAStore settings + <*> mkCreds settings + +mkCAStore :: + ( Member (Embed IO) r, + Member (Polysemy.Error FederationSetupError) r + ) => + RunSettings -> + Sem r CertificateStore +mkCAStore settings = do + customCAStore <- fmap (fromRight mempty) . Polysemy.runError @() $ do + path <- maybe (Polysemy.throw ()) pure $ remoteCAStore settings + embed (readCertificateStore path) + >>= maybe (Polysemy.throw (InvalidCAStore path)) pure + systemCAStore <- + if useSystemCAStore settings + then embed getSystemCertificateStore + else pure mempty + pure (customCAStore <> systemCAStore) + +mkCreds :: + ( Member (Embed IO) r, + Member (Polysemy.Error FederationSetupError) r + ) => + RunSettings -> + Sem r TLS.Credential +mkCreds settings = do + creds <- + Polysemy.fromExceptionVia + @SomeException + (InvalidClientCertificate . displayException) + $ TLS.credentialLoadX509 + (clientCertificate settings) + (clientPrivateKey settings) + case creds of + Left e -> Polysemy.throw (InvalidClientCertificate e) + Right (X509.CertificateChain [], _) -> + Polysemy.throw + ( InvalidClientCertificate + "could not read client certificate" + ) + Right x -> pure x diff --git a/services/federator/src/Federator/Remote.hs b/services/federator/src/Federator/Remote.hs index 445b8e43ea..4428e47c18 100644 --- a/services/federator/src/Federator/Remote.hs +++ b/services/federator/src/Federator/Remote.hs @@ -23,23 +23,32 @@ module Federator.Remote RemoteError (..), interpretRemote, discoverAndCall, + blessedCiphers, ) where import qualified Control.Exception as E +import Control.Lens ((^.)) import Control.Monad.Codensity import Data.Binary.Builder +import Data.ByteString.Conversion (toByteString') import qualified Data.ByteString.Lazy as LBS +import Data.Default (def) import Data.Domain import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding.Error as Text +import qualified Data.X509 as X509 +import qualified Data.X509.Validation as X509 import Federator.Discovery +import Federator.Env (TLSSettings, caStore, creds) import Federator.Error +import Federator.Validation import Imports import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP2.Client as HTTP2 -import OpenSSL.Session (SSLContext) +import Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as TLS import Polysemy import Polysemy.Error import Polysemy.Input @@ -101,25 +110,26 @@ interpretRemote :: Member DiscoverFederator r, Member (Error DiscoveryFailure) r, Member (Error RemoteError) r, - Member (Input SSLContext) r + Member (Input TLSSettings) r ) => Sem (Remote ': r) a -> Sem r a interpretRemote = interpret $ \case DiscoverAndCall domain component rpc headers body -> do target@(SrvTarget hostname port) <- discoverFederatorWithError domain + settings <- input let path = LBS.toStrict . toLazyByteString $ HTTP.encodePathSegments ["federation", componentName component, rpc] -- filter out Host header, because the HTTP2 client adds it back headers' = filter ((/= "Host") . fst) headers req' = HTTP2.requestBuilder HTTP.methodPost path headers' body + tlsConfig = mkTLSConfig settings hostname port - sslCtx <- input resp <- mapError (RemoteError target) . (fromEither @FederatorClientHTTP2Error =<<) . embed $ Codensity $ \k -> E.catch - (withHTTP2Request (Just sslCtx) req' hostname (fromIntegral port) (k . Right)) + (withHTTP2Request (Just tlsConfig) req' hostname (fromIntegral port) (k . Right)) (k . Left) unless (HTTP.statusIsSuccessful (responseStatusCode resp)) $ do @@ -130,3 +140,46 @@ interpretRemote = interpret $ \case (responseStatusCode resp) (toLazyByteString bdy) pure resp + +mkTLSConfig :: TLSSettings -> ByteString -> Word16 -> TLS.ClientParams +mkTLSConfig settings hostname port = + ( defaultParamsClient + (Text.unpack (Text.decodeUtf8With Text.lenientDecode hostname)) + (toByteString' port) + ) + { TLS.clientSupported = + def + { TLS.supportedCiphers = blessedCiphers, + -- FUTUREWORK: Figure out if we can drop TLS 1.2 + TLS.supportedVersions = [TLS.TLS12, TLS.TLS13] + }, + TLS.clientHooks = + def + { TLS.onServerCertificate = + X509.validate + X509.HashSHA256 + X509.defaultHooks {X509.hookValidateName = validateDomainName} + X509.defaultChecks {X509.checkLeafKeyPurpose = [X509.KeyUsagePurpose_ServerAuth]}, + TLS.onCertificateRequest = \_ -> pure (Just (settings ^. creds)), + TLS.onSuggestALPN = pure (Just ["h2"]) -- we only support HTTP2 + }, + TLS.clientShared = def {TLS.sharedCAStore = settings ^. caStore} + } + +-- Context and possible future work see +-- https://wearezeta.atlassian.net/browse/FS-33 +-- https://wearezeta.atlassian.net/browse/FS-444 +-- https://wearezeta.atlassian.net/browse/FS-443 +-- +-- The current list is compliant to TR-02102-2 +-- https://www.bsi.bund.de/SharedDocs/Downloads/EN/BSI/Publications/TechGuidelines/TG02102/BSI-TR-02102-2.html +blessedCiphers :: [Cipher] +blessedCiphers = + [ TLS.cipher_TLS13_AES128CCM8_SHA256, + TLS.cipher_TLS13_AES128CCM_SHA256, + TLS.cipher_TLS13_AES128GCM_SHA256, + TLS.cipher_TLS13_AES256GCM_SHA384, + -- For TLS 1.2 (copied from default nginx ingress config): + TLS.cipher_ECDHE_ECDSA_AES256GCM_SHA384, + TLS.cipher_ECDHE_RSA_AES256GCM_SHA384 + ] diff --git a/services/federator/src/Federator/Response.hs b/services/federator/src/Federator/Response.hs index 0c6c30b649..edb99377f6 100644 --- a/services/federator/src/Federator/Response.hs +++ b/services/federator/src/Federator/Response.hs @@ -42,7 +42,6 @@ import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Utilities.Error as Wai import qualified Network.Wai.Utilities.Server as Wai -import OpenSSL.Session (SSLContext) import Polysemy import Polysemy.Embed import Polysemy.Error @@ -118,7 +117,7 @@ type AllEffects = DNSLookup, -- needed by DiscoverFederator ServiceStreaming, Input RunSettings, - Input SSLContext, -- needed by Remote + Input TLSSettings, -- needed by Remote Input Env, -- needed by Service Error ValidationError, Error RemoteError, @@ -143,7 +142,7 @@ runFederator env = DiscoveryFailure ] . runInputConst env - . runInputSem (embed @IO (readIORef (view sslContext env))) + . runInputSem (embed @IO (readIORef (view tls env))) . runInputConst (view runSettings env) . interpretServiceHTTP . runDNSLookupWithResolver (view dnsResolver env) diff --git a/services/federator/src/Federator/Run.hs b/services/federator/src/Federator/Run.hs index 8251db5fce..550113aff3 100644 --- a/services/federator/src/Federator/Run.hs +++ b/services/federator/src/Federator/Run.hs @@ -64,7 +64,7 @@ run opts = do bracket (newEnv opts res) closeEnv $ \env -> do let externalServer = serveInward env portExternal internalServer = serveOutward env portInternal - withMonitor (env ^. applog) (env ^. sslContext) (optSettings opts) $ do + withMonitor (env ^. applog) (env ^. tls) (optSettings opts) $ do internalServerThread <- async internalServer externalServerThread <- async externalServer void $ waitAnyCancel [internalServerThread, externalServerThread] @@ -97,7 +97,7 @@ newEnv o _dnsResolver = do _service Galley = Opt.galley o _service Cargohold = Opt.cargohold o _httpManager <- initHttpManager - _sslContext <- mkTLSSettingsOrThrow _runSettings >>= newIORef + _tls <- mkTLSSettingsOrThrow _runSettings >>= newIORef pure Env {..} closeEnv :: Env -> IO () diff --git a/services/federator/test/integration/Main.hs b/services/federator/test/integration/Main.hs index d8b4561577..b0e144f9ac 100644 --- a/services/federator/test/integration/Main.hs +++ b/services/federator/test/integration/Main.hs @@ -22,7 +22,6 @@ where import Data.String.Conversions import Imports -import OpenSSL (withOpenSSL) import System.Environment (withArgs) import qualified Test.Federator.IngressSpec import qualified Test.Federator.InwardSpec @@ -30,7 +29,7 @@ import Test.Federator.Util (TestEnv, mkEnvFromOptions) import Test.Hspec main :: IO () -main = withOpenSSL $ do +main = do (wireArgs, hspecArgs) <- partitionArgs <$> getArgs env <- withArgs wireArgs mkEnvFromOptions -- withArgs hspecArgs . hspec $ do diff --git a/services/federator/test/integration/Test/Federator/IngressSpec.hs b/services/federator/test/integration/Test/Federator/IngressSpec.hs index 806f57e53e..c580be531c 100644 --- a/services/federator/test/integration/Test/Federator/IngressSpec.hs +++ b/services/federator/test/integration/Test/Federator/IngressSpec.hs @@ -18,7 +18,6 @@ module Test.Federator.IngressSpec where import Control.Lens (view) -import Control.Monad.Catch (throwM) import Control.Monad.Codensity import qualified Data.Aeson as Aeson import Data.Binary.Builder @@ -27,13 +26,12 @@ import Data.Handle import Data.LegalHold (UserLegalHoldStatus (UserLegalHoldNoConsent)) import Data.String.Conversions (cs) import qualified Data.Text.Encoding as Text +import qualified Data.X509 as X509 import Federator.Discovery -import Federator.Monitor (FederationSetupError) -import Federator.Monitor.Internal (mkSSLContextWithoutCert) +import Federator.Env import Federator.Remote import Imports import qualified Network.HTTP.Types as HTTP -import OpenSSL.Session (SSLContext) import Polysemy import Polysemy.Embed import Polysemy.Error @@ -61,18 +59,17 @@ spec env = do _ <- putHandle brig (userId user) hdl let expectedProfile = (publicProfile user UserLegalHoldNoConsent) {profileHandle = Just (Handle hdl)} - runTestSem $ do - resp <- - liftToCodensity - . assertNoError @RemoteError - $ inwardBrigCallViaIngress - "get-user-by-handle" - (Aeson.fromEncoding (Aeson.toEncoding hdl)) - embed . lift @Codensity $ do - bdy <- streamingResponseStrictBody resp - let actualProfile = Aeson.decode (toLazyByteString bdy) - responseStatusCode resp `shouldBe` HTTP.status200 - actualProfile `shouldBe` Just expectedProfile + resp <- + runTestSem + . assertNoError @RemoteError + $ inwardBrigCallViaIngress + "get-user-by-handle" + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + liftIO $ do + bdy <- streamingResponseStrictBody resp + let actualProfile = Aeson.decode (toLazyByteString bdy) + responseStatusCode resp `shouldBe` HTTP.status200 + actualProfile `shouldBe` Just expectedProfile -- @SF.Federation @TSFI.RESTfulAPI @S2 @S3 @S7 -- @@ -90,37 +87,34 @@ spec env = do hdl <- randomHandle _ <- putHandle brig (userId user) hdl - settings <- view teSettings - sslCtxWithoutCert <- - either (throwM @_ @FederationSetupError) pure - <=< runM - . runEmbedded (liftIO @(TestFederator IO)) - . runError - $ mkSSLContextWithoutCert settings - runTestSem $ do - r <- - runError @RemoteError $ - inwardBrigCallViaIngressWithSettings - sslCtxWithoutCert - "get-user-by-handle" - (Aeson.fromEncoding (Aeson.toEncoding hdl)) - liftToCodensity . embed $ case r of - Right _ -> expectationFailure "Expected client certificate error, got response" - Left (RemoteError _ _) -> - expectationFailure "Expected client certificate error, got remote error" - Left (RemoteErrorResponse _ status _) -> status `shouldBe` HTTP.status400 + -- Remove client certificate from settings + tlsSettings0 <- view teTLSSettings + let tlsSettings = + tlsSettings0 + { _creds = case _creds tlsSettings0 of + (_, privkey) -> (X509.CertificateChain [], privkey) + } + r <- + runTestSem + . runError @RemoteError + $ inwardBrigCallViaIngressWithSettings + tlsSettings + "get-user-by-handle" + (Aeson.fromEncoding (Aeson.toEncoding hdl)) + liftIO $ case r of + Right _ -> expectationFailure "Expected client certificate error, got response" + Left (RemoteError _ _) -> + expectationFailure "Expected client certificate error, got remote error" + Left (RemoteErrorResponse _ status _) -> status `shouldBe` HTTP.status400 -- FUTUREWORK: ORMOLU_DISABLE -- @END -- ORMOLU_ENABLE -liftToCodensity :: Member (Embed (Codensity IO)) r => Sem (Embed IO ': r) a -> Sem r a -liftToCodensity = runEmbedded @IO @(Codensity IO) lift - -runTestSem :: Sem '[Input TestEnv, Embed (Codensity IO)] a -> TestFederator IO a +runTestSem :: Sem '[Input TestEnv, Embed IO] a -> TestFederator IO a runTestSem action = do e <- ask - liftIO . lowerCodensity . runM . runInputConst e $ action + liftIO . runM . runInputConst e $ action discoverConst :: SrvTarget -> Sem (DiscoverFederator ': r) a -> Sem r a discoverConst target = interpret $ \case @@ -128,29 +122,29 @@ discoverConst target = interpret $ \case DiscoverAllFederators _ -> pure (Right (pure target)) inwardBrigCallViaIngress :: - Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r => + Members [Input TestEnv, Embed IO, Error RemoteError] r => Text -> Builder -> Sem r StreamingResponse inwardBrigCallViaIngress path payload = do - sslCtx <- inputs (view teSSLContext) - inwardBrigCallViaIngressWithSettings sslCtx path payload + tlsSettings <- inputs (view teTLSSettings) + inwardBrigCallViaIngressWithSettings tlsSettings path payload inwardBrigCallViaIngressWithSettings :: - Members [Input TestEnv, Embed (Codensity IO), Error RemoteError] r => - SSLContext -> + Members [Input TestEnv, Embed IO, Error RemoteError] r => + TLSSettings -> Text -> Builder -> Sem r StreamingResponse -inwardBrigCallViaIngressWithSettings sslCtx requestPath payload = +inwardBrigCallViaIngressWithSettings tlsSettings requestPath payload = do Endpoint ingressHost ingressPort <- cfgNginxIngress . view teTstOpts <$> input originDomain <- cfgOriginDomain . view teTstOpts <$> input let target = SrvTarget (cs ingressHost) ingressPort headers = [(originDomainHeaderName, Text.encodeUtf8 originDomain)] - liftToCodensity - . runInputConst sslCtx + runInputConst tlsSettings . assertNoError @DiscoveryFailure . discoverConst target + . runEmbedded @(Codensity IO) @IO lowerCodensity . interpretRemote $ discoverAndCall (Domain "example.com") Brig requestPath headers payload diff --git a/services/federator/test/integration/Test/Federator/Util.hs b/services/federator/test/integration/Test/Federator/Util.hs index e520abadaa..30ffb56a97 100644 --- a/services/federator/test/integration/Test/Federator/Util.hs +++ b/services/federator/test/integration/Test/Federator/Util.hs @@ -43,12 +43,12 @@ import qualified Data.Text as Text import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import qualified Data.Yaml as Yaml +import Federator.Env import Federator.Options import Federator.Run import Imports import qualified Network.Connection import Network.HTTP.Client.TLS -import OpenSSL.Session (SSLContext) import qualified Options.Applicative as OPA import Polysemy import Polysemy.Error @@ -91,15 +91,13 @@ runTestFederator env = flip runReaderT env . unwrapTestFederator -- | See 'mkEnv' about what's in here. data TestEnv = TestEnv { _teMgr :: Manager, - _teSSLContext :: SSLContext, + _teTLSSettings :: TLSSettings, _teBrig :: BrigReq, _teCargohold :: CargoholdReq, -- | federator config _teOpts :: Opts, -- | integration test config - _teTstOpts :: IntegrationConfig, - -- | Settings passed to the federator - _teSettings :: RunSettings + _teTstOpts :: IntegrationConfig } type Select = TestEnv -> (Request -> Request) @@ -155,9 +153,7 @@ mkEnv _teTstOpts _teOpts = do _teMgr :: Manager <- newManager managerSettings let _teBrig = endpointToReq (cfgBrig _teTstOpts) _teCargohold = endpointToReq (cfgCargohold _teTstOpts) - -- _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts) - _teSSLContext <- mkTLSSettingsOrThrow (optSettings _teOpts) - let _teSettings = optSettings _teOpts + _teTLSSettings <- mkTLSSettingsOrThrow (optSettings _teOpts) pure TestEnv {..} destroyEnv :: HasCallStack => TestEnv -> IO () diff --git a/services/federator/test/unit/Main.hs b/services/federator/test/unit/Main.hs index fa936d392f..160cbbe28e 100644 --- a/services/federator/test/unit/Main.hs +++ b/services/federator/test/unit/Main.hs @@ -21,7 +21,6 @@ module Main where import Imports -import OpenSSL (withOpenSSL) import qualified Test.Federator.Client import qualified Test.Federator.ExternalServer import qualified Test.Federator.InternalServer @@ -34,16 +33,15 @@ import Test.Tasty main :: IO () main = - withOpenSSL $ - defaultMain $ - testGroup - "Tests" - [ Test.Federator.Options.tests, - Test.Federator.Validation.tests, - Test.Federator.Client.tests, - Test.Federator.InternalServer.tests, - Test.Federator.ExternalServer.tests, - Test.Federator.Monitor.tests, - Test.Federator.Remote.tests, - Test.Federator.Response.tests - ] + defaultMain $ + testGroup + "Tests" + [ Test.Federator.Options.tests, + Test.Federator.Validation.tests, + Test.Federator.Client.tests, + Test.Federator.InternalServer.tests, + Test.Federator.ExternalServer.tests, + Test.Federator.Monitor.tests, + Test.Federator.Remote.tests, + Test.Federator.Response.tests + ] diff --git a/services/federator/test/unit/Test/Federator/Monitor.hs b/services/federator/test/unit/Test/Federator/Monitor.hs index 1f5740fa07..e448f62f2e 100644 --- a/services/federator/test/unit/Test/Federator/Monitor.hs +++ b/services/federator/test/unit/Test/Federator/Monitor.hs @@ -19,15 +19,17 @@ module Test.Federator.Monitor (tests) where import Control.Concurrent.Chan import Control.Exception (bracket) +import Control.Lens (view) import Control.Monad.Trans.Cont import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import qualified Data.Set as Set +import Data.X509 (CertificateChain (..)) +import Federator.Env (TLSSettings (..), creds) import Federator.Monitor import Federator.Monitor.Internal import Federator.Options import Imports -import OpenSSL.Session (SSLContext) import qualified Polysemy import qualified Polysemy.Error as Polysemy import System.FilePath @@ -114,7 +116,7 @@ withKubernetesSettings = do withSilentMonitor :: Chan (Maybe FederationSetupError) -> RunSettings -> - ContT r IO (IORef SSLContext) + ContT r IO (IORef TLSSettings) withSilentMonitor reloads settings = do tlsVar <- liftIO $ newIORef (error "TLSSettings not updated before being read") void . ContT $ @@ -134,7 +136,7 @@ testMonitorChangeUpdate = reloads <- newChan evalContT $ do settings <- withSettings - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do appendFile (clientCertificate settings) "" result <- timeout timeoutMicroseconds (readChan reloads) @@ -144,6 +146,11 @@ testMonitorChangeUpdate = assertFailure ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () testMonitorReplacedChangeUpdate :: TestTree testMonitorReplacedChangeUpdate = @@ -151,18 +158,12 @@ testMonitorReplacedChangeUpdate = reloads <- newChan evalContT $ do settings <- withSettings - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do -- first replace file with a different one copyFile "test/resources/unit/localhost-dot.pem" (clientCertificate settings) - -- This will always fail because now the certificate doesn't match the - -- private key - _result0 <- timeout timeoutMicroseconds (readChan reloads) - copyFile - "test/resources/unit/localhost-dot-key.pem" - (clientPrivateKey settings) result1 <- timeout timeoutMicroseconds (readChan reloads) case result1 of Nothing -> @@ -183,6 +184,11 @@ testMonitorReplacedChangeUpdate = assertFailure ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () testMonitorOverwriteUpdate :: TestTree testMonitorOverwriteUpdate = @@ -190,18 +196,11 @@ testMonitorOverwriteUpdate = reloads <- newChan evalContT $ do settings <- withSettings - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do copyFile "test/resources/unit/localhost-dot.pem" (clientCertificate settings) - -- This will always fail because now the certificate doesn't match the - -- private key - _result0 <- timeout timeoutMicroseconds (readChan reloads) - - copyFile - "test/resources/unit/localhost-dot-key.pem" - (clientPrivateKey settings) result <- timeout timeoutMicroseconds (readChan reloads) case result of Nothing -> assertFailure "certificate not updated within the allotted time" @@ -209,6 +208,11 @@ testMonitorOverwriteUpdate = assertFailure ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () testMonitorSymlinkUpdate :: TestTree testMonitorSymlinkUpdate = @@ -216,22 +220,13 @@ testMonitorSymlinkUpdate = reloads <- newChan evalContT $ do settings <- withSymlinkSettings - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do - wd <- getWorkingDirectory - removeFile (clientCertificate settings) + wd <- getWorkingDirectory createSymbolicLink (wd "test/resources/unit/localhost-dot.pem") (clientCertificate settings) - -- This will always fail because now the certificate doesn't match the - -- private key - _result0 <- timeout timeoutMicroseconds (readChan reloads) - - removeFile (clientPrivateKey settings) - createSymbolicLink - (wd "test/resources/unit/localhost-dot-key.pem") - (clientPrivateKey settings) result <- timeout timeoutMicroseconds (readChan reloads) case result of Nothing -> assertFailure "certificate not updated within the allotted time" @@ -239,6 +234,11 @@ testMonitorSymlinkUpdate = assertFailure ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () testMonitorNestedUpdate :: TestTree testMonitorNestedUpdate = @@ -246,7 +246,7 @@ testMonitorNestedUpdate = reloads <- newChan evalContT $ do settings <- withNestedSettings 1 - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do -- make a new directory with other credentials let parent = takeDirectory (clientCertificate settings) @@ -268,6 +268,11 @@ testMonitorNestedUpdate = assertFailure ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () testMonitorDeepUpdate :: TestTree testMonitorDeepUpdate = @@ -275,7 +280,7 @@ testMonitorDeepUpdate = reloads <- newChan evalContT $ do settings <- withNestedSettings 2 - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do -- make a new directory with other credentials let root = takeDirectory (takeDirectory (takeDirectory (clientCertificate settings))) @@ -306,13 +311,19 @@ testMonitorDeepUpdate = ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + testMonitorKubernetesUpdate :: TestTree testMonitorKubernetesUpdate = do testCase "monitor updates on a kubernetes secret mount" $ do reloads <- newChan evalContT $ do settings <- withKubernetesSettings - _ <- withSilentMonitor reloads settings + tlsVar <- withSilentMonitor reloads settings liftIO $ do let root = takeDirectory (clientCertificate settings) createDirectory (root "..foo2") @@ -329,6 +340,12 @@ testMonitorKubernetesUpdate = do ("unexpected exception " <> displayException err) _ -> pure () + tls <- readIORef tlsVar + case view creds tls of + (CertificateChain [], _) -> + assertFailure "expected non-empty certificate chain" + _ -> pure () + testMonitorError :: TestTree testMonitorError = testCase "monitor returns an error when settings cannot be updated" $ do diff --git a/services/federator/test/unit/Test/Federator/Options.hs b/services/federator/test/unit/Test/Federator/Options.hs index 4c3b62e2b9..e121cd20f7 100644 --- a/services/federator/test/unit/Test/Federator/Options.hs +++ b/services/federator/test/unit/Test/Federator/Options.hs @@ -22,6 +22,7 @@ module Test.Federator.Options where import Control.Exception (try) +import Control.Lens import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson import qualified Data.ByteString.Char8 as B8 @@ -29,6 +30,7 @@ import Data.ByteString.Lazy (toStrict) import Data.Domain (Domain (..), mkDomain) import Data.String.Interpolate as QQ import qualified Data.Yaml as Yaml +import Federator.Env import Federator.Options import Federator.Run import Imports @@ -165,8 +167,10 @@ testSettings = assertFailure $ "expected invalid client certificate exception, got: " <> show e - Right _ -> - assertFailure "expected failure for non-existing client certificate, got success", + Right tlsSettings -> + assertFailure $ + "expected failure for non-existing client certificate, got: " + <> show (tlsSettings ^. creds), -- @SF.Federation @TSFI.Federate @S3 @S7 testCase "failToStartWithInvalidServerCredentials" $ do let settings = @@ -186,8 +190,10 @@ testSettings = assertFailure $ "expected invalid client certificate exception, got: " <> show e - Right _ -> - assertFailure "expected failure for invalid client certificate, got success", + Right tlsSettings -> + assertFailure $ + "expected failure for invalid client certificate, got: " + <> show (tlsSettings ^. creds), -- @END testCase "fail on invalid private key" $ do let settings = @@ -202,13 +208,15 @@ testSettings = clientCertificate: test/resources/unit/localhost.pem clientPrivateKey: test/resources/unit/invalid.pem|] try @FederationSetupError (mkTLSSettingsOrThrow settings) >>= \case - Left (InvalidClientPrivateKey _) -> pure () + Left (InvalidClientCertificate _) -> pure () Left e -> assertFailure $ "expected invalid client certificate exception, got: " <> show e - Right _ -> - assertFailure "expected failure for invalid private key, got success" + Right tlsSettings -> + assertFailure $ + "expected failure for invalid private key, got: " + <> show (tlsSettings ^. creds) ] assertParsesAs :: (HasCallStack, Eq a, FromJSON a, Show a) => a -> ByteString -> Assertion diff --git a/services/federator/test/unit/Test/Federator/Remote.hs b/services/federator/test/unit/Test/Federator/Remote.hs index 6222516069..5a4b84ea75 100644 --- a/services/federator/test/unit/Test/Federator/Remote.hs +++ b/services/federator/test/unit/Test/Federator/Remote.hs @@ -21,6 +21,7 @@ import Control.Exception (bracket) import Control.Monad.Codensity import Data.Domain import Federator.Discovery +import Federator.Env (TLSSettings) import Federator.Options import Federator.Remote import Federator.Run (mkTLSSettingsOrThrow) @@ -30,7 +31,6 @@ import Network.Wai import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.WarpTLS as Warp import Network.Wai.Utilities.MockServer (startMockServer) -import OpenSSL.Session (SSLContext) import Polysemy import Polysemy.Embed import Polysemy.Error @@ -62,29 +62,30 @@ settings = remoteCAStore = Just "test/resources/unit/unit-ca.pem" } -discoverLocalhost :: ByteString -> Int -> Sem (DiscoverFederator ': r) a -> Sem r a -discoverLocalhost hostname port = interpret $ \case +discoverLocalhost :: Int -> Sem (DiscoverFederator ': r) a -> Sem r a +discoverLocalhost port = interpret $ \case DiscoverAllFederators (Domain "localhost") -> - pure (Right (pure (SrvTarget hostname (fromIntegral port)))) + pure (Right (pure (SrvTarget "localhost" (fromIntegral port)))) DiscoverAllFederators _ -> pure (Left (DiscoveryFailureSrvNotAvailable "only localhost is supported")) DiscoverFederator (Domain "localhost") -> - pure (Right (SrvTarget hostname (fromIntegral port))) + pure (Right (SrvTarget "localhost" (fromIntegral port))) DiscoverFederator _ -> pure (Left (DiscoveryFailureSrvNotAvailable "only localhost is supported")) -assertNoRemoteError :: Either RemoteError x -> IO x -assertNoRemoteError = \case - Left err -> assertFailure $ "Unexpected remote error: " <> show err - Right x -> pure x +assertNoRemoteError :: IO (Either RemoteError x) -> IO x +assertNoRemoteError action = + action >>= \case + Left err -> assertFailure $ "Unexpected remote error: " <> show err + Right x -> pure x -mkTestCall :: SSLContext -> ByteString -> Int -> Codensity IO (Either RemoteError ()) -mkTestCall sslCtx hostname port = +mkTestCall :: TLSSettings -> Int -> IO (Either RemoteError ()) +mkTestCall tlsSettings port = runM - . runEmbedded @IO @(Codensity IO) liftIO . runError @RemoteError . void - . runInputConst sslCtx - . discoverLocalhost hostname port + . runInputConst tlsSettings + . discoverLocalhost port . assertNoError @DiscoveryFailure + . runEmbedded @(Codensity IO) @IO lowerCodensity . interpretRemote $ discoverAndCall (Domain "localhost") Brig "test" [] mempty @@ -104,23 +105,17 @@ testValidatesCertificateSuccess = [ testCase "when hostname=localhost and certificate-for=localhost" $ withMockServer certForLocalhost $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost" port) assertNoRemoteError, + assertNoRemoteError (mkTestCall tlsSettings port), testCase "when hostname=localhost. and certificate-for=localhost" $ withMockServer certForLocalhost $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost." port) assertNoRemoteError, - -- It is not very clear how to handle this, this test just exists to - -- document what we do. - -- Some discussion from author of curl: - -- https://lists.w3.org/Archives/Public/ietf-http-wg/2016JanMar/0430.html - -- - -- Perhaps it is also not possible to get a publically verifiable - -- certificate like this from any of the CAs: - -- https://github.com/certbot/certbot/issues/3718 + assertNoRemoteError (mkTestCall tlsSettings port), + -- This is a limitation of the TLS library, this test just exists to document that. testCase "when hostname=localhost. and certificate-for=localhost." $ withMockServer certForLocalhostDot $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost." port) $ \case + eitherClient <- mkTestCall tlsSettings port + case eitherClient of Left _ -> pure () Right _ -> assertFailure "Congratulations, you fixed a known issue!" ] @@ -138,14 +133,16 @@ testValidatesCertificateWrongHostname = [ testCase "when the server's certificate doesn't match the hostname" $ withMockServer certForWrongDomain $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost" port) $ \case + eitherClient <- mkTestCall tlsSettings port + case eitherClient of Left (RemoteError _ (FederatorClientTLSException _)) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x Right _ -> assertFailure "Expected connection with the server to fail", testCase "when the server's certificate does not have the server key usage flag" $ withMockServer certWithoutServerKeyUsage $ \port -> do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost" port) $ \case + eitherClient <- mkTestCall tlsSettings port + case eitherClient of Left (RemoteError _ (FederatorClientTLSException _)) -> pure () Left x -> assertFailure $ "Expected TLS failure, got: " <> show x Right _ -> assertFailure "Expected connection with the server to fail" @@ -156,7 +153,8 @@ testValidatesCertificateWrongHostname = testConnectionError :: TestTree testConnectionError = testCase "connection failures are reported correctly" $ do tlsSettings <- mkTLSSettingsOrThrow settings - runCodensity (mkTestCall tlsSettings "localhost" 1) $ \case + result <- mkTestCall tlsSettings 1 + case result of Left (RemoteError _ (FederatorClientConnectionError _)) -> pure () Left x -> assertFailure $ "Expected connection error, got: " <> show x Right _ -> assertFailure "Expected connection with the server to fail"