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

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

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

        statusCode :: Int
statusCode =
            Status -> Int
Network.HTTP.Types.statusCode
                (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"
                    forall a. Semigroup a => a -> a -> a
<>  String
"Message (non-UTF8 bytes):\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
truncatedBodyString forall a. Semigroup a => a -> a -> a
<> String
"\n"
                  where
                    bodyString :: String
bodyString = forall a. Show a => a -> String
show ByteString
body

                    dots :: String
dots = String
"…"

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

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

                        combine :: a -> a -> a
combine a
n a
line = a
n forall a. Semigroup 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"
      forall a. Semigroup a => a -> a -> a
<>  String
"\ESC[1;31mError\ESC[0m: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show HttpExceptionContent
e'
      forall a. Semigroup a => a -> a -> a
<>  String
"\n"
      forall a. Semigroup a => a -> a -> a
<>  String
"URL: " forall a. Semigroup a => a -> a -> a
<> String
url 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 ByteString
URL -> StateT Status IO Text
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
..} <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get

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

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

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

        Just Manager
manager ->
            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
actualOrigin :: ByteString
expectedOrigins :: [ByteString]
actualOrigin :: NotCORSCompliant -> ByteString
expectedOrigins :: NotCORSCompliant -> [ByteString]
..}) =
            forall string. IsString string => string
Dhall.Util._ERROR forall a. Semigroup a => a -> a -> a
<> String
": Not CORS compliant\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"Dhall supports transitive imports, meaning that an imported expression can\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"import other expressions.  However, a remote import (the \"parent\" import)\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"cannot import another remote import (the \"child\" import) unless the child\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"import grants permission to do using CORS.  The child import must respond with\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"an `Access-Control-Allow-Origin` response header that matches the parent\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"import, otherwise Dhall rejects the import.\n"
        forall a. Semigroup a => a -> a -> a
<>  String
"\n" 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"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"↳ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
actualOrigin forall a. Semigroup a => a -> a -> a
<> String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"... did not match the expected origin:\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"↳ " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
expectedOrigin forall a. Semigroup a => a -> a -> a
<> String
"\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    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"
                    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"
                    forall a. Semigroup a => a -> a -> a
<>  String
"when only one such header should have been present, so import resolution\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"failed.\n"
                    forall a. Semigroup a => a -> a -> a
<>  String
"\n"
                    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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let toOrigin :: URL -> ByteString
toOrigin (URL {Maybe Text
Maybe (Expr Src Import)
Text
Scheme
File
headers :: URL -> Maybe (Expr Src Import)
query :: URL -> Maybe Text
path :: URL -> File
authority :: URL -> Text
scheme :: URL -> Scheme
headers :: Maybe (Expr Src Import)
query :: Maybe Text
path :: File
authority :: Text
scheme :: Scheme
..}) =
            Text -> ByteString
Data.Text.Encoding.encodeUtf8 (Text
prefix forall a. Semigroup a => a -> a -> a
<> 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 forall a. Eq a => a -> a -> Bool
== a
"Access-Control-Allow-Origin"

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

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

    case [ByteString]
expectedOrigins of
        [ByteString
expectedOrigin]
            | ByteString
expectedOrigin forall a. Eq a => a -> a -> Bool
== ByteString
"*" ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | ByteString
expectedOrigin forall a. Eq a => a -> a -> Bool
== ByteString
actualOrigin ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [ByteString]
_   | ByteString
actualOrigin forall a. Eq a => a -> a -> Bool
== ByteString
childOrigin ->
                forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise ->
                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
_ = 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) forall a. Semigroup a => a -> a -> a
<> RequestHeaders
perOriginHeaders }
      where
        origin :: Text
origin = ByteString -> Text
decodeUtf8 (Request -> ByteString
HTTP.host Request
request) forall a. Semigroup a => a -> a -> a
<> Text
":" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show (Request -> Int
HTTP.port Request
request))
 
        perOriginHeaders :: RequestHeaders
perOriginHeaders = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Text
origin OriginHeaders
originHeaders

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

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

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

fetchFromHttpUrlBytes
    :: URL -> Maybe [HTTPHeader] -> StateT Status IO ByteString
fetchFromHttpUrlBytes :: URL -> Maybe RequestHeaders -> StateT Status IO ByteString
fetchFromHttpUrlBytes URL
childURL Maybe RequestHeaders
mheaders = do
    Status { StateT Status IO OriginHeaders
_loadOriginHeaders :: StateT Status IO OriginHeaders
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_loadOriginHeaders } <- 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (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
            forall e a. Exception e => e -> IO a
Control.Exception.throwIO (String -> HttpException -> PrettyHttpException
mkPrettyHttpException String
childURLString HttpException
e)

    Response ByteString
response <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.handle 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 ByteString
URL -> StateT Status IO Text
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_remoteBytes :: URL -> StateT Status IO ByteString
_remote :: URL -> StateT Status IO Text
_loadOriginHeaders :: StateT Status IO OriginHeaders
_manager :: Maybe Manager
_newManager :: IO Manager
_cache :: Map Chained ImportSemantics
_graph :: [Depends]
_stack :: NonEmpty Chained
_cacheWarning :: Status -> CacheWarning
_semanticCacheMode :: Status -> SemanticCacheMode
_startingContext :: Status -> Context (Expr Src Void)
_normalizer :: Status -> Maybe (ReifiedNormalizer Void)
_substitutions :: Status -> Substitutions Src Void
_remoteBytes :: Status -> URL -> StateT Status IO ByteString
_remote :: Status -> URL -> StateT Status IO Text
_loadOriginHeaders :: Status -> StateT Status IO OriginHeaders
_newManager :: Status -> IO Manager
_cache :: Status -> Map Chained ImportSemantics
_graph :: Status -> [Depends]
_stack :: Status -> NonEmpty Chained
_manager :: Status -> Maybe Manager
..} <- 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)

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

    forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> ByteString
ByteString.Lazy.toStrict (forall body. Response body -> body
HTTP.responseBody Response ByteString
response))

fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text
fetchFromHttpUrl :: URL -> Maybe RequestHeaders -> StateT Status IO Text
fetchFromHttpUrl URL
childURL Maybe RequestHeaders
mheaders = do
    ByteString
bytes <- URL -> Maybe RequestHeaders -> StateT Status IO ByteString
fetchFromHttpUrlBytes URL
childURL Maybe RequestHeaders
mheaders

    case ByteString -> Either UnicodeException Text
Data.Text.Encoding.decodeUtf8' ByteString
bytes of
        Left  UnicodeException
err  -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall e a. Exception e => e -> IO a
Control.Exception.throwIO UnicodeException
err)
        Right Text
text -> forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack (String -> [String]
splitDirectories String
directoryStr)
    let directory :: Directory
directory = [Text] -> Directory
Directory (forall a. [a] -> [a]
reverse [Text]
components)
    let file :: File
file = (Directory -> Text -> File
File Directory
directory Text
"headers.dhall")
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. a -> Expr s a
Embed (ImportHashed -> ImportMode -> Import
Import (Maybe SHA256Digest -> ImportType -> ImportHashed
ImportHashed forall a. Maybe a
Nothing (FilePrefix -> File -> ImportType
Local FilePrefix
Absolute File
file)) ImportMode
Code))