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

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

        Just Manager
manager ->
            Manager -> StateT Status IO 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]
..}) =
            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 :: ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant (Remote URL
parentURL) URL
childURL [(CI ByteString, ByteString)]
responseHeaders = IO () -> io ()
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
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 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 :: [(CI ByteString, ByteString)]
originHeaders = ((CI ByteString, ByteString) -> Bool)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (CI ByteString, ByteString) -> Bool
forall a b. (Eq a, IsString a) => (a, b) -> Bool
predicate [(CI ByteString, ByteString)]
responseHeaders

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

    case [ByteString]
expectedOrigins of
        [ByteString
expectedOrigin]
            | ByteString
expectedOrigin ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*" ->
                () -> IO ()
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 (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 (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 -> NotCORSCompliant
NotCORSCompliant {[ByteString]
ByteString
expectedOrigins :: [ByteString]
actualOrigin :: ByteString
actualOrigin :: ByteString
expectedOrigins :: [ByteString]
..})
corsCompliant ImportType
_ URL
_ [(CI ByteString, ByteString)]
_ = () -> io ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

addHeaders :: OriginHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request
addHeaders :: OriginHeaders
-> Maybe [(CI ByteString, ByteString)] -> Request -> Request
addHeaders OriginHeaders
originHeaders Maybe [(CI ByteString, ByteString)]
urlHeaders Request
request =
    Request
request { requestHeaders :: [(CI ByteString, ByteString)]
HTTP.requestHeaders = (Maybe [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)]
filterHeaders Maybe [(CI ByteString, ByteString)]
urlHeaders) [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
forall a. Semigroup a => a -> a -> a
<> [(CI ByteString, ByteString)]
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 :: [(CI ByteString, ByteString)]
perOriginHeaders = [(CI ByteString, ByteString)]
-> Text -> OriginHeaders -> [(CI ByteString, ByteString)]
forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
HashMap.lookupDefault [] Text
origin OriginHeaders
originHeaders

        filterHeaders :: Maybe [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)]
filterHeaders = ([(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)])
-> Maybe [(CI ByteString, ByteString)]
-> [(CI ByteString, ByteString)]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (((CI ByteString, ByteString) -> Bool)
-> [(CI ByteString, ByteString)] -> [(CI ByteString, ByteString)]
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)
-> [(CI ByteString, ByteString)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (CI ByteString -> (CI ByteString, ByteString) -> Bool
matchesKey CI ByteString
key) [(CI ByteString, ByteString)]
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 [(CI ByteString, ByteString)] -> StateT Status IO Text
fetchFromHttpUrl URL
childURL Maybe [(CI ByteString, ByteString)]
mheaders = do
    Status { StateT Status IO OriginHeaders
_loadOriginHeaders :: StateT Status IO OriginHeaders
_loadOriginHeaders :: Status -> 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 (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 [(CI ByteString, ByteString)] -> Request -> Request
addHeaders OriginHeaders
originHeaders Maybe [(CI ByteString, ByteString)]
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 (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
_cacheWarning :: CacheWarning
_semanticCacheMode :: SemanticCacheMode
_startingContext :: Context (Expr Src Void)
_normalizer :: Maybe (ReifiedNormalizer Void)
_substitutions :: Substitutions Src Void
_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
_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
..} <- 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 -> [(CI ByteString, ByteString)] -> StateT Status IO ()
forall (io :: * -> *).
MonadIO io =>
ImportType -> URL -> [(CI ByteString, ByteString)] -> io ()
corsCompliant ImportType
parentImportType URL
childURL (Response ByteString -> [(CI ByteString, ByteString)]
forall body. Response body -> [(CI ByteString, ByteString)]
HTTP.responseHeaders Response ByteString
response)
        NonEmpty Chained
_ -> do
            () -> StateT Status IO ()
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 (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 (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 (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))