Use openssl instead of tls in federator http2 client

changelog.d/6-federation/openssl

@@ -0,0 +1 @@
+Fix bug with asset downloads and large federated responses

libs/wire-api-federation/default.nix

@@ -15,6 +15,7 @@
 , errors
 , exceptions
 , gitignoreSource
+, HsOpenSSL
 , hspec
 , hspec-discover
 , http-media
@@ -67,6 +68,7 @@ mkDerivation {
     either
     errors
     exceptions
+    HsOpenSSL
     http-media
     http-types
     http2

libs/wire-api-federation/src/Wire/API/Federation/Client.hs

@@ -47,6 +47,7 @@ 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
@@ -58,8 +59,9 @@ 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
@@ -122,7 +124,7 @@ connectSocket hostname port =
     $ getSocketFamilyTCP hostname port NS.AF_UNSPEC
 
 performHTTP2Request ::
-  Maybe TLS.ClientParams ->
+  Maybe SSLContext ->
   HTTP2.Request ->
   ByteString ->
   Int ->
@@ -138,34 +140,42 @@ performHTTP2Request mtlsConfig req hostname port = try $ do
     pure $ resp $> foldMap byteString b
 
 withHTTP2Request ::
-  Maybe TLS.ClientParams ->
+  Maybe SSLContext ->
   HTTP2.Request ->
   ByteString ->
   Int ->
   (StreamingResponse -> IO a) ->
   IO a
-withHTTP2Request mtlsConfig req hostname port k = do
+withHTTP2Request mSSLCtx req hostname port k = do
   let clientConfig =
         HTTP2.ClientConfig
-          "https"
-          hostname
-          {- cacheLimit: -} 20
+          { HTTP2.scheme = "https",
+            HTTP2.authority = hostname,
+            HTTP2.cacheLimit = 20
+          }
   E.handle (E.throw . FederatorClientHTTP2Exception) $
     bracket (connectSocket hostname port) NS.close $ \sock -> do
-      let withHTTP2Config k' = case mtlsConfig of
+      let withHTTP2Config k' = case mSSLCtx of
             Nothing -> bracket (HTTP2.allocSimpleConfig sock 4096) HTTP2.freeSimpleConfig 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'
+            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'
       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 ->
@@ -351,21 +361,22 @@ versionNegotiation =
 freeTLSConfig :: HTTP2.Config -> IO ()
 freeTLSConfig cfg = free (HTTP2.confWriteBuffer cfg)
 
-allocTLSConfig :: TLS.Context -> HTTP2.BufferSize -> IO HTTP2.Config
-allocTLSConfig ctx bufsize = do
+allocTLSConfig :: SSL -> HTTP2.BufferSize -> IO HTTP2.Config
+allocTLSConfig ssl bufsize = do
   buf <- mallocBytes bufsize
   timmgr <- System.TimeManager.initialize $ 30 * 1000000
   ref <- newIORef mempty
-  let readData :: Int -> IO ByteString
-      readData n = do
+  let 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
+            -- Handling SSL.ConnectionAbruptlyTerminated as a stream end
+            -- (some sites terminate SSL connection right after returning the data).
+            chunk' <- SSL.read ssl n `catch` \(_ :: SSL.ConnectionAbruptlyTerminated) -> pure mempty
             if BS.null chunk'
               then pure chunk
               else do
@@ -375,7 +386,7 @@ allocTLSConfig ctx bufsize = do
     HTTP2.Config
       { HTTP2.confWriteBuffer = buf,
         HTTP2.confBufferSize = bufsize,
-        HTTP2.confSendAll = TLS.sendData ctx . LBS.fromStrict,
+        HTTP2.confSendAll = SSL.write ssl,
         HTTP2.confReadN = readData,
         HTTP2.confPositionReadMaker = HTTP2.defaultPositionReadMaker,
         HTTP2.confTimeoutManager = timmgr

libs/wire-api-federation/src/Wire/API/Federation/Error.hs

@@ -85,16 +85,16 @@ 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
 
 -- | Transport-layer errors in federator client.
 data FederatorClientHTTP2Error
   = FederatorClientNoStatusCode
   | FederatorClientHTTP2Exception HTTP2.HTTP2Error
-  | FederatorClientTLSException TLSException
+  | FederatorClientTLSException SomeSSLException
   | FederatorClientConnectionError IOException
   deriving (Show, Typeable)
 
@@ -213,7 +213,7 @@ federationRemoteHTTP2Error (FederatorClientTLSException e) =
   Wai.mkError
     (HTTP.mkStatus 525 "SSL Handshake Failure")
     "federation-tls-error"
-    (LT.fromStrict (displayTLSException e))
+    (LT.pack (displayException e))
 federationRemoteHTTP2Error (FederatorClientConnectionError e) =
   Wai.mkError
     federatorConnectionRefusedStatus
@@ -241,22 +241,6 @@ 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

libs/wire-api-federation/wire-api-federation.cabal

@@ -86,6 +86,7 @@ library
     , either
     , errors
     , exceptions
+    , HsOpenSSL
     , http-media
     , http-types
     , http2

services/federator/default.nix

@@ -25,6 +25,7 @@
 , filepath
 , gitignoreSource
 , hinotify
+, HsOpenSSL
 , hspec
 , http-client
 , http-client-openssl
@@ -104,6 +105,7 @@ mkDerivation {
     extended
     filepath
     hinotify
+    HsOpenSSL
     http-client
     http-client-openssl
     http-media
@@ -166,6 +168,7 @@ mkDerivation {
     extended
     filepath
     hinotify
+    HsOpenSSL
     hspec
     http-client
     http-client-openssl
@@ -233,6 +236,7 @@ mkDerivation {
     extended
     filepath
     hinotify
+    HsOpenSSL
     http-client
     http-client-openssl
     http-media

services/federator/exec/Main.hs

@@ -22,10 +22,11 @@ where
 
 import Federator.Run (run)
 import Imports
+import OpenSSL
 import Util.Options (getOptions)
 
 main :: IO ()
-main = do
+main = withOpenSSL $ do
   let desc = "Federation Service"
       defaultPath = "/etc/wire/federator/conf/federator.yaml"
   options <- getOptions desc Nothing defaultPath

services/federator/federator.cabal

@@ -116,6 +116,7 @@ library
     , extended
     , filepath
     , hinotify
+    , HsOpenSSL
     , http-client
     , http-client-openssl
     , http-media
@@ -210,63 +211,11 @@ executable federator
     -Wredundant-constraints
 
   build-depends:
-      aeson
-    , async
-    , base
-    , bilge
-    , binary
-    , bytestring
-    , bytestring-conversion
-    , constraints
-    , containers
-    , data-default
-    , dns
-    , dns-util
-    , either
-    , exceptions
-    , extended
+      base
     , federator
-    , filepath
-    , hinotify
-    , http-client
-    , http-client-openssl
-    , http-media
-    , http-types
-    , http2
+    , HsOpenSSL
     , 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
 
@@ -323,7 +272,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
+    -Wredundant-constraints -threaded -with-rtsopts=-N1
 
   build-depends:
       aeson
@@ -347,6 +296,7 @@ executable federator-integration
     , federator
     , filepath
     , hinotify
+    , HsOpenSSL
     , hspec
     , http-client
     , http-client-openssl
@@ -478,6 +428,7 @@ test-suite federator-tests
     , federator
     , filepath
     , hinotify
+    , HsOpenSSL
     , http-client
     , http-client-openssl
     , http-media

services/federator/src/Federator/Env.hs

@@ -24,21 +24,15 @@ 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 qualified Network.TLS as TLS
+import OpenSSL.Session (SSLContext)
 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,
@@ -47,8 +41,7 @@ data Env = Env
     _runSettings :: RunSettings,
     _service :: Component -> Endpoint,
     _httpManager :: HTTP.Manager,
-    _tls :: IORef TLSSettings
+    _sslContext :: IORef SSLContext
   }
 
-makeLenses ''TLSSettings
 makeLenses ''Env