{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module      : Text.Pandoc.Class.IO.HTTP
Copyright   : Copyright (C) 2025 John MacFarlane
License     : GNU GPL, version 2 or above

Maintainer  : John MacFarlane <jgm@berkeley.edu>
Stability   : alpha
Portability : portable

HTTP fetching functionality for pandoc.
-}
module Text.Pandoc.Class.IO.HTTP
  ( openURL
  ) where

import Network.URI (URI(..), parseURI)
import Data.Text (Text)
import Control.Monad.IO.Class (MonadIO)
import Text.Pandoc.Class.PandocMonad (PandocMonad, extractURIData)
import Text.Pandoc.Error (PandocError (..))
import Text.Pandoc.MIME (MimeType)
import qualified Data.ByteString as B
import qualified Data.Text as T
import Control.Monad.Except (throwError)
#ifdef PANDOC_HTTP_SUPPORT
import Data.ByteString.Lazy (toChunks)
import Control.Monad.IO.Class (liftIO)
import System.Environment (getEnv)
import Data.Default (def)
import Network.Connection (TLSSettings(..))
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra as TLS
import System.X509 (getSystemCertificateStore)
import Network.HTTP.Client
       (httpLbs, Manager, responseBody, responseHeaders,
        Request(port, host, requestHeaders), parseUrlThrow, newManager, HttpException)
import Network.HTTP.Client.Internal (addProxy)
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types.Header ( hContentType )
import Network.Socket (withSocketsDo)
import Text.Pandoc.Class.CommonState (CommonState (..))
import Text.Pandoc.Class.PandocMonad ( getsCommonState, modifyCommonState, report )
import qualified Data.CaseInsensitive as CI
import System.IO.Error
import Text.Pandoc.Logging (LogMessage (..))
import qualified Control.Exception as E
import qualified Text.Pandoc.UTF8 as UTF8
#endif

#ifdef PANDOC_HTTP_SUPPORT
getManager :: (PandocMonad m, MonadIO m) => m Manager
getManager :: forall (m :: * -> *). (PandocMonad m, MonadIO m) => m Manager
getManager = do
  mbManager <- (CommonState -> Maybe Manager) -> m (Maybe Manager)
forall a. (CommonState -> a) -> m a
forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> Maybe Manager
stManager
  disableCertificateValidation <- getsCommonState stNoCheckCertificate
  case mbManager of
    Just Manager
manager -> Manager -> m Manager
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Manager
manager
    Maybe Manager
Nothing -> do
      manager <- IO Manager -> m Manager
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> m Manager) -> IO Manager -> m Manager
forall a b. (a -> b) -> a -> b
$ do
        certificateStore <- IO CertificateStore
getSystemCertificateStore
        let tlsSettings = ClientParams -> TLSSettings
TLSSettings (ClientParams -> TLSSettings) -> ClientParams -> TLSSettings
forall a b. (a -> b) -> a -> b
$
               (HostName -> ByteString -> ClientParams
TLS.defaultParamsClient HostName
"localhost.localdomain" ByteString
"80")
                  { 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
                                   (\ServiceID
_ Fingerprint
_ Certificate
_ -> ValidationCacheResult -> IO ValidationCacheResult
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ValidationCacheResult
TLS.ValidationCachePass)
                                   (\ServiceID
_ Fingerprint
_ Certificate
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                             else def
                      }
                  }
        let tlsManagerSettings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
tlsSettings  Maybe SockSettings
forall a. Maybe a
Nothing
        newManager tlsManagerSettings
      modifyCommonState $ \CommonState
st -> CommonState
st{ stManager = Just manager }
      pure manager
#endif

openURL :: (PandocMonad m, MonadIO m) => Text -> m (B.ByteString, Maybe MimeType)
openURL :: forall (m :: * -> *).
(PandocMonad m, MonadIO m) =>
Text -> m (ByteString, Maybe Text)
openURL Text
u
 | Just (URI{ uriScheme :: URI -> HostName
uriScheme = HostName
"data:",
              uriPath :: URI -> HostName
uriPath = HostName
upath }) <- HostName -> Maybe URI
parseURI (Text -> HostName
T.unpack Text
u)
     = (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString, Maybe Text) -> m (ByteString, Maybe Text))
-> (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ HostName -> (ByteString, Maybe Text)
extractURIData HostName
upath
#ifdef PANDOC_HTTP_SUPPORT
 | Bool
otherwise = do
     let toReqHeader :: (Text, Text) -> (HeaderName, ByteString)
toReqHeader (Text
n, Text
v) = (ByteString -> HeaderName
forall s. FoldCase s => s -> CI s
CI.mk (Text -> ByteString
UTF8.fromText Text
n), Text -> ByteString
UTF8.fromText Text
v)
     customHeaders <- ((Text, Text) -> (HeaderName, ByteString))
-> [(Text, Text)] -> [(HeaderName, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Text) -> (HeaderName, ByteString)
toReqHeader ([(Text, Text)] -> [(HeaderName, ByteString)])
-> m [(Text, Text)] -> m [(HeaderName, ByteString)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CommonState -> [(Text, Text)]) -> m [(Text, Text)]
forall a. (CommonState -> a) -> m a
forall (m :: * -> *) a. PandocMonad m => (CommonState -> a) -> m a
getsCommonState CommonState -> [(Text, Text)]
stRequestHeaders
     report $ Fetching u
     manager <- getManager
     res <- liftIO $ E.try $ withSocketsDo $ do
       proxy <- tryIOError (getEnv "http_proxy")
       let addProxy' Request
x = case Either IOError HostName
proxy of
                            Left IOError
_ -> Request -> m Request
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
x
                            Right HostName
pr -> HostName -> m Request
forall (m :: * -> *). MonadThrow m => HostName -> m Request
parseUrlThrow HostName
pr m Request -> (Request -> m Request) -> m Request
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Request
r ->
                                Request -> m Request
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Int -> Request -> Request
addProxy (Request -> ByteString
host Request
r) (Request -> Int
port Request
r) Request
x)
       req <- parseUrlThrow (T.unpack u) >>= addProxy'
       let req' = Request
req{requestHeaders = customHeaders ++ requestHeaders req}
       resp <- httpLbs req' manager
       return (B.concat $ toChunks $ responseBody resp,
               UTF8.toText `fmap` lookup hContentType (responseHeaders resp))

     case res of
          Right (ByteString, Maybe Text)
r -> (ByteString, Maybe Text) -> m (ByteString, Maybe Text)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString, Maybe Text)
r
          Left (HttpException
e :: HttpException)
                  -> PandocError -> m (ByteString, Maybe Text)
forall a. PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m (ByteString, Maybe Text))
-> PandocError -> m (ByteString, Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> PandocError
PandocHttpError Text
u (HostName -> Text
T.pack (HttpException -> HostName
forall a. Show a => a -> HostName
show HttpException
e))
#else
 | otherwise =
     throwError $ PandocHttpError u "pandoc was compiled without HTTP support"
#endif