Add an option to disable certificate validation (#6156)

This commit adds the option `--no-check-certificate`, which disables certificate
checking when resources are fetched by HTTP.

Co-authored-by: Cécile Chemin <cecile.chemin@insee.fr>
Co-authored-by: Juliette Fourcot <juliette.fourcot@insee.fr>

3 files changed, 12 insertions, 2 deletions

diff --git a/src/Text/Pandoc/Class/CommonState.hs b/src/Text/Pandoc/Class/CommonState.hs
index 4a0f66859..7e1735c2b 100644
--- a/src/Text/Pandoc/Class/CommonState.hs
+++ b/src/Text/Pandoc/Class/CommonState.hs
@@ -37,6 +37,8 @@ data CommonState = CommonState
     -- ^ Absolute URL + dir of 1st source file
   , stRequestHeaders :: [(Text, Text)]
     -- ^ Headers to add for HTTP requests
+  , stNoCheckCertificate :: Bool
+    -- ^ Controls whether certificate validation is disabled
   , stMediaBag     :: MediaBag
     -- ^ Media parsed from binary containers
   , stTranslations :: Maybe (Lang, Maybe Translations)
@@ -67,6 +69,7 @@ defaultCommonState = CommonState
   , stUserDataDir = Nothing
   , stSourceURL = Nothing
   , stRequestHeaders = []
+  , stNoCheckCertificate = False
   , stMediaBag = mempty
   , stTranslations = Nothing
   , stInputFiles = []
diff --git a/src/Text/Pandoc/Class/PandocIO.hs b/src/Text/Pandoc/Class/PandocIO.hs
index 1cbfd680e..ee6a041ba 100644
--- a/src/Text/Pandoc/Class/PandocIO.hs
+++ b/src/Text/Pandoc/Class/PandocIO.hs
@@ -54,7 +54,8 @@ import Network.HTTP.Client
        (httpLbs, responseBody, responseHeaders,
         Request(port, host, requestHeaders), parseRequest, newManager)
 import Network.HTTP.Client.Internal (addProxy)
-import Network.HTTP.Client.TLS (tlsManagerSettings)
+import Network.HTTP.Client.TLS (mkManagerSettings)
+import Network.Connection (TLSSettings (..))
 import Network.HTTP.Types.Header ( hContentType )
 import Network.Socket (withSocketsDo)
 import Network.URI ( unEscapeString )
@@ -139,6 +140,7 @@ instance PandocMonad PandocIO where
    | otherwise = do
        let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
        customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
+       disableCertificateValidation <- getsCommonState stNoCheckCertificate
        report $ Fetching u
        res <- liftIO $ E.try $ withSocketsDo $ do
          let parseReq = parseRequest
@@ -149,7 +151,7 @@ instance PandocMonad PandocIO where
                                   return (addProxy (host r) (port r) x)
          req <- parseReq (T.unpack u) >>= addProxy'
          let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
-         resp <- newManager tlsManagerSettings >>= httpLbs req'
+         resp <- newManager (mkManagerSettings  (TLSSettingsSimple disableCertificateValidation False False) Nothing) >>= httpLbs req'
          return (B.concat $ toChunks $ responseBody resp,
                  UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
 
diff --git a/src/Text/Pandoc/Class/PandocMonad.hs b/src/Text/Pandoc/Class/PandocMonad.hs
index 8229668e7..991aeed41 100644
--- a/src/Text/Pandoc/Class/PandocMonad.hs
+++ b/src/Text/Pandoc/Class/PandocMonad.hs
@@ -27,6 +27,7 @@ module Text.Pandoc.Class.PandocMonad
   , report
   , setTrace
   , setRequestHeader
+  , setNoCheckCertificate
   , getLog
   , setVerbosity
   , getVerbosity
@@ -189,6 +190,10 @@ setRequestHeader name val = modifyCommonState $ \st ->
   st{ stRequestHeaders =
        (name, val) : filter (\(n,_) -> n /= name) (stRequestHeaders st)  }
 
+-- | Determine whether certificate validation is disabled
+setNoCheckCertificate :: PandocMonad m => Bool -> m ()
+setNoCheckCertificate noCheckCertificate = modifyCommonState $ \st -> st{stNoCheckCertificate = noCheckCertificate}
+
 -- | Initialize the media bag.
 setMediaBag :: PandocMonad m => MediaBag -> m ()
 setMediaBag mb = modifyCommonState $ \st -> st{stMediaBag = mb}