Revert "Use openssl instead of tls in federator http2 client"

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

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

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 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

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

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

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

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

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

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