    {-# LANGUAGE NamedFieldPuns    #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE RecordWildCards   #-}

    module Dhall.Import.HTTP
        ( fetchFromHttpUrl
        , originHeadersFileExpr
        ) where

    import Control.Exception                (Exception)
    import Control.Monad.IO.Class           (MonadIO (..))
    import Control.Monad.Trans.State.Strict (StateT)
    import Data.ByteString                  (ByteString)
    import Data.CaseInsensitive             (CI)
    import Data.Dynamic                     (toDyn)
    import Data.List.NonEmpty               (NonEmpty (..))
    import Data.Text.Encoding               (decodeUtf8)
    import Dhall.Core
        ( Expr (..)
        , Directory (..)
        , File (..)
        , FilePrefix (..)
        , Import (..)
        , ImportHashed (..)
        , ImportMode (..)
        , ImportType (..)
        , Scheme (..)
        , URL (..)
        )
    import Dhall.Import.Types
    import Dhall.Parser                     (Src)
    import Dhall.URL                        (renderURL)
    import System.Directory                 (getXdgDirectory, XdgDirectory(XdgConfig))
    import System.FilePath                  (splitDirectories)

    import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..))

    import qualified Control.Exception
    import qualified Control.Monad.Trans.State.Strict as State
    import qualified Data.HashMap.Strict              as HashMap
    import qualified Data.Text                        as Text
    import qualified Data.Text.Encoding
    import qualified Data.Text.Lazy
    import qualified Data.Text.Lazy.Encoding
    import qualified Dhall.Util
    import qualified Network.HTTP.Client              as HTTP
    import qualified Network.HTTP.Types

    mkPrettyHttpException :: String -> HttpException -> PrettyHttpException
    mkPrettyHttpException :: String -> HttpException -> PrettyHttpException
    mkPrettyHttpException String
    url HttpException
    ex =
        String -> Dynamic -> PrettyHttpException
    PrettyHttpException (String -> HttpException -> String
    renderPrettyHttpException String
    url HttpException
    ex) (HttpException -> Dynamic
    forall a. Typeable a => a -> Dynamic
    toDyn HttpException
    ex)

    renderPrettyHttpException :: String -> HttpException -> String
    renderPrettyHttpException :: String -> HttpException -> String
    renderPrettyHttpException String
    _ (InvalidUrlException String
    _ String
    r) =
          String
    "\n"
      String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Invalid URL\n"
      String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
      String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String -> String
    forall a. Show a => a -> String
    show String
    r String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
    renderPrettyHttpException String
    url (HttpExceptionRequest Request
    _ HttpExceptionContent
    e) =
      case HttpExceptionContent
    e of
        ConnectionFailure SomeException
    _ ->
              String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Remote host not found\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    url String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
        InvalidDestinationHost ByteString
    host ->
              String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Invalid remote host name:\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "Host: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> String
    forall a. Show a => a -> String
    show ByteString
    host String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
        HttpExceptionContent
    ResponseTimeout ->
              String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: The remote host took too long to respond\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    url String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
        HttpExceptionContent
    ConnectionTimeout ->
              String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Connection establishment took too long\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    url String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
        StatusCodeException Response ()
    response ByteString
    body -> String
    prefix String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    suffix
          where
            prefix :: String
    prefix
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    401 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Access unauthorized\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    403 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Access forbidden\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    404 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Remote file not found\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    500 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Server-side failure\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    502 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Upstream failure\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    503 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Server temporarily unavailable\n"
                | Int
    statusCode Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    504 =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: Upstream timeout\n"
                | Bool
    otherwise =
                        String
    "\n"
                    String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: HTTP request failure\n"

            suffix :: String
    suffix =
                    String
    "\n"
                String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "HTTP status code: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> Int -> String
    forall a. Show a => a -> String
    show Int
    statusCode String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
                String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    url String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
                String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    message

            statusCode :: Int
    statusCode =
                Status -> Int
    Network.HTTP.Types.statusCode
                    (Response () -> Status
    forall body. Response body -> Status
    HTTP.responseStatus Response ()
    response)

            message :: String
    message =
                case ByteString -> Either UnicodeException Text
    Data.Text.Encoding.decodeUtf8' ByteString
    body of
                    Left UnicodeException
    _ ->
                            String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "Message (non-UTF8 bytes):\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    truncatedBodyString String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
                      where
                        bodyString :: String
    bodyString = ByteString -> String
    forall a. Show a => a -> String
    show ByteString
    body

                        dots :: String
    dots = String
    "…"

                        truncatedLength :: Int
    truncatedLength = Int
    80 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    dots

                        truncatedBodyString :: String
    truncatedBodyString
                            | Int
    truncatedLength Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    < String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length String
    bodyString =
                                Int -> String -> String
    forall a. Int -> [a] -> [a]
    take Int
    truncatedLength String
    bodyString String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    dots
                            | Bool
    otherwise =
                                String
    bodyString
                    Right Text
    "" ->
                        String
    ""
                    Right Text
    bodyText ->
                            String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "Message:\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  Text -> String
    Text.unpack Text
    prefixedText
                      where
                        prefixedLines :: [Text]
    prefixedLines =
                            (Text -> Text -> Text) -> [Text] -> [Text] -> [Text]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith Text -> Text -> Text
    forall {a}. (Semigroup a, IsString a) => a -> a -> a
    combine [Text]
    prefixes (Text -> [Text]
    Text.lines Text
    bodyText)
                          where
                            prefixes :: [Text]
    prefixes =
                                (Int -> Text) -> [Int] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map (String -> Text
    Text.pack (String -> Text) -> (Int -> String) -> Int -> Text
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show) [(Int
    1 ::Int)..Int
    7] [Text] -> [Text] -> [Text]
    forall a. [a] -> [a] -> [a]
    ++ [ Text
    "…" ]

                            combine :: a -> a -> a
    combine a
    n a
    line = a
    n a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    "│ " a -> a -> a
    forall a. Semigroup a => a -> a -> a
    <> a
    line

                        prefixedText :: Text
    prefixedText = [Text] -> Text
    Text.unlines [Text]
    prefixedLines

        HttpExceptionContent
    e' -> String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\ESC[1;31mError\ESC[0m: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> HttpExceptionContent -> String
    forall a. Show a => a -> String
    show HttpExceptionContent
    e'
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
          String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "URL: " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    url String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"

    newManager :: StateT Status IO Manager
    newManager :: StateT Status IO Manager
    newManager = do
        Status { _manager :: Status -> Maybe Manager
    _manager = Maybe Manager
    oldManager, [Depends]
    Maybe (ReifiedNormalizer Void)
    IO Manager
    NonEmpty Chained
    StateT Status IO OriginHeaders
    Context (Expr Src Void)
    Substitutions Src Void
    Map Chained ImportSemantics
    CacheWarning
    SemanticCacheMode
    URL -> StateT Status IO Text
    _stack :: NonEmpty Chained
    _graph :: [Depends]
    _cache :: Map Chained ImportSemantics
    _newManager :: IO Manager
    _loadOriginHeaders :: StateT Status IO OriginHeaders
    _remote :: URL -> StateT Status IO Text
    _substitutions :: Substitutions Src Void
    _normalizer :: Maybe (ReifiedNormalizer Void)
    _startingContext :: Context (Expr Src Void)
    _semanticCacheMode :: SemanticCacheMode
    _cacheWarning :: CacheWarning
    _stack :: Status -> NonEmpty Chained
    _graph :: Status -> [Depends]
    _cache :: Status -> Map Chained ImportSemantics
    _newManager :: Status -> IO Manager
    _loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
    _remote :: Status -> URL -> StateT Status IO Text
    _substitutions :: Status -> Substitutions Src Void
    _normalizer :: Status -> Maybe (ReifiedNormalizer Void)
    _startingContext :: Status -> Context (Expr Src Void)
    _semanticCacheMode :: Status -> SemanticCacheMode
    _cacheWarning :: Status -> CacheWarning
    ..} <- StateT Status IO Status
    forall (m :: * -> *) s. Monad m => StateT s m s
    State.get

        case Maybe Manager
    oldManager of
            Maybe Manager
    Nothing -> do
                Manager
    manager <- IO Manager -> StateT Status IO Manager
    forall a. IO a -> StateT Status IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO IO Manager
    _newManager

                Status -> StateT Status IO ()
    forall (m :: * -> *) s. Monad m => s -> StateT s m ()
    State.put (Status { _manager :: Maybe Manager
    _manager = Manager -> Maybe Manager
    forall a. a -> Maybe a
    Just Manager
    manager , [Depends]
    Maybe (ReifiedNormalizer Void)
    IO Manager
    NonEmpty Chained
    StateT Status IO OriginHeaders
    Context (Expr Src Void)
    Substitutions Src Void
    Map Chained ImportSemantics
    CacheWarning
    SemanticCacheMode
    URL -> StateT Status IO Text
    _stack :: NonEmpty Chained
    _graph :: [Depends]
    _cache :: Map Chained ImportSemantics
    _newManager :: IO Manager
    _loadOriginHeaders :: StateT Status IO OriginHeaders
    _remote :: URL -> StateT Status IO Text
    _substitutions :: Substitutions Src Void
    _normalizer :: Maybe (ReifiedNormalizer Void)
    _startingContext :: Context (Expr Src Void)
    _semanticCacheMode :: SemanticCacheMode
    _cacheWarning :: CacheWarning
    _stack :: NonEmpty Chained
    _graph :: [Depends]
    _cache :: Map Chained ImportSemantics
    _newManager :: IO Manager
    _loadOriginHeaders :: StateT Status IO OriginHeaders
    _remote :: URL -> StateT Status IO Text
    _substitutions :: Substitutions Src Void
    _normalizer :: Maybe (ReifiedNormalizer Void)
    _startingContext :: Context (Expr Src Void)
    _semanticCacheMode :: SemanticCacheMode
    _cacheWarning :: CacheWarning
    ..})

                Manager -> StateT Status IO Manager
    forall a. a -> StateT Status IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Manager
    manager

            Just Manager
    manager ->
                Manager -> StateT Status IO Manager
    forall a. a -> StateT Status IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Manager
    manager

    data NotCORSCompliant = NotCORSCompliant
        { NotCORSCompliant -> [ByteString]
    expectedOrigins :: [ByteString]
        , NotCORSCompliant -> ByteString
    actualOrigin    :: ByteString
        }

    instance Exception NotCORSCompliant

    instance Show NotCORSCompliant where
        show :: NotCORSCompliant -> String
    show (NotCORSCompliant {[ByteString]
    ByteString
    expectedOrigins :: NotCORSCompliant -> [ByteString]
    actualOrigin :: NotCORSCompliant -> ByteString
    expectedOrigins :: [ByteString]
    actualOrigin :: ByteString
    ..}) =
                String
    forall string. IsString string => string
    Dhall.Util._ERROR String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    ": Not CORS compliant\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "Dhall supports transitive imports, meaning that an imported expression can\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "import other expressions.  However, a remote import (the \"parent\" import)\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "cannot import another remote import (the \"child\" import) unless the child\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "import grants permission to do using CORS.  The child import must respond with\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "an `Access-Control-Allow-Origin` response header that matches the parent\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "import, otherwise Dhall rejects the import.\n"
            String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n" String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    prologue
          where
            prologue :: String
    prologue =
                case [ByteString]
    expectedOrigins of
                    [ ByteString
    expectedOrigin ] ->
                            String
    "The following parent import:\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "↳ " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> String
    forall a. Show a => a -> String
    show ByteString
    actualOrigin String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "... did not match the expected origin:\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "↳ " String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> ByteString -> String
    forall a. Show a => a -> String
    show ByteString
    expectedOrigin String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <> String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "... so import resolution failed.\n"
                    [] ->
                            String
    "The child response did not include any `Access-Control-Allow-Origin` header,\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "so import resolution failed.\n"
                    ByteString
    _:ByteString
    _:[ByteString]
    _ ->
                            String
    "The child response included more than one `Access-Control-Allow-Origin` header,\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "when only one such header should have been present, so import resolution\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "failed.\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "\n"
                        String -> String -> String
    forall a. Semigroup a => a -> a -> a
    <>  String
    "This may indicate that the server for the child import is misconfigured.\n"

    corsCompliant
        :: MonadIO io
        => ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
    corsCompliant :: forall (io :: * -> *).
    MonadIO io =>
    ImportType -> URL -> RequestHeaders -> io ()
    corsCompliant (Remote URL
    parentURL) URL
    childURL RequestHeaders
    responseHeaders = IO () -> io ()
    forall a. IO a -> io a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> io ()) -> IO () -> io ()
    forall a b. (a -> b) -> a -> b
    $ do
        let toOrigin :: URL -> ByteString
    toOrigin (URL {Maybe Text
    Maybe (Expr Src Import)
    Text
    Scheme
    File
    scheme :: Scheme
    authority :: Text
    path :: File
    query :: Maybe Text
    headers :: Maybe (Expr Src Import)
    scheme :: URL -> Scheme
    authority :: URL -> Text
    path :: URL -> File
    query :: URL -> Maybe Text
    headers :: URL -> Maybe (Expr Src Import)
    ..}) =
                Text -> ByteString
    Data.Text.Encoding.encodeUtf8 (Text
    prefix Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    "://" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    authority)
              where
                prefix :: Text
    prefix =
                    case Scheme
    scheme of
                        Scheme
    HTTP  -> Text
    "http"
                        Scheme
    HTTPS -> Text
    "https"

        let actualOrigin :: ByteString
    actualOrigin = URL -> ByteString
    toOrigin URL
    parentURL

        let childOrigin :: ByteString
    childOrigin = URL -> ByteString
    toOrigin URL
    childURL

        let predicate :: (a, b) -> Bool
    predicate (a
    header, b
    _) = a
    header a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    "Access-Control-Allow-Origin"

        let originHeaders :: RequestHeaders
    originHeaders = ((CI ByteString, ByteString) -> Bool)
    -> RequestHeaders -> RequestHeaders
    forall a. (a -> Bool) -> [a] -> [a]
    filter (CI ByteString, ByteString) -> Bool
    forall {a} {b}. (Eq a, IsString a) => (a, b) -> Bool
    predicate RequestHeaders
    responseHeaders

        let expectedOrigins :: [ByteString]
    expectedOrigins = ((CI ByteString, ByteString) -> ByteString)
    -> RequestHeaders -> [ByteString]
    forall a b. (a -> b) -> [a] -> [b]
    map (CI ByteString, ByteString) -> ByteString
    forall a b. (a, b) -> b
    snd RequestHeaders
    originHeaders

        case [ByteString]
    expectedOrigins of
            [ByteString
    expectedOrigin]
                | ByteString
    expectedOrigin ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    "*" ->
                    () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                | ByteString
    expectedOrigin ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    actualOrigin ->
                    () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
            [ByteString]
    _   | ByteString
    actualOrigin ByteString -> ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteString
    childOrigin ->
                    () -> IO ()
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                | Bool
    otherwise ->
                    NotCORSCompliant -> IO ()
    forall e a. Exception e => e -> IO a
    Control.Exception.throwIO (NotCORSCompliant {[ByteString]
    ByteString
    expectedOrigins :: [ByteString]
    actualOrigin :: ByteString
    actualOrigin :: ByteString
    expectedOrigins :: [ByteString]
    ..})
    corsCompliant ImportType
    _ URL
    _ RequestHeaders
    _ = () -> io ()
    forall a. a -> io a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

    addHeaders :: OriginHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request
    addHeaders :: OriginHeaders -> Maybe RequestHeaders -> Request -> Request
    addHeaders OriginHeaders
    originHeaders Maybe RequestHeaders
    urlHeaders Request
    request =
        Request
    request { requestHeaders :: RequestHeaders
    HTTP.requestHeaders = (Maybe RequestHeaders -> RequestHeaders
    filterHeaders Maybe RequestHeaders
    urlHeaders) RequestHeaders -> RequestHeaders -> RequestHeaders
    forall a. Semigroup a => a -> a -> a
    <> RequestHeaders
    perOriginHeaders }
          where
            origin :: Text
    origin = ByteString -> Text
    decodeUtf8 (Request -> ByteString
    HTTP.host Request
    request) Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> Text
    ":" Text -> Text -> Text
    forall a. Semigroup a => a -> a -> a
    <> String -> Text
    Text.pack (Int -> String
    forall a. Show a => a -> String
    show (Request -> Int
    HTTP.port Request
    request))

            perOriginHeaders :: RequestHeaders
    perOriginHeaders = RequestHeaders -> Text -> OriginHeaders -> RequestHeaders
    forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
    HashMap.lookupDefault [] Text
    origin OriginHeaders
    originHeaders

            filterHeaders :: Maybe RequestHeaders -> RequestHeaders
    filterHeaders = (RequestHeaders -> RequestHeaders)
    -> Maybe RequestHeaders -> RequestHeaders
    forall m a. Monoid m => (a -> m) -> Maybe a -> m
    forall (t :: * -> *) m a.
    (Foldable t, Monoid m) =>
    (a -> m) -> t a -> m
    foldMap (((CI ByteString, ByteString) -> Bool)
    -> RequestHeaders -> RequestHeaders
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool)
    -> ((CI ByteString, ByteString) -> Bool)
    -> (CI ByteString, ByteString)
    -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (CI ByteString, ByteString) -> Bool
    overridden))

            overridden :: HTTPHeader -> Bool
            overridden :: (CI ByteString, ByteString) -> Bool
    overridden (CI ByteString
    key, ByteString
    _value) = ((CI ByteString, ByteString) -> Bool) -> RequestHeaders -> Bool
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
    any (CI ByteString -> (CI ByteString, ByteString) -> Bool
    matchesKey CI ByteString
    key) RequestHeaders
    perOriginHeaders

            matchesKey :: CI ByteString -> HTTPHeader -> Bool
            matchesKey :: CI ByteString -> (CI ByteString, ByteString) -> Bool
    matchesKey CI ByteString
    key (CI ByteString
    candidate, ByteString
    _value) = CI ByteString
    key CI ByteString -> CI ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == CI ByteString
    candidate

    fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text
    fetchFromHttpUrl :: URL -> Maybe RequestHeaders -> StateT Status IO Text
    fetchFromHttpUrl URL
    childURL Maybe RequestHeaders
    mheaders = do
        Status { StateT Status IO OriginHeaders
    _loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
    _loadOriginHeaders :: StateT Status IO OriginHeaders
    _loadOriginHeaders } <- StateT Status IO Status
    forall (m :: * -> *) s. Monad m => StateT s m s
    State.get

        OriginHeaders
    originHeaders <- StateT Status IO OriginHeaders
    _loadOriginHeaders

        Manager
    manager <- StateT Status IO Manager
    newManager

        let childURLString :: String
    childURLString = Text -> String
    Text.unpack (URL -> Text
    renderURL URL
    childURL)

        Request
    baseRequest <- IO Request -> StateT Status IO Request
    forall a. IO a -> StateT Status IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (String -> IO Request
    forall (m :: * -> *). MonadThrow m => String -> m Request
    HTTP.parseUrlThrow String
    childURLString)

        let requestWithHeaders :: Request
    requestWithHeaders = OriginHeaders -> Maybe RequestHeaders -> Request -> Request
    addHeaders OriginHeaders
    originHeaders Maybe RequestHeaders
    mheaders Request
    baseRequest

        let io :: IO (Response ByteString)
    io = Request -> Manager -> IO (Response ByteString)
    HTTP.httpLbs Request
    requestWithHeaders Manager
    manager

        let handler :: HttpException -> IO a
    handler HttpException
    e = do
                let HttpException
    _ = HttpException
    e :: HttpException
                PrettyHttpException -> IO a
    forall e a. Exception e => e -> IO a
    Control.Exception.throwIO (String -> HttpException -> PrettyHttpException
    mkPrettyHttpException String
    childURLString HttpException
    e)

        Response ByteString
    response <- IO (Response ByteString) -> StateT Status IO (Response ByteString)
    forall a. IO a -> StateT Status IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO ((HttpException -> IO (Response ByteString))
    -> IO (Response ByteString) -> IO (Response ByteString)
    forall e a. Exception e => (e -> IO a) -> IO a -> IO a
    Control.Exception.handle HttpException -> IO (Response ByteString)
    forall {a}. HttpException -> IO a
    handler IO (Response ByteString)
    io)

        Status {[Depends]
    Maybe Manager
    Maybe (ReifiedNormalizer Void)
    IO Manager
    NonEmpty Chained
    StateT Status IO OriginHeaders
    Context (Expr Src Void)
    Substitutions Src Void
    Map Chained ImportSemantics
    CacheWarning
    SemanticCacheMode
    URL -> StateT Status IO Text
    _manager :: Status -> Maybe Manager
    _stack :: Status -> NonEmpty Chained
    _graph :: Status -> [Depends]
    _cache :: Status -> Map Chained ImportSemantics
    _newManager :: Status -> IO Manager
    _loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
    _remote :: Status -> URL -> StateT Status IO Text
    _substitutions :: Status -> Substitutions Src Void
    _normalizer :: Status -> Maybe (ReifiedNormalizer Void)
    _startingContext :: Status -> Context (Expr Src Void)
    _semanticCacheMode :: Status -> SemanticCacheMode
    _cacheWarning :: Status -> CacheWarning
    _stack :: NonEmpty Chained
    _graph :: [Depends]
    _cache :: Map Chained ImportSemantics
    _newManager :: IO Manager
    _manager :: Maybe Manager
    _loadOriginHeaders :: StateT Status IO OriginHeaders
    _remote :: URL -> StateT Status IO Text
    _substitutions :: Substitutions Src Void
    _normalizer :: Maybe (ReifiedNormalizer Void)
    _startingContext :: Context (Expr Src Void)
    _semanticCacheMode :: SemanticCacheMode
    _cacheWarning :: CacheWarning
    ..} <- StateT Status IO Status
    forall (m :: * -> *) s. Monad m => StateT s m s
    State.get

        case NonEmpty Chained
    _stack of
            -- We ignore the first import in the stack since that is the same import
            -- as the `childUrl`
            Chained
    _ :| Chained Import
    parentImport : [Chained]
    _ -> do
                let parentImportType :: ImportType
    parentImportType = ImportHashed -> ImportType
    importType (Import -> ImportHashed
    importHashed Import
    parentImport)

                ImportType -> URL -> RequestHeaders -> StateT Status IO ()
    forall (io :: * -> *).
    MonadIO io =>
    ImportType -> URL -> RequestHeaders -> io ()
    corsCompliant ImportType
    parentImportType URL
    childURL (Response ByteString -> RequestHeaders
    forall body. Response body -> RequestHeaders
    HTTP.responseHeaders Response ByteString
    response)
            NonEmpty Chained
    _ -> do
                () -> StateT Status IO ()
    forall a. a -> StateT Status IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()

        let bytes :: ByteString
    bytes = Response ByteString -> ByteString
    forall body. Response body -> body
    HTTP.responseBody Response ByteString
    response

        case ByteString -> Either UnicodeException Text
    Data.Text.Lazy.Encoding.decodeUtf8' ByteString
    bytes of
            Left  UnicodeException
    err  -> IO Text -> StateT Status IO Text
    forall a. IO a -> StateT Status IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (UnicodeException -> IO Text
    forall e a. Exception e => e -> IO a
    Control.Exception.throwIO UnicodeException
    err)
            Right Text
    text -> Text -> StateT Status IO Text
    forall a. a -> StateT Status IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Text -> Text
    Data.Text.Lazy.toStrict Text
    text)

    originHeadersFileExpr :: IO (Expr Src Import)
    originHeadersFileExpr :: IO (Expr Src Import)
    originHeadersFileExpr = do
        String
    directoryStr <- XdgDirectory -> String -> IO String
    getXdgDirectory XdgDirectory
    XdgConfig String
    "dhall"
        let components :: [Text]
    components = (String -> Text) -> [String] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> Text
    Text.pack (String -> [String]
    splitDirectories String
    directoryStr)
        let directory :: Directory
    directory = [Text] -> Directory
    Directory ([Text] -> [Text]
    forall a. [a] -> [a]
    reverse [Text]
    components)
        let file :: File
    file = (Directory -> Text -> File
    File Directory
    directory Text
    "headers.dhall")
        Expr Src Import -> IO (Expr Src Import)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Import -> Expr Src Import
    forall s a. a -> Expr s a
    Embed (ImportHashed -> ImportMode -> Import
    Import (Maybe SHA256Digest -> ImportType -> ImportHashed
    ImportHashed Maybe SHA256Digest
    forall a. Maybe a
    Nothing (FilePrefix -> File -> ImportType
    Local FilePrefix
    Absolute File
    file)) ImportMode
    Code))