From 25a994df65f32ea2156c9171ec445d150ad4372c Mon Sep 17 00:00:00 2001
From: John MacFarlane <jgm@berkeley.edu>
Date: Tue, 20 Feb 2024 10:07:58 -0800
Subject: Class: openUrl TLS negotiation fixes.

With the release of TLS 2.0.0, the TLS library started requiring
Extended Main Secret for the TLS handshake. This caused problems
connecting to zotero's server and others that do not support TLS 1.3.
This commit relaxes this requirement.

Closes #9483.
---
 pandoc.cabal                |  4 +++-
 src/Text/Pandoc/Class/IO.hs | 28 +++++++++++++++++++++++++---
 2 files changed, 28 insertions(+), 4 deletions(-)

diff --git a/pandoc.cabal b/pandoc.cabal
index 4640272ce..dae62cc2a 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -528,7 +528,9 @@ library
                  xml                   >= 1.3.12   && < 1.4,
                  typst                 >= 0.5.0.1  && < 0.5.1,
                  vector                >= 0.12     && < 0.14,
-                 djot                  >= 0.1      && < 0.2
+                 djot                  >= 0.1      && < 0.2,
+                 tls                   >= 1.9.0    && < 2.1,
+                 crypton-x509-system   >= 1.6.7    && < 1.7
 
   if !os(windows)
     build-depends:  unix >= 2.4 && < 2.9
diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs
index 0e288270c..12feeeb3c 100644
--- a/src/Text/Pandoc/Class/IO.hs
+++ b/src/Text/Pandoc/Class/IO.hs
@@ -42,7 +42,9 @@ import Data.ByteString.Lazy (toChunks)
 import Data.Text (Text, pack, unpack)
 import Data.Time (TimeZone, UTCTime)
 import Data.Unique (hashUnique)
-import Network.Connection (TLSSettings (TLSSettingsSimple))
+import Network.Connection (TLSSettings(..))
+import qualified Network.TLS as TLS
+import qualified Network.TLS.Extra as TLS
 import Network.HTTP.Client
        (httpLbs, responseBody, responseHeaders,
         Request(port, host, requestHeaders), parseRequest, newManager)
@@ -69,6 +71,7 @@ import Text.Pandoc.MediaBag (MediaBag, MediaItem(..), lookupMedia, mediaItems)
 import Text.Pandoc.Walk (walk)
 import qualified Control.Exception as E
 import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T
@@ -80,6 +83,8 @@ import qualified System.Environment as Env
 import qualified System.FilePath.Glob
 import qualified System.Random
 import qualified Text.Pandoc.UTF8 as UTF8
+import Data.Default (def)
+import System.X509 (getSystemCertificateStore)
 #ifndef EMBED_DATA_FILES
 import qualified Paths_pandoc as Paths
 #endif
@@ -144,8 +149,25 @@ openURL u
                                 return (addProxy (host r) (port r) x)
        req <- parseRequest (unpack u) >>= addProxy'
        let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
-       let tlsSimple = TLSSettingsSimple disableCertificateValidation False False
-       let tlsManagerSettings = mkManagerSettings tlsSimple  Nothing
+       certificateStore <- getSystemCertificateStore
+       let tlsSettings = TLSSettings $
+              (TLS.defaultParamsClient (show $ host req')
+                                       (B8.pack $ show $ port req'))
+                 { TLS.clientSupported = def{ TLS.supportedCiphers =
+                                              TLS.ciphersuite_default
+                                            , TLS.supportedExtendedMainSecret =
+                                               TLS.AllowEMS }
+                 , TLS.clientShared = def
+                     { TLS.sharedCAStore = certificateStore
+                     , TLS.sharedValidationCache =
+                         if disableCertificateValidation
+                            then TLS.ValidationCache
+                                  (\_ _ _ -> return TLS.ValidationCachePass)
+                                  (\_ _ _ -> return ())
+                            else def
+                     }
+                 }
+       let tlsManagerSettings = mkManagerSettings tlsSettings  Nothing
        resp <- newManager tlsManagerSettings >>= httpLbs req'
        return (B.concat $ toChunks $ responseBody resp,
                UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
-- 
cgit v1.2.3