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>

6 files changed, 24 insertions, 2 deletions

diff --git a/src/Text/Pandoc/App.hs b/src/Text/Pandoc/App.hs
index 899c35e23..aa75436a4 100644
--- a/src/Text/Pandoc/App.hs
+++ b/src/Text/Pandoc/App.hs
@@ -270,6 +270,8 @@ convertWithOpts opts = do
 
     mapM_ (uncurry setRequestHeader) (optRequestHeaders opts)
 
+    setNoCheckCertificate (optNoCheckCertificate opts)
+
     doc <- sourceToDoc sources >>=
               (   (if isJust (optExtractMedia opts)
                       then fillMediaBag
diff --git a/src/Text/Pandoc/App/CommandLineOptions.hs b/src/Text/Pandoc/App/CommandLineOptions.hs
index 164ef17d5..06ee73299 100644
--- a/src/Text/Pandoc/App/CommandLineOptions.hs
+++ b/src/Text/Pandoc/App/CommandLineOptions.hs
@@ -414,6 +414,11 @@ options =
                   "NAME:VALUE")
                  ""
 
+    , Option "" ["no-check-certificate"]
+                (NoArg
+                 (\opt -> return opt { optNoCheckCertificate = True }))
+                "" -- "Disable certificate validation"
+
     , Option "" ["abbreviations"]
                 (ReqArg
                  (\arg opt -> return opt { optAbbreviations = Just arg })
diff --git a/src/Text/Pandoc/App/Opt.hs b/src/Text/Pandoc/App/Opt.hs
index d4b36bef3..fb2aeab22 100644
--- a/src/Text/Pandoc/App/Opt.hs
+++ b/src/Text/Pandoc/App/Opt.hs
@@ -140,6 +140,7 @@ data Opt = Opt
     , optIncludeInHeader       :: [FilePath]       -- ^ Files to include in header
     , optResourcePath          :: [FilePath] -- ^ Path to search for images etc
     , optRequestHeaders        :: [(Text, Text)] -- ^ Headers for HTTP requests
+    , optNoCheckCertificate    :: Bool       -- ^ Disable certificate validation
     , optEol                   :: LineEnding -- ^ Style of line-endings to use
     , optStripComments         :: Bool       -- ^ Skip HTML comments
     } deriving (Generic, Show)
@@ -390,6 +391,9 @@ doOpt (k',v) = do
     "request-headers" ->
       parseYAML v >>= \x ->
              return (\o -> o{ optRequestHeaders = x })
+    "no-check-certificate" ->
+      parseYAML v >>= \x ->
+             return (\o -> o{ optNoCheckCertificate = x })
     "eol" ->
       parseYAML v >>= \x -> return (\o -> o{ optEol = x })
     "strip-comments" ->
@@ -466,6 +470,7 @@ defaultOpts = Opt
     , optIncludeInHeader       = []
     , optResourcePath          = ["."]
     , optRequestHeaders        = []
+    , optNoCheckCertificate    = False
     , optEol                   = Native
     , optStripComments         = False
     }
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}