diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 5f32f4213..3b3137bac 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -610,6 +610,7 @@ Library Other-Modules: Dhall.Eval Dhall.Import.Types + Dhall.Import.Headers Dhall.Marshal.Internal Dhall.Normalize Dhall.Parser.Combinators diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index b0b5f737a..b86d139cb 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} module Dhall.Import.HTTP ( fetchFromHttpUrl + , originHeadersFileExpr ) where import Control.Exception (Exception) @@ -12,21 +14,31 @@ 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 - ( Import (..) + ( 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 @@ -238,20 +250,35 @@ corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () -type HTTPHeader = Network.HTTP.Types.Header +addHeaders :: OriginHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request +addHeaders originHeaders urlHeaders request = + request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> perOriginHeaders } + where + origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) + + perOriginHeaders = HashMap.lookupDefault [] origin originHeaders + + filterHeaders = foldMap (filter (not . overridden)) + + overridden :: HTTPHeader -> Bool + overridden (key, _value) = any (matchesKey key) perOriginHeaders + + matchesKey :: CI ByteString -> HTTPHeader -> Bool + matchesKey key (candidate, _value) = key == candidate fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do + Status { _loadOriginHeaders } <- State.get + + originHeaders <- _loadOriginHeaders + manager <- newManager let childURLString = Text.unpack (renderURL childURL) - request <- liftIO (HTTP.parseUrlThrow childURLString) + baseRequest <- liftIO (HTTP.parseUrlThrow childURLString) - let requestWithHeaders = - case mheaders of - Nothing -> request - Just headers -> request { HTTP.requestHeaders = headers } + let requestWithHeaders = addHeaders originHeaders mheaders baseRequest let io = HTTP.httpLbs requestWithHeaders manager @@ -278,3 +305,11 @@ fetchFromHttpUrl childURL mheaders = do case Data.Text.Lazy.Encoding.decodeUtf8' bytes of Left err -> liftIO (Control.Exception.throwIO err) Right text -> return (Data.Text.Lazy.toStrict text) + +originHeadersFileExpr :: IO (Expr Src Import) +originHeadersFileExpr = do + directoryStr <- getXdgDirectory XdgConfig "dhall" + let components = map Text.pack (splitDirectories directoryStr) + let directory = Directory (reverse components) + let file = (File directory "headers.dhall") + return (Embed (Import (ImportHashed Nothing (Local Absolute file)) Code)) \ No newline at end of file diff --git a/dhall/ghcjs-src/Dhall/Import/HTTP.hs b/dhall/ghcjs-src/Dhall/Import/HTTP.hs index 78ff08da5..eea74be0d 100644 --- a/dhall/ghcjs-src/Dhall/Import/HTTP.hs +++ b/dhall/ghcjs-src/Dhall/Import/HTTP.hs @@ -2,14 +2,16 @@ module Dhall.Import.HTTP ( fetchFromHttpUrl + , originHeadersFileExpr ) where import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) -import Dhall.Core (URL (..)) -import Dhall.Import.Types (Status) +import Dhall.Core (URL (..), Expr (..)) +import Dhall.Import.Types (Import, Status) +import Dhall.Parser (Src) import Dhall.URL (renderURL) import qualified Data.Text as Text @@ -35,3 +37,6 @@ fetchFromHttpUrl childURL Nothing = do return body fetchFromHttpUrl _ _ = fail "Dhall does not yet support custom headers when built using GHCJS" + +originHeadersFileExpr :: IO (Expr Src Import) +originHeadersFileExpr = return Missing diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index e3370906f..47c8d18df 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -108,7 +108,7 @@ module Dhall.Import ( load , loadWithManager , loadRelativeTo - , loadRelativeToWithManager + , loadWithStatus , loadWith , localToPath , hashExpression @@ -126,8 +126,11 @@ module Dhall.Import ( , chainedChangeMode , emptyStatus , emptyStatusWithManager + , envOriginHeaders + , makeEmptyStatus , remoteStatus , remoteStatusWithManager + , fetchRemote , stack , cache , Depends(..) @@ -152,7 +155,7 @@ module Dhall.Import ( , HashMismatch(..) ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception ( Exception , IOException @@ -164,8 +167,8 @@ import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Morph (hoist) import Control.Monad.State.Strict (MonadState, StateT) import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), nonEmpty) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Typeable (Typeable) import Data.Void (Void, absurd) @@ -188,10 +191,17 @@ import Dhall.Syntax ) import System.FilePath (()) +import Text.Megaparsec (SourcePos (SourcePos), mkPos) #ifdef WITH_HTTP import Dhall.Import.HTTP #endif +import Dhall.Import.Headers + ( normalizeHeaders + , originHeadersTypeExpr + , toHeaders + , toOriginHeaders + ) import Dhall.Import.Types import Dhall.Parser @@ -209,12 +219,9 @@ import qualified Control.Monad.State.Strict as State import qualified Control.Monad.Trans.Maybe as Maybe import qualified Data.ByteString import qualified Data.ByteString.Lazy -import qualified Data.CaseInsensitive -import qualified Data.Foldable import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Maybe as Maybe import qualified Data.Text as Text -import qualified Data.Text.Encoding import qualified Data.Text.IO import qualified Dhall.Binary import qualified Dhall.Core as Core @@ -355,9 +362,6 @@ instance Show MissingImports where throwMissingImport :: (MonadCatch m, Exception e) => e -> m a throwMissingImport e = throwM (MissingImports [toException e]) --- | HTTP headers -type HTTPHeader = (CI ByteString, ByteString) - -- | Exception thrown when a HTTP url is imported but dhall was built without -- the @with-http@ Cabal flag. data CannotImportHTTPURL = @@ -501,7 +505,7 @@ chainedChangeMode mode (Chained (Import importHashed _)) = -- | Chain imports, also typecheck and normalize headers if applicable. chainImport :: Chained -> Import -> StateT Status IO Chained chainImport (Chained parent) child@(Import importHashed@(ImportHashed _ (Remote url)) _) = do - url' <- normalizeHeaders url + url' <- normalizeHeadersIn url let child' = child { importHashed = importHashed { importType = Remote url' } } return (Chained (canonicalize (parent <> child'))) @@ -786,7 +790,7 @@ fetchFresh (Env env) = do fetchFresh Missing = throwM (MissingImports []) - +-- | Fetch the text contents of a URL fetchRemote :: URL -> StateT Status IO Data.Text.Text #ifndef WITH_HTTP fetchRemote (url@URL { headers = maybeHeadersExpression }) = do @@ -805,29 +809,6 @@ fetchRemote url = do fetchFromHttpUrl url' maybeHeaders #endif --- | Given a well-typed (of type `List { header : Text, value Text }` or --- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form --- construct the corresponding binary http headers; otherwise return the empty --- list. -toHeaders :: Expr s a -> [HTTPHeader] -toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders) - where - maybeHeaders = mapM toHeader hs -toHeaders _ = [] - -toHeader :: Expr s a -> Maybe HTTPHeader -toHeader (RecordLit m) = do - (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> TextLit (Chunks [] valueText)) - <- lookupHeader <|> lookupMapKey - let keyBytes = Data.Text.Encoding.encodeUtf8 keyText - let valueBytes = Data.Text.Encoding.encodeUtf8 valueText - return (Data.CaseInsensitive.mk keyBytes, valueBytes) - where - lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m) - lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) -toHeader _ = - empty - getCacheFile :: (MonadCatch m, Alternative m, MonadState CacheWarning m, MonadIO m) => FilePath -> Dhall.Crypto.SHA256Digest -> m FilePath @@ -1019,62 +1000,102 @@ getCacheBaseDirectory = alternative₀ <|> alternative₁ <|> alternative₂ -- If the URL contains headers typecheck them and replace them with their normal -- forms. -normalizeHeaders :: URL -> StateT Status IO URL -normalizeHeaders url@URL { headers = Just headersExpression } = do +normalizeHeadersIn :: URL -> StateT Status IO URL +normalizeHeadersIn url@URL { headers = Just headersExpression } = do Status { _stack } <- State.get loadedExpr <- loadWith headersExpression + let handler (e :: SomeException) = throwMissingImport (Imported _stack e) + normalized <- liftIO $ handle handler (normalizeHeaders loadedExpr) + return url { headers = Just (fmap absurd normalized) } + +normalizeHeadersIn url = return url + +-- | Empty origin headers used for remote contexts +-- (and fallback when nothing is set in env or config file) +emptyOriginHeaders :: Expr Src Import +emptyOriginHeaders = ListLit (Just (fmap absurd originHeadersTypeExpr)) mempty + +-- | A fake Src to annotate headers expressions with. +-- We need to wrap headers expressions in a Note for nice error reporting, +-- and because ImportAlt handling only catches SourcedExceptions +headersSrc :: Src +headersSrc = Src { + srcStart = SourcePos { + sourceName = fakeSrcName, + sourceLine = mkPos 1, + sourceColumn = mkPos 1 + }, + srcEnd = SourcePos { + sourceName = fakeSrcName, + sourceLine = mkPos 1, + sourceColumn = mkPos (Text.length fakeSrcText) + }, + srcText = fakeSrcText + } + where + fakeSrcText = "«Origin Header Configuration»" + fakeSrcName = "[builtin]" + +-- | Load headers only from the environment (used in tests) +envOriginHeaders :: Expr Src Import +envOriginHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) Code)) + +-- | Load headers in env, falling back to config file +defaultOriginHeaders :: IO (Expr Src Import) +#ifndef WITH_HTTP +defaultOriginHeaders = return emptyOriginHeaders +#else +defaultOriginHeaders = do + fromFile <- originHeadersFileExpr + return (Note headersSrc (ImportAlt envOriginHeaders (Note headersSrc fromFile))) +#endif + +-- | Given a headers expression, return an origin headers loader +originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders +originHeadersLoader headersExpr = do + + -- Load the headers using the parent stack, which should always be a local + -- import (we only load headers for the first remote import) - let go key₀ key₁ = do - let expected :: Expr Src Void - expected = - App List - ( Record $ Core.makeRecordField <$> - Dhall.Map.fromList - [ (key₀, Text) - , (key₁, Text) - ] - ) - - let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected - let annot = case loadedExpr of - Note (Src begin end bytes) _ -> - Note (Src begin end bytes') (Annot loadedExpr expected) - where - bytes' = bytes <> " : " <> suffix_ - _ -> - Annot loadedExpr expected - - _ <- case (Dhall.TypeCheck.typeOf annot) of - Left err -> throwMissingImport (Imported _stack err) - Right _ -> return () - - return (Core.normalize loadedExpr) - - let handler₀ (e :: SomeException) = do - {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields - and fall back to @header@/@value@ if that fails. However, if - @header@/@value@ still fails then re-throw the original exception - for @mapKey@ / @mapValue@. -} - let handler₁ (_ :: SomeException) = - throwMissingImport (Imported _stack e) - - handle handler₁ (go "header" "value") - - headersExpression' <- - handle handler₀ (go "mapKey" "mapValue") - - return url { headers = Just (fmap absurd headersExpression') } - -normalizeHeaders url = return url + status <- State.get + + let parentStack = fromMaybe abortEmptyStack (nonEmpty (NonEmpty.tail (_stack status))) + + let headerLoadStatus = status { _stack = parentStack } + + (headers, _) <- liftIO (State.runStateT doLoad headerLoadStatus) + + -- return cached headers next time + _ <- State.modify (\state -> state { _loadOriginHeaders = return headers }) + + return headers + where + abortEmptyStack = Core.internalError "Origin headers loaded with an empty stack" + + doLoad = do + partialExpr <- liftIO headersExpr + loaded <- loadWith (Note headersSrc (ImportAlt partialExpr emptyOriginHeaders)) + liftIO (toOriginHeaders loaded) -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = emptyStatusWithManager defaultNewManager +emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders + +-- | See 'emptyStatus' +emptyStatusWithManager + :: IO Manager + -> FilePath + -> Status +emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders -- | See 'emptyStatus'. -emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager rootDirectory = - emptyStatusWith newManager fetchRemote rootImport +makeEmptyStatus + :: IO Manager + -> IO (Expr Src Import) + -> FilePath + -> Status +makeEmptyStatus newManager headersExpr rootDirectory = + emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1107,7 +1128,7 @@ remoteStatus = remoteStatusWithManager defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager fetchRemote rootImport + emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) fetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1205,7 +1226,10 @@ load = loadWithManager defaultNewManager -- | See 'load'. loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) -loadWithManager newManager = loadRelativeToWithManager newManager "." UseSemanticCache +loadWithManager newManager = + loadWithStatus + (makeEmptyStatus newManager defaultOriginHeaders ".") + UseSemanticCache printWarning :: (MonadIO m) => String -> m () printWarning message = do @@ -1219,19 +1243,19 @@ printWarning message = do -- | Resolve all imports within an expression, importing relative to the given -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeTo = loadRelativeToWithManager defaultNewManager +loadRelativeTo parentDirectory = loadWithStatus + (makeEmptyStatus defaultNewManager defaultOriginHeaders parentDirectory) -- | See 'loadRelativeTo'. -loadRelativeToWithManager - :: IO Manager - -> FilePath +loadWithStatus + :: Status -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeToWithManager newManager rootDirectory semanticCacheMode expression = +loadWithStatus status semanticCacheMode expression = State.evalStateT (loadWith expression) - (emptyStatusWithManager newManager rootDirectory) { _semanticCacheMode = semanticCacheMode } + status { _semanticCacheMode = semanticCacheMode } encodeExpression :: Expr Void Void -> Data.ByteString.ByteString encodeExpression expression = bytesStrict diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs new file mode 100644 index 000000000..1009c2c88 --- /dev/null +++ b/dhall/src/Dhall/Import/Headers.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Dhall.Import.Headers + ( normalizeHeaders + , originHeadersTypeExpr + , toHeaders + , toOriginHeaders + ) where + +import Control.Applicative (Alternative (..), liftA2) +import Control.Exception (SomeException) +import Control.Monad.Catch (handle, throwM) +import Data.Text (Text) +import Data.Void (Void) +import Dhall.Core + ( Chunks (..) + , Expr (..) + ) +import Dhall.Import.Types (HTTPHeader , OriginHeaders) +import Dhall.Parser (Src (..)) + +import qualified Data.CaseInsensitive +import qualified Data.Foldable +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text.Encoding +import qualified Dhall.Core as Core +import qualified Dhall.Map +import qualified Dhall.TypeCheck +import qualified Dhall.Pretty.Internal + +-- | Given a well-typed (of type `List { header : Text, value Text }` or +-- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form +-- construct the corresponding binary http headers; otherwise return the empty +-- list. +toHeaders :: Expr s a -> [HTTPHeader] +toHeaders (ListLit _ hs) = Data.Foldable.toList (Data.Foldable.fold maybeHeaders) + where + maybeHeaders = mapM toHeader hs +toHeaders _ = [] + +toHeader :: Expr s a -> Maybe HTTPHeader +toHeader (RecordLit m) = do + (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> TextLit (Chunks [] valueText)) + <- lookupHeader <|> lookupMapKey + let keyBytes = Data.Text.Encoding.encodeUtf8 keyText + let valueBytes = Data.Text.Encoding.encodeUtf8 valueText + return (Data.CaseInsensitive.mk keyBytes, valueBytes) + where + lookupHeader = liftA2 (,) (Dhall.Map.lookup "header" m) (Dhall.Map.lookup "value" m) + lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) +toHeader _ = + empty + +-- | Normalize, typecheck and return OriginHeaders from a given expression. +toOriginHeaders :: Expr Src Void -> IO OriginHeaders +toOriginHeaders expr = fmap convert (normalizeOriginHeaders expr) + where + convert :: Expr s a -> OriginHeaders + convert (ListLit _ hs) = HashMap.fromList (originPairs hs) + convert _ = mempty + + originPairs hs = Data.Foldable.toList (Data.Foldable.fold (mapM toOriginPair hs)) + + toOriginPair :: Expr s a -> Maybe (Text, [HTTPHeader]) + toOriginPair (RecordLit m) = do + (Core.recordFieldValue -> TextLit (Chunks [] keyText), Core.recordFieldValue -> value) + <- lookupMapKey + return (keyText, toHeaders value) + where + lookupMapKey = liftA2 (,) (Dhall.Map.lookup "mapKey" m) (Dhall.Map.lookup "mapValue" m) + toOriginPair _ = Nothing + +makeHeadersTypeExpr :: Text -> Text -> Expr Src Void +makeHeadersTypeExpr keyKey valueKey = + App List + ( Record $ Core.makeRecordField <$> + Dhall.Map.fromList + [ (keyKey, Text) + , (valueKey, Text) + ] + ) + +headersTypeExpr :: Expr Src Void +headersTypeExpr = makeHeadersTypeExpr "mapKey" "mapValue" + +leagacyHeadersTypeExpr :: Expr Src Void +leagacyHeadersTypeExpr = makeHeadersTypeExpr "header" "value" + +originHeadersTypeExpr :: Expr Src Void +originHeadersTypeExpr = + App List + ( Record $ Core.makeRecordField <$> + Dhall.Map.fromList + [ ("mapKey", Text) + , ("mapValue", headersTypeExpr) + ] + ) + +typecheck :: Expr Src Void -> Expr Src Void -> IO (Expr Src Void) +typecheck expected expr = do + let suffix_ = Dhall.Pretty.Internal.prettyToStrictText expected + let annot = case expr of + Note (Src begin end bytes) _ -> + Note (Src begin end bytes') (Annot expr expected) + where + bytes' = bytes <> " : " <> suffix_ + _ -> + Annot expr expected + + _ <- case (Dhall.TypeCheck.typeOf annot) of + Left err -> throwM err + Right _ -> return () + + return (Core.normalize expr) + +normalizeHeaders :: Expr Src Void -> IO (Expr Src Void) +normalizeHeaders headersExpr = do + let handler₀ (e :: SomeException) = do + {- Try to typecheck using the preferred @mapKey@/@mapValue@ fields + and fall back to @header@/@value@ if that fails. However, if + @header@/@value@ still fails then re-throw the original exception + for @mapKey@ / @mapValue@. -} + let handler₁ (_ :: SomeException) = throwM e + handle handler₁ (typecheck leagacyHeadersTypeExpr headersExpr) + + handle handler₀ (typecheck headersTypeExpr headersExpr) + +normalizeOriginHeaders :: Expr Src Void -> IO (Expr Src Void) +normalizeOriginHeaders = typecheck originHeadersTypeExpr diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index f212825dd..10d3e09f7 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -8,7 +8,10 @@ module Dhall.Import.Types where import Control.Exception (Exception) import Control.Monad.Trans.State.Strict (StateT) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) import Data.Dynamic +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty) import Data.Void (Void) import Dhall.Context (Context) @@ -77,6 +80,12 @@ defaultNewManager = pure () #endif +-- | HTTP headers +type HTTPHeader = (CI ByteString, ByteString) + +-- | A map of site origin -> HTTP headers +type OriginHeaders = HashMap Data.Text.Text [HTTPHeader] + {-| Used internally to track whether or not we've already warned the user about caching issues -} @@ -101,6 +110,10 @@ data Status = Status -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests + , _loadOriginHeaders :: StateT Status IO OriginHeaders + -- ^ Load the origin headers from environment or configuration file. + -- After loading once, further evaluations return the cached version. + , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. @@ -117,14 +130,16 @@ data Status = Status -- cache directory } --- | Initial `Status`, parameterised over the HTTP 'Manager' and the remote --- resolver, importing relative to the given root import. +-- | Initial `Status`, parameterised over the HTTP 'Manager', +-- the origin headers and the remote resolver, +-- importing relative to the given root import. emptyStatusWith :: IO Manager + -> StateT Status IO OriginHeaders -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status -emptyStatusWith _newManager _remote rootImport = Status {..} +emptyStatusWith _newManager _loadOriginHeaders _remote rootImport = Status {..} where _stack = pure (Chained rootImport) diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 6cf905dad..286542f68 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -90,8 +90,6 @@ successTest prefix = do , importDirectory "success/unit/cors/AllowedAll" , importDirectory "success/unit/cors/SelfImportRelative" , importDirectory "success/unit/cors/OnlyGithub" - , importDirectory "success/userHeaders" - , importDirectory "success/userHeadersOverride" ] Test.Util.testCase prefix expectedFailures (do @@ -110,10 +108,17 @@ successTest prefix = do HTTP.newManager HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) } + + let status = + Import.makeEmptyStatus + httpManager + (pure Import.envOriginHeaders) + directoryString + let load = State.evalStateT (Test.Util.loadWith actualExpr) - (Import.emptyStatusWithManager httpManager directoryString) + status let usesCache = [ "hashFromCache" , "unit/asLocation/Hash"