From 6a02facd520d76b6da9cbf13e92c731aac558d54 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Tue, 29 Jun 2021 21:03:38 +1000 Subject: [PATCH 01/22] WIP support for ~/.config/dhall/headers.dhall --- dhall/dhall.cabal | 1 + dhall/ghc-src/Dhall/Import/HTTP.hs | 13 ++-- dhall/ghc-src/Dhall/Import/Manager.hs | 18 +++-- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 81 +++++++++++++++++++++++ 4 files changed, 104 insertions(+), 9 deletions(-) create mode 100644 dhall/ghc-src/Dhall/Import/UserHeaders.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 93fa77509..944e8d971 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -623,6 +623,7 @@ Library Other-Modules: Dhall.Import.HTTP Dhall.Import.Manager + Dhall.Import.UserHeaders GHC-Options: -Wall -fwarn-incomplete-uni-patterns Default-Language: Haskell2010 diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 81e2c8dcd..c037379d7 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} module Dhall.Import.HTTP ( fetchFromHttpUrl @@ -19,7 +20,9 @@ import Dhall.Core , Scheme (..) , URL (..) ) -import Dhall.Import.Types +import Dhall.Import.Types hiding (Manager) +import Dhall.Import.Manager (Manager(..)) +import Dhall.Import.UserHeaders (withUserHeaders) import Dhall.URL (renderURL) @@ -245,18 +248,20 @@ type HTTPHeader = Network.HTTP.Types.Header fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do - manager <- newManager + Manager { httpManager, headersManager } <- newManager let childURLString = Text.unpack (renderURL childURL) request <- liftIO (HTTP.parseUrlThrow childURLString) - let requestWithHeaders = + let baseRequest = case mheaders of Nothing -> request Just headers -> request { HTTP.requestHeaders = headers } - let io = HTTP.httpLbs requestWithHeaders manager + requestWithHeaders <- liftIO (withUserHeaders headersManager baseRequest) + + let io = HTTP.httpLbs requestWithHeaders httpManager let handler e = do let _ = e :: HttpException diff --git a/dhall/ghc-src/Dhall/Import/Manager.hs b/dhall/ghc-src/Dhall/Import/Manager.hs index 1926f41a1..7cf1324d0 100644 --- a/dhall/ghc-src/Dhall/Import/Manager.hs +++ b/dhall/ghc-src/Dhall/Import/Manager.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} {-| Both the GHC and GHCJS implementations of 'Dhall.Import.Manager.Manager' export a `Dhall.Import.Manager.Manager` type suitable for use within the @@ -12,22 +14,28 @@ -} module Dhall.Import.Manager ( -- * Manager - Manager + Manager(..) , defaultNewManager ) where -import Network.HTTP.Client (Manager, newManager) +import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as HTTP +import Dhall.Import.UserHeaders (UserHeaders, defaultNewUserHeaders) #ifdef USE_HTTP_CLIENT_TLS import Network.HTTP.Client.TLS (tlsManagerSettings) #endif +data Manager = Manager { httpManager :: Client.Manager, headersManager :: UserHeaders } + defaultNewManager :: IO Manager -defaultNewManager = newManager +defaultNewManager = + build <$> (Client.newManager #ifdef USE_HTTP_CLIENT_TLS - tlsManagerSettings + tlsManagerSettings #else - HTTP.defaultManagerSettings + HTTP.defaultManagerSettings #endif { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds + ) where + build httpManager = Manager { httpManager, headersManager = defaultNewUserHeaders } \ No newline at end of file diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs new file mode 100644 index 000000000..dfc398a1b --- /dev/null +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Dhall.Import.UserHeaders + ( + UserHeaders + , Headers + , defaultNewUserHeaders + , withUserHeaders + ) where + +import Data.Aeson (eitherDecodeStrict') +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Network.HTTP.Types (Header) +import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) +import System.Environment (lookupEnv) +import System.FilePath (()) +import Data.Either.Combinators (rightToMaybe) +import Control.Exception (tryJust) +import Control.Monad (guard) +import System.IO.Error (isDoesNotExistError) +import qualified Data.ByteString as B +import qualified Data.CaseInsensitive as CI +import qualified Data.HashMap.Strict as HashMap +import qualified Data.Text as Text +import qualified Network.HTTP.Client as HTTP + +-- todo StateT? +type UserHeaders = () + +type Headers = [Header] + +defaultNewUserHeaders :: UserHeaders +defaultNewUserHeaders = () + +loadAllHeaders :: IO (HashMap.HashMap Text Headers) +-- TODO load dhall, not JSON... +loadAllHeaders = getExpr >>= \case + Just expr -> case eitherDecodeStrict' expr of + Left err -> fail err + Right result -> pure $ convert $ result + Nothing -> pure HashMap.empty + where + convert :: HashMap.HashMap Text (HashMap.HashMap Text Text) -> HashMap Text Headers + convert = HashMap.map toHeaders + + toHeaders :: HashMap.HashMap Text Text -> Headers + toHeaders hmap = map toHeader (HashMap.toList hmap) + + toHeader :: (Text, Text) -> Header + toHeader (k, v) = (CI.mk (encodeUtf8 k), encodeUtf8 v) + + getExpr :: IO (Maybe B.ByteString) + getExpr = lookupEnv "DHALL_HEADERS" >>= \case + Just expr -> pure $ Just $ encodeUtf8 $ Text.pack expr + Nothing -> loadConfigFile + + configSuffix = "dhall" "headers.dhall" + loadConfigFile = getXdgDirectory XdgConfig configSuffix >>= tryReadFile + + tryReadFile path = rightToMaybe <$> + tryJust (guard . isDoesNotExistError) (B.readFile path) + +addUserHeaders :: HTTP.Request -> HashMap Text Headers -> HTTP.Request +addUserHeaders request config = addHeaders $ HashMap.lookupDefault [] origin config where + origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) + + -- TODO how should we combine user / explicit headers? + -- I think for forwards compat we should override mheaders (if any) + -- with userHeaders. + -- TODO check how library deals with multiple conflicting headers + -- in the list + addHeaders newHeaders = request { + HTTP.requestHeaders = (HTTP.requestHeaders request) <> newHeaders + } + +-- TODO make this lazy / load only once (see ./HTTP newManager) +withUserHeaders :: UserHeaders -> HTTP.Request -> IO HTTP.Request +withUserHeaders () request = addUserHeaders request <$> loadAllHeaders \ No newline at end of file From 01438f182dc355528b93e7f7f1a22f21dddc034f Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 24 Jul 2021 11:13:26 +1000 Subject: [PATCH 02/22] load headers as dhall expressions, not JSON --- dhall/dhall.cabal | 6 +- dhall/ghc-src/Dhall/Import/Manager.hs | 15 ++- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 92 ++++++++----- dhall/src/Dhall/Import.hs | 117 ++++++---------- dhall/src/Dhall/Import/Headers.hs | 154 ++++++++++++++++++++++ dhall/src/Dhall/Import/Types.hs | 9 -- dhall/tests/Dhall/Test/Import.hs | 14 +- 7 files changed, 282 insertions(+), 125 deletions(-) create mode 100644 dhall/src/Dhall/Import/Headers.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 944e8d971..50a67accf 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 @@ -620,10 +621,11 @@ Library Autogen-Modules: Paths_dhall if flag(with-http) - Other-Modules: - Dhall.Import.HTTP + Exposed-Modules: Dhall.Import.Manager Dhall.Import.UserHeaders + Other-Modules: + Dhall.Import.HTTP GHC-Options: -Wall -fwarn-incomplete-uni-patterns Default-Language: Haskell2010 diff --git a/dhall/ghc-src/Dhall/Import/Manager.hs b/dhall/ghc-src/Dhall/Import/Manager.hs index 7cf1324d0..8849b2ab3 100644 --- a/dhall/ghc-src/Dhall/Import/Manager.hs +++ b/dhall/ghc-src/Dhall/Import/Manager.hs @@ -15,11 +15,15 @@ module Dhall.Import.Manager ( -- * Manager Manager(..) - , defaultNewManager + , makeDefaultNewManager ) where import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as HTTP + +import Dhall.Core (Expr, Import) +import Dhall.Parser (Src) +import Dhall.Import.Headers (SiteHeaders) import Dhall.Import.UserHeaders (UserHeaders, defaultNewUserHeaders) #ifdef USE_HTTP_CLIENT_TLS @@ -28,8 +32,8 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) data Manager = Manager { httpManager :: Client.Manager, headersManager :: UserHeaders } -defaultNewManager :: IO Manager -defaultNewManager = +makeDefaultNewManager :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> IO Manager +makeDefaultNewManager loadHeaderExpression = build <$> (Client.newManager #ifdef USE_HTTP_CLIENT_TLS tlsManagerSettings @@ -38,4 +42,7 @@ defaultNewManager = #endif { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds ) where - build httpManager = Manager { httpManager, headersManager = defaultNewUserHeaders } \ No newline at end of file + build httpManager = Manager { + httpManager, + headersManager = defaultNewUserHeaders loadHeaderExpression + } \ No newline at end of file diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index dfc398a1b..f1f161960 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -1,18 +1,20 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} module Dhall.Import.UserHeaders ( UserHeaders , Headers , defaultNewUserHeaders + , noopUserHeaders , withUserHeaders ) where -import Data.Aeson (eitherDecodeStrict') import Data.HashMap.Strict (HashMap) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import qualified Data.Text.IO as IO +import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Types (Header) import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) import System.Environment (lookupEnv) @@ -20,48 +22,76 @@ import System.FilePath (()) import Data.Either.Combinators (rightToMaybe) import Control.Exception (tryJust) import Control.Monad (guard) +import Control.Monad.Catch (throwM) import System.IO.Error (isDoesNotExistError) -import qualified Data.ByteString as B -import qualified Data.CaseInsensitive as CI +import Dhall.Core (Expr, Import) +import Dhall.Parser (Src) +import Dhall.Import.Headers (SiteHeaders) +import qualified Dhall.Parser as Parser import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text import qualified Network.HTTP.Client as HTTP --- todo StateT? -type UserHeaders = () +-- TODO StateT? +data UserHeaders = UserHeaders { + -- This loading function needs to be injected, because + -- it would be circular for this module to depend on Import + loadRelativeTo :: FilePath -> Expr Src Import -> IO SiteHeaders, + + -- Injected in order for tests to use a no-op implementation + resolveHeaderExpression :: IO (Maybe (FilePath, Text)) +} type Headers = [Header] -defaultNewUserHeaders :: UserHeaders -defaultNewUserHeaders = () +noopResolveHeaderExpression :: IO (Maybe (FilePath, Text)) +noopResolveHeaderExpression = return Nothing -loadAllHeaders :: IO (HashMap.HashMap Text Headers) --- TODO load dhall, not JSON... -loadAllHeaders = getExpr >>= \case - Just expr -> case eitherDecodeStrict' expr of - Left err -> fail err - Right result -> pure $ convert $ result - Nothing -> pure HashMap.empty - where - convert :: HashMap.HashMap Text (HashMap.HashMap Text Text) -> HashMap Text Headers - convert = HashMap.map toHeaders +{-| Resolve the raw dhall text for user headers, + along with the directory containing it + (which is `.` if loaded from $DHALL_HEADERS) + -} +defaultResolveHeaderExpression :: IO (Maybe (FilePath, Text)) +defaultResolveHeaderExpression = + lookupEnv "DHALL_HEADERS" >>= \case + Just expr -> return $ Just (".", Text.pack expr) + Nothing -> loadConfigFile - toHeaders :: HashMap.HashMap Text Text -> Headers - toHeaders hmap = map toHeader (HashMap.toList hmap) + where - toHeader :: (Text, Text) -> Header - toHeader (k, v) = (CI.mk (encodeUtf8 k), encodeUtf8 v) + loadConfigFile = do + directory <- getXdgDirectory XdgConfig "dhall" + fileContents <- tryReadFile (directory "headers.dhall") + let withDirectory text = (directory, text) + return $ fmap withDirectory fileContents - getExpr :: IO (Maybe B.ByteString) - getExpr = lookupEnv "DHALL_HEADERS" >>= \case - Just expr -> pure $ Just $ encodeUtf8 $ Text.pack expr - Nothing -> loadConfigFile + tryReadFile path = rightToMaybe <$> + tryJust (guard . isDoesNotExistError) (IO.readFile path) - configSuffix = "dhall" "headers.dhall" - loadConfigFile = getXdgDirectory XdgConfig configSuffix >>= tryReadFile +defaultNewUserHeaders :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> UserHeaders +defaultNewUserHeaders loadRelativeTo = UserHeaders + { loadRelativeTo + , resolveHeaderExpression = defaultResolveHeaderExpression + } - tryReadFile path = rightToMaybe <$> - tryJust (guard . isDoesNotExistError) (B.readFile path) +noopUserHeaders :: UserHeaders +noopUserHeaders = UserHeaders + { resolveHeaderExpression = noopResolveHeaderExpression + , loadRelativeTo = const $ fail "impossible" + } + +loadHeaderExpr :: UserHeaders -> FilePath -> Text -> IO SiteHeaders +loadHeaderExpr UserHeaders { loadRelativeTo } directory text = do + -- TODO surely there's a helper for this + expr <- case Parser.exprFromText mempty text of + Left exn -> throwM exn + Right expr -> pure expr + loadRelativeTo directory expr + +loadAllHeaders :: UserHeaders -> IO SiteHeaders +loadAllHeaders userHeaders = resolveHeaderExpression userHeaders >>= \case + Nothing -> pure HashMap.empty + Just (directory, text) -> loadHeaderExpr userHeaders directory text addUserHeaders :: HTTP.Request -> HashMap Text Headers -> HTTP.Request addUserHeaders request config = addHeaders $ HashMap.lookupDefault [] origin config where @@ -78,4 +108,4 @@ addUserHeaders request config = addHeaders $ HashMap.lookupDefault [] origin con -- TODO make this lazy / load only once (see ./HTTP newManager) withUserHeaders :: UserHeaders -> HTTP.Request -> IO HTTP.Request -withUserHeaders () request = addUserHeaders request <$> loadAllHeaders \ No newline at end of file +withUserHeaders userHeaders request = addUserHeaders request <$> (loadAllHeaders userHeaders) \ No newline at end of file diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 0583139ae..00e35c598 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -152,7 +152,7 @@ module Dhall.Import ( , HashMismatch(..) ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception ( Exception , IOException @@ -164,7 +164,6 @@ 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.Text (Text) import Data.Typeable (Typeable) @@ -191,7 +190,15 @@ import System.FilePath (()) #ifdef WITH_HTTP import Dhall.Import.HTTP +import qualified Dhall.Import.Manager as Manager #endif +import Dhall.Import.Headers + ( HTTPHeader + , SiteHeaders + , toHeaders + , toSiteHeaders + , normalizeHeaders + ) import Dhall.Import.Types import Dhall.Parser @@ -209,12 +216,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 +359,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 +502,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'))) @@ -805,29 +806,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,53 +997,38 @@ 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 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 + 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 + +-- TODO better error reporting +remoteDisabledNewManager :: IO Manager +remoteDisabledNewManager = fail "manager disabled" + +-- Injected into Manager for loading header expressions +-- TODO are we representing the source (DHALL_HEADERS / headers.dhall) +-- properly in errors? +loadHeaderExpression :: FilePath -> Expr Src Import -> IO SiteHeaders +loadHeaderExpression directory contents = do + expr <- loadRelativeToWithManager + remoteDisabledNewManager + directory + UseSemanticCache + contents + toSiteHeaders expr + +defaultNewManager :: IO Manager +#ifndef WITH_HTTP +defaultNewManager = pure () +#else +defaultNewManager = Manager.makeDefaultNewManager loadHeaderExpression +#endif -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs new file mode 100644 index 000000000..d6cb2068f --- /dev/null +++ b/dhall/src/Dhall/Import/Headers.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Dhall.Import.Headers ( + HTTPHeader + , SiteHeaders + , toHeaders + , toSiteHeaders + , normalizeHeaders + ) where + +import Control.Applicative (Alternative (..), liftA2) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) +import Data.Text (Text) +import Data.Void (Void, absurd) +import Control.Monad.Catch (MonadCatch (catch), handle, throwM) + +import Dhall.Syntax + ( Chunks (..) + , Expr (..) + ) + +import Dhall.Parser + ( ParseError (..) + , Parser (..) + , SourcedException (..) + , Src (..) + ) + +import Control.Exception + ( Exception + , IOException + , SomeException + , toException + ) + +import qualified Data.CaseInsensitive +import qualified Data.Foldable +import qualified Data.Text.Encoding +import qualified Dhall.Core as Core +import qualified Dhall.Map +import qualified Dhall.TypeCheck +import qualified Dhall.Pretty.Internal + + +-- | HTTP headers +type HTTPHeader = (CI ByteString, ByteString) + +-- | A map of site origin -> HTTP headers +type SiteHeaders = HashMap Text [HTTPHeader] + +-- | 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 the SiteHeaders from a given expression. +toSiteHeaders :: Expr Src Void -> IO SiteHeaders +toSiteHeaders expr = fmap convert (normalizeSiteHeaders expr) + where + convert :: Expr s a -> SiteHeaders + convert (ListLit _ hs) = HashMap.fromList (sitePairs hs) + convert _ = mempty + + sitePairs hs = Data.Foldable.toList (Data.Foldable.fold (mapM toSitePair hs)) + + toSitePair :: Expr s a -> Maybe (Text, [HTTPHeader]) + toSitePair (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) + toSitePair _ = 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" + +siteHeadersTypeExpr :: Expr Src Void +siteHeadersTypeExpr = + 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) + +normalizeSiteHeaders :: Expr Src Void -> IO (Expr Src Void) +normalizeSiteHeaders = typecheck siteHeadersTypeExpr \ No newline at end of file diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 52bf5dc50..53063eb3f 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -68,15 +68,6 @@ type Manager = () #endif --- | The default HTTP 'Manager' -defaultNewManager :: IO Manager -defaultNewManager = -#ifdef WITH_HTTP - Dhall.Import.Manager.defaultNewManager -#else - pure () -#endif - {-| Used internally to track whether or not we've already warned the user about caching issues -} diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 208a98961..58464b95f 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -9,6 +9,7 @@ import Data.Void (Void) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath, ()) +import Dhall.Import.Manager (Manager(..)) import qualified Control.Exception as Exception import qualified Control.Monad as Monad @@ -17,6 +18,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Core as Core import qualified Dhall.Import as Import +import qualified Dhall.Import.UserHeaders as UserHeaders import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util import qualified Network.HTTP.Client as HTTP @@ -101,14 +103,22 @@ successTest prefix = do let originalCache = "dhall-lang/tests/import/cache" - let httpManager = + let newHttpManager = HTTP.newManager HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) } + + let newManager = do + http <- newHttpManager + return Manager { + httpManager = http, + headersManager = UserHeaders.noopUserHeaders + } + let load = State.evalStateT (Test.Util.loadWith actualExpr) - (Import.emptyStatusWithManager httpManager directoryString) + (Import.emptyStatusWithManager newManager directoryString) let usesCache = [ "hashFromCache" , "unit/asLocation/Hash" From b60c084d1c7a13e74b159308832e0a1bc54eb0a8 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 25 Jul 2021 17:03:16 +1000 Subject: [PATCH 03/22] load headers from env in tests --- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 20 ++++++++++++++++++-- dhall/src/Dhall/Import.hs | 7 ++++--- dhall/tests/Dhall/Test/Import.hs | 2 +- 3 files changed, 23 insertions(+), 6 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index f1f161960..30fcc48fb 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -7,6 +7,7 @@ module Dhall.Import.UserHeaders UserHeaders , Headers , defaultNewUserHeaders + , envOnlyNewUserHeaders , noopUserHeaders , withUserHeaders ) where @@ -47,14 +48,23 @@ type Headers = [Header] noopResolveHeaderExpression :: IO (Maybe (FilePath, Text)) noopResolveHeaderExpression = return Nothing +{-| Resolve the raw dhall text for user headers + only from $DHALL_HEADERS, not the filesystem + -} +envOnlyResolveHeaderExpression :: IO (Maybe (FilePath, Text)) +envOnlyResolveHeaderExpression = + fmap (fmap fromEnv) (lookupEnv "DHALL_HEADERS") + where + fromEnv expr = (".", Text.pack expr) + {-| Resolve the raw dhall text for user headers, along with the directory containing it (which is `.` if loaded from $DHALL_HEADERS) -} defaultResolveHeaderExpression :: IO (Maybe (FilePath, Text)) defaultResolveHeaderExpression = - lookupEnv "DHALL_HEADERS" >>= \case - Just expr -> return $ Just (".", Text.pack expr) + envOnlyResolveHeaderExpression >>= \case + Just pair -> return (Just pair) Nothing -> loadConfigFile where @@ -74,6 +84,12 @@ defaultNewUserHeaders loadRelativeTo = UserHeaders , resolveHeaderExpression = defaultResolveHeaderExpression } +envOnlyNewUserHeaders :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> UserHeaders +envOnlyNewUserHeaders loadRelativeTo = UserHeaders + { loadRelativeTo + , resolveHeaderExpression = envOnlyResolveHeaderExpression + } + noopUserHeaders :: UserHeaders noopUserHeaders = UserHeaders { resolveHeaderExpression = noopResolveHeaderExpression diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 00e35c598..45e9bf9a5 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -117,6 +117,7 @@ module Dhall.Import ( , assertNoImports , Manager , defaultNewManager + , loadSiteHeaders , CacheWarning(..) , Status(..) , SemanticCacheMode(..) @@ -1014,8 +1015,8 @@ remoteDisabledNewManager = fail "manager disabled" -- Injected into Manager for loading header expressions -- TODO are we representing the source (DHALL_HEADERS / headers.dhall) -- properly in errors? -loadHeaderExpression :: FilePath -> Expr Src Import -> IO SiteHeaders -loadHeaderExpression directory contents = do +loadSiteHeaders :: FilePath -> Expr Src Import -> IO SiteHeaders +loadSiteHeaders directory contents = do expr <- loadRelativeToWithManager remoteDisabledNewManager directory @@ -1027,7 +1028,7 @@ defaultNewManager :: IO Manager #ifndef WITH_HTTP defaultNewManager = pure () #else -defaultNewManager = Manager.makeDefaultNewManager loadHeaderExpression +defaultNewManager = Manager.makeDefaultNewManager loadSiteHeaders #endif -- | Default starting `Status`, importing relative to the given directory. diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 58464b95f..08788c69d 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -112,7 +112,7 @@ successTest prefix = do http <- newHttpManager return Manager { httpManager = http, - headersManager = UserHeaders.noopUserHeaders + headersManager = UserHeaders.envOnlyNewUserHeaders Import.loadSiteHeaders } let load = From 8c859bb70931b80a376643f9d93ea85a3263b131 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 25 Jul 2021 17:19:15 +1000 Subject: [PATCH 04/22] user headers take precedent over inline headers --- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 30 ++++++++++++----------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index 30fcc48fb..529c1395f 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -14,6 +14,8 @@ module Dhall.Import.UserHeaders import Data.HashMap.Strict (HashMap) import Data.Text (Text) +import Data.ByteString (ByteString) +import Data.CaseInsensitive (CI) import qualified Data.Text.IO as IO import Data.Text.Encoding (decodeUtf8) import Network.HTTP.Types (Header) @@ -23,9 +25,8 @@ import System.FilePath (()) import Data.Either.Combinators (rightToMaybe) import Control.Exception (tryJust) import Control.Monad (guard) -import Control.Monad.Catch (throwM) import System.IO.Error (isDoesNotExistError) -import Dhall.Core (Expr, Import) +import Dhall.Core (Expr, Import, throws) import Dhall.Parser (Src) import Dhall.Import.Headers (SiteHeaders) import qualified Dhall.Parser as Parser @@ -98,10 +99,7 @@ noopUserHeaders = UserHeaders loadHeaderExpr :: UserHeaders -> FilePath -> Text -> IO SiteHeaders loadHeaderExpr UserHeaders { loadRelativeTo } directory text = do - -- TODO surely there's a helper for this - expr <- case Parser.exprFromText mempty text of - Left exn -> throwM exn - Right expr -> pure expr + expr <- throws (Parser.exprFromText mempty text) loadRelativeTo directory expr loadAllHeaders :: UserHeaders -> IO SiteHeaders @@ -113,14 +111,18 @@ addUserHeaders :: HTTP.Request -> HashMap Text Headers -> HTTP.Request addUserHeaders request config = addHeaders $ HashMap.lookupDefault [] origin config where origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) - -- TODO how should we combine user / explicit headers? - -- I think for forwards compat we should override mheaders (if any) - -- with userHeaders. - -- TODO check how library deals with multiple conflicting headers - -- in the list - addHeaders newHeaders = request { - HTTP.requestHeaders = (HTTP.requestHeaders request) <> newHeaders - } + addHeaders newHeaders = + request { + HTTP.requestHeaders = originalHeaders <> newHeaders + } + where + originalHeaders = filter (not . overridden) (HTTP.requestHeaders request) + + overridden :: Header -> Bool + overridden (key, _value) = any (matchesKey key) newHeaders + + matchesKey :: CI ByteString -> Header -> Bool + matchesKey key (candidate, _value) = key == candidate -- TODO make this lazy / load only once (see ./HTTP newManager) withUserHeaders :: UserHeaders -> HTTP.Request -> IO HTTP.Request From 5c0711cfb5477952533dcb611db0c005ba30a67c Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 1 Aug 2021 14:36:51 +1000 Subject: [PATCH 05/22] move UserHeaders out of HTTP manager --- dhall/ghc-src/Dhall/Import/HTTP.hs | 53 +++++++-- dhall/ghc-src/Dhall/Import/Manager.hs | 29 ++--- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 127 +++++----------------- dhall/src/Dhall/Import.hs | 117 ++++++++++++-------- dhall/src/Dhall/Import/Headers.hs | 51 +++------ dhall/src/Dhall/Import/Types.hs | 30 ++++- dhall/tests/Dhall/Test/Import.hs | 19 ++-- 7 files changed, 199 insertions(+), 227 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index c037379d7..1a99458f3 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -12,7 +12,9 @@ import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Data.Dynamic (toDyn) +import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text.Encoding (decodeUtf8) import Dhall.Core ( Import (..) , ImportHashed (..) @@ -22,7 +24,6 @@ import Dhall.Core ) import Dhall.Import.Types hiding (Manager) import Dhall.Import.Manager (Manager(..)) -import Dhall.Import.UserHeaders (withUserHeaders) import Dhall.URL (renderURL) @@ -33,6 +34,7 @@ import Network.HTTP.Client 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 @@ -169,6 +171,21 @@ newManager = do Just manager -> return manager +getSiteHeaders :: StateT Status IO SiteHeaders +getSiteHeaders = do + Status { _siteHeaders = oldSiteHeaders, ..} <- State.get + + case oldSiteHeaders of + Nothing -> do + siteHeaders <- liftIO _loadSiteHeaders + + State.put (Status { _siteHeaders = Just siteHeaders , ..}) + + return siteHeaders + + Just siteHeaders -> + return siteHeaders + data NotCORSCompliant = NotCORSCompliant { expectedOrigins :: [ByteString] , actualOrigin :: ByteString @@ -244,24 +261,38 @@ corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () -type HTTPHeader = Network.HTTP.Types.Header +-- type HTTPHeader = Network.HTTP.Types.Header + +addHeaders :: SiteHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request +addHeaders siteHeaders urlHeaders request = + request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> originHeaders } + where + origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) + + originHeaders = HashMap.lookupDefault [] origin siteHeaders + + filterHeaders Nothing = [] + filterHeaders (Just urlHeaders) = filter (not . overridden) urlHeaders + + overridden :: HTTPHeader -> Bool + overridden (key, _value) = any (matchesKey key) originHeaders + + matchesKey :: CI ByteString -> HTTPHeader -> Bool + matchesKey key (candidate, _value) = key == candidate fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do - Manager { httpManager, headersManager } <- newManager + siteHeaders <- getSiteHeaders - let childURLString = Text.unpack (renderURL childURL) + manager <- newManager - request <- liftIO (HTTP.parseUrlThrow childURLString) + let childURLString = Text.unpack (renderURL childURL) - let baseRequest = - case mheaders of - Nothing -> request - Just headers -> request { HTTP.requestHeaders = headers } + baseRequest <- liftIO (HTTP.parseUrlThrow childURLString) - requestWithHeaders <- liftIO (withUserHeaders headersManager baseRequest) + let requestWithHeaders = addHeaders siteHeaders mheaders baseRequest - let io = HTTP.httpLbs requestWithHeaders httpManager + let io = HTTP.httpLbs requestWithHeaders manager let handler e = do let _ = e :: HttpException diff --git a/dhall/ghc-src/Dhall/Import/Manager.hs b/dhall/ghc-src/Dhall/Import/Manager.hs index 8849b2ab3..1926f41a1 100644 --- a/dhall/ghc-src/Dhall/Import/Manager.hs +++ b/dhall/ghc-src/Dhall/Import/Manager.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-| Both the GHC and GHCJS implementations of 'Dhall.Import.Manager.Manager' export a `Dhall.Import.Manager.Manager` type suitable for use within the @@ -14,35 +12,22 @@ -} module Dhall.Import.Manager ( -- * Manager - Manager(..) - , makeDefaultNewManager + Manager + , defaultNewManager ) where -import qualified Network.HTTP.Client as Client +import Network.HTTP.Client (Manager, newManager) import qualified Network.HTTP.Client as HTTP -import Dhall.Core (Expr, Import) -import Dhall.Parser (Src) -import Dhall.Import.Headers (SiteHeaders) -import Dhall.Import.UserHeaders (UserHeaders, defaultNewUserHeaders) - #ifdef USE_HTTP_CLIENT_TLS import Network.HTTP.Client.TLS (tlsManagerSettings) #endif -data Manager = Manager { httpManager :: Client.Manager, headersManager :: UserHeaders } - -makeDefaultNewManager :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> IO Manager -makeDefaultNewManager loadHeaderExpression = - build <$> (Client.newManager +defaultNewManager :: IO Manager +defaultNewManager = newManager #ifdef USE_HTTP_CLIENT_TLS - tlsManagerSettings + tlsManagerSettings #else - HTTP.defaultManagerSettings + HTTP.defaultManagerSettings #endif { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (30 * 1000 * 1000) } -- 30 seconds - ) where - build httpManager = Manager { - httpManager, - headersManager = defaultNewUserHeaders loadHeaderExpression - } \ No newline at end of file diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index 529c1395f..f44228758 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -3,22 +3,12 @@ {-# LANGUAGE NamedFieldPuns #-} module Dhall.Import.UserHeaders - ( - UserHeaders - , Headers - , defaultNewUserHeaders - , envOnlyNewUserHeaders - , noopUserHeaders - , withUserHeaders + ( defaultUserHeaders + , envOnlyUserHeaders ) where -import Data.HashMap.Strict (HashMap) import Data.Text (Text) -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) import qualified Data.Text.IO as IO -import Data.Text.Encoding (decodeUtf8) -import Network.HTTP.Types (Header) import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) import System.Environment (lookupEnv) import System.FilePath (()) @@ -26,104 +16,41 @@ import Data.Either.Combinators (rightToMaybe) import Control.Exception (tryJust) import Control.Monad (guard) import System.IO.Error (isDoesNotExistError) -import Dhall.Core (Expr, Import, throws) -import Dhall.Parser (Src) -import Dhall.Import.Headers (SiteHeaders) +import Dhall.Core (throws) +import Dhall.Import.Types (SiteHeadersFile(..)) import qualified Dhall.Parser as Parser -import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as Text -import qualified Network.HTTP.Client as HTTP --- TODO StateT? -data UserHeaders = UserHeaders { - -- This loading function needs to be injected, because - -- it would be circular for this module to depend on Import - loadRelativeTo :: FilePath -> Expr Src Import -> IO SiteHeaders, +parseFrom :: FilePath -> Text -> IO SiteHeadersFile +parseFrom parentDirectory text = do + expr <- throws (Parser.exprFromText mempty text) + return (SiteHeadersFile { parentDirectory , expr }) - -- Injected in order for tests to use a no-op implementation - resolveHeaderExpression :: IO (Maybe (FilePath, Text)) -} - -type Headers = [Header] - -noopResolveHeaderExpression :: IO (Maybe (FilePath, Text)) -noopResolveHeaderExpression = return Nothing +parseFrom' :: FilePath -> IO (Maybe Text) -> IO (Maybe SiteHeadersFile) +parseFrom' parentDirectory getText = do + mtext <- getText + mapM (parseFrom parentDirectory) mtext {-| Resolve the raw dhall text for user headers only from $DHALL_HEADERS, not the filesystem -} -envOnlyResolveHeaderExpression :: IO (Maybe (FilePath, Text)) -envOnlyResolveHeaderExpression = - fmap (fmap fromEnv) (lookupEnv "DHALL_HEADERS") - where - fromEnv expr = (".", Text.pack expr) +envOnlyUserHeaders :: IO (Maybe SiteHeadersFile) +envOnlyUserHeaders = + parseFrom' "." (fmap (fmap Text.pack) (lookupEnv "DHALL_HEADERS")) {-| Resolve the raw dhall text for user headers, along with the directory containing it (which is `.` if loaded from $DHALL_HEADERS) -} -defaultResolveHeaderExpression :: IO (Maybe (FilePath, Text)) -defaultResolveHeaderExpression = - envOnlyResolveHeaderExpression >>= \case - Just pair -> return (Just pair) - Nothing -> loadConfigFile - - where - - loadConfigFile = do - directory <- getXdgDirectory XdgConfig "dhall" - fileContents <- tryReadFile (directory "headers.dhall") - let withDirectory text = (directory, text) - return $ fmap withDirectory fileContents - - tryReadFile path = rightToMaybe <$> - tryJust (guard . isDoesNotExistError) (IO.readFile path) - -defaultNewUserHeaders :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> UserHeaders -defaultNewUserHeaders loadRelativeTo = UserHeaders - { loadRelativeTo - , resolveHeaderExpression = defaultResolveHeaderExpression - } - -envOnlyNewUserHeaders :: (FilePath -> Expr Src Import -> IO SiteHeaders) -> UserHeaders -envOnlyNewUserHeaders loadRelativeTo = UserHeaders - { loadRelativeTo - , resolveHeaderExpression = envOnlyResolveHeaderExpression - } - -noopUserHeaders :: UserHeaders -noopUserHeaders = UserHeaders - { resolveHeaderExpression = noopResolveHeaderExpression - , loadRelativeTo = const $ fail "impossible" - } - -loadHeaderExpr :: UserHeaders -> FilePath -> Text -> IO SiteHeaders -loadHeaderExpr UserHeaders { loadRelativeTo } directory text = do - expr <- throws (Parser.exprFromText mempty text) - loadRelativeTo directory expr - -loadAllHeaders :: UserHeaders -> IO SiteHeaders -loadAllHeaders userHeaders = resolveHeaderExpression userHeaders >>= \case - Nothing -> pure HashMap.empty - Just (directory, text) -> loadHeaderExpr userHeaders directory text - -addUserHeaders :: HTTP.Request -> HashMap Text Headers -> HTTP.Request -addUserHeaders request config = addHeaders $ HashMap.lookupDefault [] origin config where - origin = decodeUtf8 (HTTP.host request) <> ":" <> Text.pack (show (HTTP.port request)) - - addHeaders newHeaders = - request { - HTTP.requestHeaders = originalHeaders <> newHeaders - } - where - originalHeaders = filter (not . overridden) (HTTP.requestHeaders request) - - overridden :: Header -> Bool - overridden (key, _value) = any (matchesKey key) newHeaders - - matchesKey :: CI ByteString -> Header -> Bool - matchesKey key (candidate, _value) = key == candidate - --- TODO make this lazy / load only once (see ./HTTP newManager) -withUserHeaders :: UserHeaders -> HTTP.Request -> IO HTTP.Request -withUserHeaders userHeaders request = addUserHeaders request <$> (loadAllHeaders userHeaders) \ No newline at end of file +defaultUserHeaders :: IO (Maybe SiteHeadersFile) +defaultUserHeaders = + envOnlyUserHeaders >>= \case + Just file -> return (Just file) + Nothing -> loadConfigFile + where + loadConfigFile = do + directory <- getXdgDirectory XdgConfig "dhall" + parseFrom' directory (tryReadFile (directory "headers.dhall")) + + tryReadFile path = rightToMaybe <$> + tryJust (guard . isDoesNotExistError) (IO.readFile path) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 45e9bf9a5..c3c1dd641 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} @@ -108,7 +109,7 @@ module Dhall.Import ( load , loadWithManager , loadRelativeTo - , loadRelativeToWithManager + , loadRelativeToWithStatus , loadWith , localToPath , hashExpression @@ -117,7 +118,6 @@ module Dhall.Import ( , assertNoImports , Manager , defaultNewManager - , loadSiteHeaders , CacheWarning(..) , Status(..) , SemanticCacheMode(..) @@ -127,8 +127,10 @@ module Dhall.Import ( , chainedChangeMode , emptyStatus , emptyStatusWithManager + , makeEmptyStatus , remoteStatus , remoteStatusWithManager + , defaultFetchRemote , stack , cache , Depends(..) @@ -191,16 +193,15 @@ import System.FilePath (()) #ifdef WITH_HTTP import Dhall.Import.HTTP -import qualified Dhall.Import.Manager as Manager #endif import Dhall.Import.Headers - ( HTTPHeader - , SiteHeaders - , toHeaders + ( toHeaders , toSiteHeaders , normalizeHeaders ) +import Dhall.Import.Manager (defaultNewManager) import Dhall.Import.Types +import Dhall.Import.UserHeaders (defaultUserHeaders) import Dhall.Parser ( ParseError (..) @@ -381,6 +382,17 @@ instance Show CannotImportHTTPURL where <> url <> "\n" +data CannotImportFromHeadersFile = + CannotImportFromHeadersFile + deriving (Typeable) + +instance Exception CannotImportFromHeadersFile + +instance Show CannotImportFromHeadersFile where + show CannotImportFromHeadersFile = + "\n" + <> "\ESC[1;31mError\ESC[0m: Cannot import a remote URL from the headers configuration expression.\n" + {-| > canonicalize . canonicalize = canonicalize @@ -788,16 +800,20 @@ fetchFresh (Env env) = do fetchFresh Missing = throwM (MissingImports []) +fetchDisabledForHeaders :: URL -> StateT Status IO Data.Text.Text +fetchDisabledForHeaders _url = do + Status { _stack } <- State.get + throwMissingImport (Imported _stack CannotImportFromHeadersFile) -fetchRemote :: URL -> StateT Status IO Data.Text.Text +defaultFetchRemote :: URL -> StateT Status IO Data.Text.Text #ifndef WITH_HTTP -fetchRemote (url@URL { headers = maybeHeadersExpression }) = do +defaultFetchRemote (url@URL { headers = maybeHeadersExpression }) = do let maybeHeaders = fmap toHeaders maybeHeadersExpression let urlString = Text.unpack (Core.pretty url) Status { _stack } <- State.get throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders)) #else -fetchRemote url = do +defaultFetchRemote url = do zoom remote (State.put fetchFromHTTP) fetchFromHTTP url where @@ -1008,37 +1024,49 @@ normalizeHeadersIn url@URL { headers = Just headersExpression } = do normalizeHeadersIn url = return url --- TODO better error reporting -remoteDisabledNewManager :: IO Manager -remoteDisabledNewManager = fail "manager disabled" - --- Injected into Manager for loading header expressions --- TODO are we representing the source (DHALL_HEADERS / headers.dhall) --- properly in errors? -loadSiteHeaders :: FilePath -> Expr Src Import -> IO SiteHeaders -loadSiteHeaders directory contents = do - expr <- loadRelativeToWithManager - remoteDisabledNewManager - directory - UseSemanticCache - contents - toSiteHeaders expr - -defaultNewManager :: IO Manager -#ifndef WITH_HTTP -defaultNewManager = pure () -#else -defaultNewManager = Manager.makeDefaultNewManager loadSiteHeaders -#endif +-- | A no-op user headers loader used for remote contexts +-- (and loading user headers themselves) +noopUserHeaders :: IO (Maybe SiteHeadersFile) +noopUserHeaders = return Nothing + +-- Given a SiteHeadersFile loader, return a SiteHeaders loader. +siteHeadersLoader :: IO (Maybe SiteHeadersFile) -> IO SiteHeaders +siteHeadersLoader loadSideHeadersFile = do + loadSideHeadersFile >>= \case + Nothing -> return mempty + Just (SiteHeadersFile { parentDirectory, expr }) -> do + -- TODO are we representing the source (DHALL_HEADERS / headers.dhall) + -- properly in errors? + loaded <- loadRelativeToWithStatus + (makeEmptyStatus + defaultNewManager + noopUserHeaders + fetchDisabledForHeaders + parentDirectory) + IgnoreSemanticCache + expr + + toSiteHeaders loaded -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = emptyStatusWithManager defaultNewManager +emptyStatus = makeEmptyStatus defaultNewManager defaultUserHeaders defaultFetchRemote + +emptyStatusWithManager + :: IO Manager + -> FilePath + -> Status +emptyStatusWithManager newManager = makeEmptyStatus newManager defaultUserHeaders defaultFetchRemote -- | See 'emptyStatus'. -emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager rootDirectory = - emptyStatusWith newManager fetchRemote rootImport +makeEmptyStatus + :: IO Manager + -> IO (Maybe SiteHeadersFile) + -> (URL -> StateT Status IO Data.Text.Text) + -> FilePath + -> Status +makeEmptyStatus newManager loadSiteHeadersFile fetchRemote rootDirectory = + emptyStatusWith newManager (siteHeadersLoader loadSiteHeadersFile) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1071,7 +1099,7 @@ remoteStatus = remoteStatusWithManager defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager fetchRemote rootImport + emptyStatusWith newManager (siteHeadersLoader noopUserHeaders) defaultFetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1169,7 +1197,10 @@ load = loadWithManager defaultNewManager -- | See 'load'. loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) -loadWithManager newManager = loadRelativeToWithManager newManager "." UseSemanticCache +loadWithManager newManager = + loadRelativeToWithStatus + (makeEmptyStatus newManager defaultUserHeaders defaultFetchRemote ".") + UseSemanticCache printWarning :: (MonadIO m) => String -> m () printWarning message = do @@ -1183,19 +1214,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 = loadRelativeToWithStatus + (makeEmptyStatus defaultNewManager defaultUserHeaders defaultFetchRemote parentDirectory) -- | See 'loadRelativeTo'. -loadRelativeToWithManager - :: IO Manager - -> FilePath +loadRelativeToWithStatus + :: Status -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeToWithManager newManager rootDirectory semanticCacheMode expression = +loadRelativeToWithStatus 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 index d6cb2068f..4ad59c46e 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -2,56 +2,31 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -module Dhall.Import.Headers ( - HTTPHeader - , SiteHeaders - , toHeaders +module Dhall.Import.Headers + ( toHeaders , toSiteHeaders , normalizeHeaders ) where -import Control.Applicative (Alternative (..), liftA2) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.ByteString (ByteString) -import Data.CaseInsensitive (CI) -import Data.Text (Text) -import Data.Void (Void, absurd) -import Control.Monad.Catch (MonadCatch (catch), handle, throwM) - -import Dhall.Syntax - ( Chunks (..) - , Expr (..) - ) - -import Dhall.Parser - ( ParseError (..) - , Parser (..) - , SourcedException (..) - , Src (..) - ) - -import Control.Exception - ( Exception - , IOException - , SomeException - , toException - ) +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.Import.Types (HTTPHeader , SiteHeaders) +import Dhall.Parser (Src (..)) +import Dhall.Syntax (Chunks (..), Expr (..)) 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.Core as Core import qualified Dhall.Map import qualified Dhall.TypeCheck import qualified Dhall.Pretty.Internal --- | HTTP headers -type HTTPHeader = (CI ByteString, ByteString) - --- | A map of site origin -> HTTP headers -type SiteHeaders = HashMap Text [HTTPHeader] -- | Given a well-typed (of type `List { header : Text, value Text }` or -- `List { mapKey : Text, mapValue Text }`) headers expressions in normal form @@ -151,4 +126,4 @@ normalizeHeaders headersExpr = do handle handler₀ (typecheck headersTypeExpr headersExpr) normalizeSiteHeaders :: Expr Src Void -> IO (Expr Src Void) -normalizeSiteHeaders = typecheck siteHeadersTypeExpr \ No newline at end of file +normalizeSiteHeaders = typecheck siteHeadersTypeExpr diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 53063eb3f..a733b76fc 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.Text.Prettyprint.Doc (Pretty (..)) import Data.Void (Void) @@ -68,6 +71,19 @@ type Manager = () #endif +-- | HTTP headers +type HTTPHeader = (CI ByteString, ByteString) + +-- | A map of site origin -> HTTP headers +type SiteHeaders = HashMap Data.Text.Text [HTTPHeader] + +-- SiteHeadersFile is the raw (unresolved) expression +-- used to build SiteHeaders +data SiteHeadersFile = SiteHeadersFile { + parentDirectory :: FilePath, + expr :: Expr Src Import +} + {-| Used internally to track whether or not we've already warned the user about caching issues -} @@ -92,6 +108,10 @@ data Status = Status -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests + , _loadSiteHeaders :: IO SiteHeaders + , _siteHeaders :: Maybe SiteHeaders + -- ^ Used to cache the user's custom headers for all remote imports + , _remote :: URL -> StateT Status IO Data.Text.Text -- ^ The remote resolver, fetches the content at the given URL. @@ -108,14 +128,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 user headers and the remote resolver, +-- importing relative to the given root import. emptyStatusWith :: IO Manager + -> IO SiteHeaders -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status -emptyStatusWith _newManager _remote rootImport = Status {..} +emptyStatusWith _newManager _loadSiteHeaders _remote rootImport = Status {..} where _stack = pure (Chained rootImport) @@ -125,6 +147,8 @@ emptyStatusWith _newManager _remote rootImport = Status {..} _manager = Nothing + _siteHeaders = Nothing + _substitutions = Dhall.Substitution.empty _normalizer = Nothing diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 08788c69d..6bf5bdb6b 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -9,7 +9,6 @@ import Data.Void (Void) import Prelude hiding (FilePath) import Test.Tasty (TestTree) import Turtle (FilePath, ()) -import Dhall.Import.Manager (Manager(..)) import qualified Control.Exception as Exception import qualified Control.Monad as Monad @@ -18,7 +17,7 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Core as Core import qualified Dhall.Import as Import -import qualified Dhall.Import.UserHeaders as UserHeaders +import qualified Dhall.Import.UserHeaders as UserHeaders import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util import qualified Network.HTTP.Client as HTTP @@ -103,22 +102,22 @@ successTest prefix = do let originalCache = "dhall-lang/tests/import/cache" - let newHttpManager = + let httpManager = HTTP.newManager HTTP.tlsManagerSettings { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) } - let newManager = do - http <- newHttpManager - return Manager { - httpManager = http, - headersManager = UserHeaders.envOnlyNewUserHeaders Import.loadSiteHeaders - } + let status = + Import.makeEmptyStatus + httpManager + UserHeaders.envOnlyUserHeaders + Import.defaultFetchRemote + directoryString let load = State.evalStateT (Test.Util.loadWith actualExpr) - (Import.emptyStatusWithManager newManager directoryString) + status let usesCache = [ "hashFromCache" , "unit/asLocation/Hash" From d8ff7cedcd3d8c8b74a27626201adab33b3d83e1 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 1 Aug 2021 21:18:52 +1000 Subject: [PATCH 06/22] cleanup --- dhall/dhall.cabal | 2 +- dhall/ghc-src/Dhall/Import/HTTP.hs | 7 ++---- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 28 ++++++++++++----------- dhall/src/Dhall/Import.hs | 16 ++++++------- dhall/src/Dhall/Import/Headers.hs | 4 +--- dhall/src/Dhall/Import/Types.hs | 4 ++-- 6 files changed, 29 insertions(+), 32 deletions(-) diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index 50a67accf..99abae190 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -622,10 +622,10 @@ Library Paths_dhall if flag(with-http) Exposed-Modules: - Dhall.Import.Manager Dhall.Import.UserHeaders Other-Modules: Dhall.Import.HTTP + Dhall.Import.Manager GHC-Options: -Wall -fwarn-incomplete-uni-patterns Default-Language: Haskell2010 diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 1a99458f3..9dd3ae471 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -1,6 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} module Dhall.Import.HTTP ( fetchFromHttpUrl @@ -12,7 +11,6 @@ import Control.Monad.Trans.State.Strict (StateT) import Data.ByteString (ByteString) import Data.CaseInsensitive (CI) import Data.Dynamic (toDyn) -import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty(..)) import Data.Text.Encoding (decodeUtf8) import Dhall.Core @@ -22,8 +20,7 @@ import Dhall.Core , Scheme (..) , URL (..) ) -import Dhall.Import.Types hiding (Manager) -import Dhall.Import.Manager (Manager(..)) +import Dhall.Import.Types import Dhall.URL (renderURL) @@ -272,7 +269,7 @@ addHeaders siteHeaders urlHeaders request = originHeaders = HashMap.lookupDefault [] origin siteHeaders filterHeaders Nothing = [] - filterHeaders (Just urlHeaders) = filter (not . overridden) urlHeaders + filterHeaders (Just headers) = filter (not . overridden) headers overridden :: HTTPHeader -> Bool overridden (key, _value) = any (matchesKey key) originHeaders diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index f44228758..177f715c0 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -7,25 +7,27 @@ module Dhall.Import.UserHeaders , envOnlyUserHeaders ) where -import Data.Text (Text) -import qualified Data.Text.IO as IO -import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) -import System.Environment (lookupEnv) -import System.FilePath (()) -import Data.Either.Combinators (rightToMaybe) -import Control.Exception (tryJust) -import Control.Monad (guard) -import System.IO.Error (isDoesNotExistError) -import Dhall.Core (throws) -import Dhall.Import.Types (SiteHeadersFile(..)) -import qualified Dhall.Parser as Parser -import qualified Data.Text as Text +import Control.Exception (tryJust) +import Control.Monad (guard) +import Data.Either.Combinators (rightToMaybe) +import Data.Text (Text) +import Dhall.Core (throws) +import Dhall.Import.Types (SiteHeadersFile(..)) +import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) +import System.Environment (lookupEnv) +import System.FilePath (()) +import System.IO.Error (isDoesNotExistError) + +import qualified Data.Text as Text +import qualified Data.Text.IO as IO +import qualified Dhall.Parser as Parser parseFrom :: FilePath -> Text -> IO SiteHeadersFile parseFrom parentDirectory text = do expr <- throws (Parser.exprFromText mempty text) return (SiteHeadersFile { parentDirectory , expr }) +-- lift 'parseFrom' to work on IO (Maybe Text) parseFrom' :: FilePath -> IO (Maybe Text) -> IO (Maybe SiteHeadersFile) parseFrom' parentDirectory getText = do mtext <- getText diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index c3c1dd641..e7a1eec80 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -109,7 +109,7 @@ module Dhall.Import ( load , loadWithManager , loadRelativeTo - , loadRelativeToWithStatus + , loadWithStatus , loadWith , localToPath , hashExpression @@ -1029,15 +1029,15 @@ normalizeHeadersIn url = return url noopUserHeaders :: IO (Maybe SiteHeadersFile) noopUserHeaders = return Nothing --- Given a SiteHeadersFile loader, return a SiteHeaders loader. +-- | Given a SiteHeadersFile loader, return a SiteHeaders loader. siteHeadersLoader :: IO (Maybe SiteHeadersFile) -> IO SiteHeaders -siteHeadersLoader loadSideHeadersFile = do +siteHeadersLoader loadSideHeadersFile = loadSideHeadersFile >>= \case Nothing -> return mempty Just (SiteHeadersFile { parentDirectory, expr }) -> do -- TODO are we representing the source (DHALL_HEADERS / headers.dhall) -- properly in errors? - loaded <- loadRelativeToWithStatus + loaded <- loadWithStatus (makeEmptyStatus defaultNewManager noopUserHeaders @@ -1198,7 +1198,7 @@ load = loadWithManager defaultNewManager -- | See 'load'. loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) loadWithManager newManager = - loadRelativeToWithStatus + loadWithStatus (makeEmptyStatus newManager defaultUserHeaders defaultFetchRemote ".") UseSemanticCache @@ -1214,16 +1214,16 @@ 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 parentDirectory = loadRelativeToWithStatus +loadRelativeTo parentDirectory = loadWithStatus (makeEmptyStatus defaultNewManager defaultUserHeaders defaultFetchRemote parentDirectory) -- | See 'loadRelativeTo'. -loadRelativeToWithStatus +loadWithStatus :: Status -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) -loadRelativeToWithStatus status semanticCacheMode expression = +loadWithStatus status semanticCacheMode expression = State.evalStateT (loadWith expression) status { _semanticCacheMode = semanticCacheMode } diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 4ad59c46e..85fbc08d7 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -26,8 +26,6 @@ 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 @@ -51,7 +49,7 @@ toHeader (RecordLit m) = do toHeader _ = empty --- | Normalize, typecheck and return the SiteHeaders from a given expression. +-- | Normalize, typecheck and return SiteHeaders from a given expression. toSiteHeaders :: Expr Src Void -> IO SiteHeaders toSiteHeaders expr = fmap convert (normalizeSiteHeaders expr) where diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index a733b76fc..07f680b9c 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -77,8 +77,8 @@ type HTTPHeader = (CI ByteString, ByteString) -- | A map of site origin -> HTTP headers type SiteHeaders = HashMap Data.Text.Text [HTTPHeader] --- SiteHeadersFile is the raw (unresolved) expression --- used to build SiteHeaders +-- SiteHeadersFile is the raw (unresolved) +-- configuration used to build SiteHeaders data SiteHeadersFile = SiteHeadersFile { parentDirectory :: FilePath, expr :: Expr Src Import From 9f335598c5a7dd5e41419d5a320e30dc7eaccf62 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Tue, 3 Aug 2021 19:32:01 +1000 Subject: [PATCH 07/22] use caller's stack when importing headers --- dhall/ghc-src/Dhall/Import/HTTP.hs | 7 +-- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 72 +++++++++++++++-------- dhall/src/Dhall/Import.hs | 53 +++++++++++------ dhall/src/Dhall/Import/Headers.hs | 16 ++++- dhall/src/Dhall/Import/Types.hs | 12 +--- 5 files changed, 103 insertions(+), 57 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 9dd3ae471..97b66b53a 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -170,11 +171,11 @@ newManager = do getSiteHeaders :: StateT Status IO SiteHeaders getSiteHeaders = do - Status { _siteHeaders = oldSiteHeaders, ..} <- State.get + Status { _siteHeaders = oldSiteHeaders, _stack, ..} <- State.get case oldSiteHeaders of Nothing -> do - siteHeaders <- liftIO _loadSiteHeaders + siteHeaders <- liftIO (_loadSiteHeaders _stack) State.put (Status { _siteHeaders = Just siteHeaders , ..}) @@ -258,8 +259,6 @@ corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () --- type HTTPHeader = Network.HTTP.Types.Header - addHeaders :: SiteHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request addHeaders siteHeaders urlHeaders request = request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> originHeaders } diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index 177f715c0..1ee74a3b4 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -11,48 +11,72 @@ import Control.Exception (tryJust) import Control.Monad (guard) import Data.Either.Combinators (rightToMaybe) import Data.Text (Text) -import Dhall.Core (throws) -import Dhall.Import.Types (SiteHeadersFile(..)) +import Dhall.Import.Headers (SiteHeadersFile(..)) +import Dhall.Core + ( Directory(..) + , File(..) + , FilePrefix(..) + , ImportType + ) + import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) import System.Environment (lookupEnv) -import System.FilePath (()) +import System.FilePath ((), splitDirectories) import System.IO.Error (isDoesNotExistError) import qualified Data.Text as Text import qualified Data.Text.IO as IO -import qualified Dhall.Parser as Parser +import qualified Dhall.Core as Core -parseFrom :: FilePath -> Text -> IO SiteHeadersFile -parseFrom parentDirectory text = do - expr <- throws (Parser.exprFromText mempty text) - return (SiteHeadersFile { parentDirectory , expr }) +siteHeadersFile :: FilePath -> ImportType -> Text -> SiteHeadersFile +siteHeadersFile parentDirectory source fileContents = + SiteHeadersFile { parentDirectory , source, fileContents } --- lift 'parseFrom' to work on IO (Maybe Text) -parseFrom' :: FilePath -> IO (Maybe Text) -> IO (Maybe SiteHeadersFile) -parseFrom' parentDirectory getText = do +-- lift 'siteHeadersFile' to work on IO (Maybe Text) +siteHeadersFile' :: FilePath -> ImportType -> IO (Maybe Text) -> IO (Maybe SiteHeadersFile) +siteHeadersFile' parentDirectory source getText = do mtext <- getText - mapM (parseFrom parentDirectory) mtext + return (fmap (siteHeadersFile parentDirectory source) mtext) {-| Resolve the raw dhall text for user headers only from $DHALL_HEADERS, not the filesystem -} envOnlyUserHeaders :: IO (Maybe SiteHeadersFile) envOnlyUserHeaders = - parseFrom' "." (fmap (fmap Text.pack) (lookupEnv "DHALL_HEADERS")) + siteHeadersFile' "." (Core.Env (Text.pack key)) (fmap (fmap Text.pack) (lookupEnv key)) + where + key = "DHALL_HEADERS" + +configFileOnlyUserHeaders :: IO (Maybe SiteHeadersFile) +configFileOnlyUserHeaders = do + directory <- getXdgDirectory XdgConfig "dhall" + siteHeadersFile' + directory + (makeSource directory) + (tryReadFile (directory (Text.unpack filename))) + + where + filename :: Text + filename = "headers.dhall" + + makeSource directory = + Core.Local Absolute File + { directory = Directory + { components = reverse (components directory) } + , file = filename + } + + components directory = map Text.pack (splitDirectories directory) + + tryReadFile path = rightToMaybe <$> + tryJust (guard . isDoesNotExistError) (IO.readFile path) + {-| Resolve the raw dhall text for user headers, along with the directory containing it (which is `.` if loaded from $DHALL_HEADERS) -} defaultUserHeaders :: IO (Maybe SiteHeadersFile) -defaultUserHeaders = - envOnlyUserHeaders >>= \case - Just file -> return (Just file) - Nothing -> loadConfigFile - where - loadConfigFile = do - directory <- getXdgDirectory XdgConfig "dhall" - parseFrom' directory (tryReadFile (directory "headers.dhall")) - - tryReadFile path = rightToMaybe <$> - tryJust (guard . isDoesNotExistError) (IO.readFile path) +defaultUserHeaders = envOnlyUserHeaders >>= \case + Just file -> return (Just file) + Nothing -> configFileOnlyUserHeaders \ No newline at end of file diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index e7a1eec80..22d55911b 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -195,7 +195,8 @@ import System.FilePath (()) import Dhall.Import.HTTP #endif import Dhall.Import.Headers - ( toHeaders + ( SiteHeadersFile(..) + , toHeaders , toSiteHeaders , normalizeHeaders ) @@ -1030,23 +1031,39 @@ noopUserHeaders :: IO (Maybe SiteHeadersFile) noopUserHeaders = return Nothing -- | Given a SiteHeadersFile loader, return a SiteHeaders loader. -siteHeadersLoader :: IO (Maybe SiteHeadersFile) -> IO SiteHeaders -siteHeadersLoader loadSideHeadersFile = - loadSideHeadersFile >>= \case - Nothing -> return mempty - Just (SiteHeadersFile { parentDirectory, expr }) -> do - -- TODO are we representing the source (DHALL_HEADERS / headers.dhall) - -- properly in errors? - loaded <- loadWithStatus - (makeEmptyStatus - defaultNewManager - noopUserHeaders - fetchDisabledForHeaders - parentDirectory) - IgnoreSemanticCache - expr - - toSiteHeaders loaded +-- The loader uses the caller's import stack, despite not using the +-- same status (in particular, remote imports are disallowed) +siteHeadersLoader :: IO (Maybe SiteHeadersFile) -> NonEmpty Chained -> IO SiteHeaders +siteHeadersLoader loadSideHeadersFile importStack = loadSideHeadersFile >>= \case + Nothing -> return mempty + Just (SiteHeadersFile { parentDirectory, fileContents, source }) -> + loadFile source parentDirectory fileContents + where + sourceChained :: ImportType -> Chained + sourceChained source = Chained (Import (ImportHashed Nothing source) Code ) + + extendStack :: NonEmpty Chained -> ImportType -> NonEmpty Chained + extendStack existing source = pure (sourceChained source) <> existing + + loadFile source parentDirectory fileContents = do + let fullStack = extendStack importStack source + + expr <- case Dhall.Parser.exprFromText mempty fileContents of + Left err -> throwMissingImport (Imported fullStack err) + Right expr -> return expr + + loaded <- loadWithStatus + (makeEmptyStatus + defaultNewManager + noopUserHeaders + fetchDisabledForHeaders + parentDirectory) { + _stack = fullStack + } + IgnoreSemanticCache + expr + + toSiteHeaders loaded -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 85fbc08d7..4417a7ecf 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -3,7 +3,8 @@ {-# LANGUAGE ViewPatterns #-} module Dhall.Import.Headers - ( toHeaders + ( SiteHeadersFile(..) + , toHeaders , toSiteHeaders , normalizeHeaders ) where @@ -13,9 +14,13 @@ import Control.Exception (SomeException) import Control.Monad.Catch (handle, throwM) import Data.Text (Text) import Data.Void (Void) +import Dhall.Core + ( Chunks (..) + , Expr (..) + , ImportType + ) import Dhall.Import.Types (HTTPHeader , SiteHeaders) import Dhall.Parser (Src (..)) -import Dhall.Syntax (Chunks (..), Expr (..)) import qualified Data.CaseInsensitive import qualified Data.Foldable @@ -26,6 +31,13 @@ import qualified Dhall.Map import qualified Dhall.TypeCheck import qualified Dhall.Pretty.Internal +-- SiteHeadersFile is the raw configuration used to build SiteHeaders +data SiteHeadersFile = SiteHeadersFile { + parentDirectory :: FilePath, + source :: ImportType, + fileContents :: Data.Text.Text +} + -- | 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 diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 07f680b9c..0df35a54e 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -19,6 +19,7 @@ import Dhall.Context (Context) import Dhall.Core ( Expr , Import (..) + , ImportType , ReifiedNormalizer (..) , URL ) @@ -77,13 +78,6 @@ type HTTPHeader = (CI ByteString, ByteString) -- | A map of site origin -> HTTP headers type SiteHeaders = HashMap Data.Text.Text [HTTPHeader] --- SiteHeadersFile is the raw (unresolved) --- configuration used to build SiteHeaders -data SiteHeadersFile = SiteHeadersFile { - parentDirectory :: FilePath, - expr :: Expr Src Import -} - {-| Used internally to track whether or not we've already warned the user about caching issues -} @@ -108,7 +102,7 @@ data Status = Status -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests - , _loadSiteHeaders :: IO SiteHeaders + , _loadSiteHeaders :: NonEmpty Chained -> IO SiteHeaders , _siteHeaders :: Maybe SiteHeaders -- ^ Used to cache the user's custom headers for all remote imports @@ -133,7 +127,7 @@ data Status = Status -- importing relative to the given root import. emptyStatusWith :: IO Manager - -> IO SiteHeaders + -> (NonEmpty Chained -> IO SiteHeaders) -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status From addfbaa442f0b8320f1f04f19addf127240436c7 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Tue, 3 Aug 2021 20:48:01 +1000 Subject: [PATCH 08/22] revert unnecessary change --- dhall/src/Dhall/Import.hs | 1 - dhall/src/Dhall/Import/Types.hs | 9 +++++++++ 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 22d55911b..f42aeb90a 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -200,7 +200,6 @@ import Dhall.Import.Headers , toSiteHeaders , normalizeHeaders ) -import Dhall.Import.Manager (defaultNewManager) import Dhall.Import.Types import Dhall.Import.UserHeaders (defaultUserHeaders) diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index 0df35a54e..aa4d19414 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -72,6 +72,15 @@ type Manager = () #endif +-- | The default HTTP 'Manager' +defaultNewManager :: IO Manager +defaultNewManager = +#ifdef WITH_HTTP + Dhall.Import.Manager.defaultNewManager +#else + pure () +#endif + -- | HTTP headers type HTTPHeader = (CI ByteString, ByteString) From e8ce0e8871cf9f0955db95017e2308f14bdf3987 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Thu, 16 Sep 2021 21:50:16 +1000 Subject: [PATCH 09/22] PR feedback --- dhall/ghc-src/Dhall/Import/HTTP.hs | 8 +-- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 73 ++++++++++----------- dhall/src/Dhall/Import.hs | 79 ++++++++++++----------- dhall/src/Dhall/Import/Types.hs | 4 +- 4 files changed, 82 insertions(+), 82 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index abc395436..205fcf503 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -170,11 +170,12 @@ getSiteHeaders :: StateT Status IO SiteHeaders getSiteHeaders = do Status { _siteHeaders = oldSiteHeaders, _stack, ..} <- State.get + -- TODO pointless? case oldSiteHeaders of Nothing -> do - siteHeaders <- liftIO (_loadSiteHeaders _stack) + siteHeaders <- _loadSiteHeaders - State.put (Status { _siteHeaders = Just siteHeaders , ..}) + -- State.put (Status { _siteHeaders = Just siteHeaders , ..}) return siteHeaders @@ -264,8 +265,7 @@ addHeaders siteHeaders urlHeaders request = originHeaders = HashMap.lookupDefault [] origin siteHeaders - filterHeaders Nothing = [] - filterHeaders (Just headers) = filter (not . overridden) headers + filterHeaders = foldMap (filter (not . overridden)) overridden :: HTTPHeader -> Bool overridden (key, _value) = any (matchesKey key) originHeaders diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs index 1ee74a3b4..0c7e5f36b 100644 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ b/dhall/ghc-src/Dhall/Import/UserHeaders.hs @@ -7,11 +7,14 @@ module Dhall.Import.UserHeaders , envOnlyUserHeaders ) where -import Control.Exception (tryJust) -import Control.Monad (guard) -import Data.Either.Combinators (rightToMaybe) -import Data.Text (Text) -import Dhall.Import.Headers (SiteHeadersFile(..)) +import Control.Applicative ((<|>)) +import Control.Exception (tryJust) +import Control.Monad (guard) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe (MaybeT(..)) +import Data.Either.Combinators (rightToMaybe) +import Data.Text (Text) +import Dhall.Import.Headers (SiteHeadersFile(..)) import Dhall.Core ( Directory(..) , File(..) @@ -32,51 +35,43 @@ siteHeadersFile :: FilePath -> ImportType -> Text -> SiteHeadersFile siteHeadersFile parentDirectory source fileContents = SiteHeadersFile { parentDirectory , source, fileContents } --- lift 'siteHeadersFile' to work on IO (Maybe Text) -siteHeadersFile' :: FilePath -> ImportType -> IO (Maybe Text) -> IO (Maybe SiteHeadersFile) -siteHeadersFile' parentDirectory source getText = do - mtext <- getText - return (fmap (siteHeadersFile parentDirectory source) mtext) - {-| Resolve the raw dhall text for user headers only from $DHALL_HEADERS, not the filesystem -} -envOnlyUserHeaders :: IO (Maybe SiteHeadersFile) -envOnlyUserHeaders = - siteHeadersFile' "." (Core.Env (Text.pack key)) (fmap (fmap Text.pack) (lookupEnv key)) - where - key = "DHALL_HEADERS" +envOnlyUserHeaders :: MaybeT IO SiteHeadersFile +envOnlyUserHeaders = do + string <- MaybeT (lookupEnv key) + + return (siteHeadersFile "." (Core.Env (Text.pack key)) (Text.pack string)) + where + key = "DHALL_HEADERS" -configFileOnlyUserHeaders :: IO (Maybe SiteHeadersFile) +configFileOnlyUserHeaders :: MaybeT IO SiteHeadersFile configFileOnlyUserHeaders = do - directory <- getXdgDirectory XdgConfig "dhall" - siteHeadersFile' - directory - (makeSource directory) - (tryReadFile (directory (Text.unpack filename))) + directory <- liftIO (getXdgDirectory XdgConfig "dhall") + + text <- MaybeT (tryReadFile (directory (Text.unpack filename))) - where - filename :: Text - filename = "headers.dhall" + return (siteHeadersFile directory (makeSource directory) text) + where + filename :: Text + filename = "headers.dhall" - makeSource directory = - Core.Local Absolute File - { directory = Directory - { components = reverse (components directory) } - , file = filename - } - - components directory = map Text.pack (splitDirectories directory) + makeSource directory = + Core.Local Absolute File + { directory = Directory + { components = reverse (components directory) } + , file = filename + } - tryReadFile path = rightToMaybe <$> - tryJust (guard . isDoesNotExistError) (IO.readFile path) + components directory = map Text.pack (splitDirectories directory) + tryReadFile path = rightToMaybe <$> + tryJust (guard . isDoesNotExistError) (IO.readFile path) {-| Resolve the raw dhall text for user headers, along with the directory containing it (which is `.` if loaded from $DHALL_HEADERS) -} -defaultUserHeaders :: IO (Maybe SiteHeadersFile) -defaultUserHeaders = envOnlyUserHeaders >>= \case - Just file -> return (Just file) - Nothing -> configFileOnlyUserHeaders \ No newline at end of file +defaultUserHeaders :: MaybeT IO SiteHeadersFile +defaultUserHeaders = envOnlyUserHeaders <|> configFileOnlyUserHeaders \ No newline at end of file diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index c3ee3ce4d..8cfc8ba2f 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -155,7 +155,7 @@ module Dhall.Import ( , HashMismatch(..) ) where -import Control.Applicative (Alternative (..), liftA2) +import Control.Applicative (Alternative (..)) import Control.Exception ( Exception , IOException @@ -167,7 +167,6 @@ 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.Text (Text) import Data.Typeable (Typeable) @@ -801,11 +800,7 @@ fetchFresh (Env env) = do fetchFresh Missing = throwM (MissingImports []) -fetchDisabledForHeaders :: URL -> StateT Status IO Data.Text.Text -fetchDisabledForHeaders _url = do - Status { _stack } <- State.get - throwMissingImport (Imported _stack CannotImportFromHeadersFile) - +-- TODO revert to fetchRemove, remove from params? defaultFetchRemote :: URL -> StateT Status IO Data.Text.Text #ifndef WITH_HTTP defaultFetchRemote (url@URL { headers = maybeHeadersExpression }) = do @@ -1027,43 +1022,53 @@ normalizeHeadersIn url = return url -- | A no-op user headers loader used for remote contexts -- (and loading user headers themselves) -noopUserHeaders :: IO (Maybe SiteHeadersFile) -noopUserHeaders = return Nothing +noopUserHeaders :: Maybe.MaybeT IO SiteHeadersFile +noopUserHeaders = Maybe.MaybeT (return Nothing) -- | Given a SiteHeadersFile loader, return a SiteHeaders loader. --- The loader uses the caller's import stack, despite not using the --- same status (in particular, remote imports are disallowed) -siteHeadersLoader :: IO (Maybe SiteHeadersFile) -> NonEmpty Chained -> IO SiteHeaders -siteHeadersLoader loadSideHeadersFile importStack = loadSideHeadersFile >>= \case - Nothing -> return mempty - Just (SiteHeadersFile { parentDirectory, fileContents, source }) -> - loadFile source parentDirectory fileContents +-- TODO is this actually using the stack? We're discarding the parent directory. +-- Perhaps it should literally return an expr with DHALL_HEADERS ? ~/.cache/.... +siteHeadersLoader :: Maybe.MaybeT IO SiteHeadersFile -> StateT Status IO SiteHeaders +siteHeadersLoader loadSiteHeadersFile = do + Status { _stack, ..} <- State.get + -- run load + loaded <- liftIO (Maybe.runMaybeT loadSiteHeadersFile) + case loaded of + Nothing -> return mempty + Just (SiteHeadersFile { parentDirectory, fileContents, source }) -> + _ + -- loadWith source parentDirectory fileContents + -- liftIO (toSiteHeaders headersExpr) + + -- don't go through load process again + -- TODO is this needed? I think it already caches imports... + -- State.put (Status { _siteHeaders = return loded , ..}) where - sourceChained :: ImportType -> Chained - sourceChained source = Chained (Import (ImportHashed Nothing source) Code ) + -- sourceChained :: ImportType -> Chained + -- sourceChained source = Chained (Import (ImportHashed Nothing source) Code ) - extendStack :: NonEmpty Chained -> ImportType -> NonEmpty Chained - extendStack existing source = pure (sourceChained source) <> existing + -- extendStack :: NonEmpty Chained -> ImportType -> NonEmpty Chained + -- extendStack existing source = pure (sourceChained source) <> existing - loadFile source parentDirectory fileContents = do - let fullStack = extendStack importStack source + -- loadFile source parentDirectory fileContents = do + -- let fullStack = extendStack importStack source - expr <- case Dhall.Parser.exprFromText mempty fileContents of - Left err -> throwMissingImport (Imported fullStack err) - Right expr -> return expr + -- expr <- case Dhall.Parser.exprFromText mempty fileContents of + -- Left err -> throwMissingImport (Imported fullStack err) + -- Right expr -> return expr - loaded <- loadWithStatus - (makeEmptyStatus - defaultNewManager - noopUserHeaders - fetchDisabledForHeaders - parentDirectory) { - _stack = fullStack - } - IgnoreSemanticCache - expr + -- loaded <- loadWithStatus + -- (makeEmptyStatus + -- defaultNewManager + -- noopUserHeaders + -- defaultFetchRemote + -- parentDirectory) { + -- _stack = fullStack + -- } + -- IgnoreSemanticCache + -- expr - toSiteHeaders loaded + -- toSiteHeaders loaded -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status @@ -1078,7 +1083,7 @@ emptyStatusWithManager newManager = makeEmptyStatus newManager defaultUserHeader -- | See 'emptyStatus'. makeEmptyStatus :: IO Manager - -> IO (Maybe SiteHeadersFile) + -> Maybe.MaybeT IO SiteHeadersFile -> (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index b1b48fe71..b7a2025fc 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -111,7 +111,7 @@ data Status = Status -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests - , _loadSiteHeaders :: NonEmpty Chained -> IO SiteHeaders + , _loadSiteHeaders :: StateT Status IO SiteHeaders , _siteHeaders :: Maybe SiteHeaders -- ^ Used to cache the user's custom headers for all remote imports @@ -136,7 +136,7 @@ data Status = Status -- importing relative to the given root import. emptyStatusWith :: IO Manager - -> (NonEmpty Chained -> IO SiteHeaders) + -> StateT Status IO SiteHeaders -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status From 65f3a1207bab89fb83a26b50728a5a7420a6b19b Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 18 Sep 2021 14:15:41 +1000 Subject: [PATCH 10/22] Implement site headers loading as a plain dhall expression --- dhall/dhall.cabal | 2 - dhall/ghc-src/Dhall/Import/HTTP.hs | 39 ++++---- dhall/ghc-src/Dhall/Import/UserHeaders.hs | 77 -------------- dhall/ghcjs-src/Dhall/Import/HTTP.hs | 9 +- dhall/src/Dhall/Binary.hs | 6 +- dhall/src/Dhall/Import.hs | 116 ++++++++++++---------- dhall/src/Dhall/Import/Headers.hs | 11 +- dhall/src/Dhall/Import/Types.hs | 6 +- dhall/src/Dhall/Syntax.hs | 16 ++- dhall/tests/Dhall/Test/Import.hs | 3 +- 10 files changed, 113 insertions(+), 172 deletions(-) delete mode 100644 dhall/ghc-src/Dhall/Import/UserHeaders.hs diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index df8e537e7..91b40adfe 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -621,8 +621,6 @@ Library Autogen-Modules: Paths_dhall if flag(with-http) - Exposed-Modules: - Dhall.Import.UserHeaders Other-Modules: Dhall.Import.HTTP Dhall.Import.Manager diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 205fcf503..2e2571c24 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -4,6 +4,7 @@ module Dhall.Import.HTTP ( fetchFromHttpUrl + , siteHeadersFileExpr ) where import Control.Exception (Exception) @@ -15,14 +16,22 @@ 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 (..)) @@ -166,22 +175,6 @@ newManager = do Just manager -> return manager -getSiteHeaders :: StateT Status IO SiteHeaders -getSiteHeaders = do - Status { _siteHeaders = oldSiteHeaders, _stack, ..} <- State.get - - -- TODO pointless? - case oldSiteHeaders of - Nothing -> do - siteHeaders <- _loadSiteHeaders - - -- State.put (Status { _siteHeaders = Just siteHeaders , ..}) - - return siteHeaders - - Just siteHeaders -> - return siteHeaders - data NotCORSCompliant = NotCORSCompliant { expectedOrigins :: [ByteString] , actualOrigin :: ByteString @@ -275,7 +268,9 @@ addHeaders siteHeaders urlHeaders request = fetchFromHttpUrl :: URL -> Maybe [HTTPHeader] -> StateT Status IO Text.Text fetchFromHttpUrl childURL mheaders = do - siteHeaders <- getSiteHeaders + Status { _loadSiteHeaders } <- State.get + + siteHeaders <- _loadSiteHeaders manager <- newManager @@ -310,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) + +siteHeadersFileExpr :: IO (Expr Src Import) +siteHeadersFileExpr = 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)) SiteHeaders)) \ No newline at end of file diff --git a/dhall/ghc-src/Dhall/Import/UserHeaders.hs b/dhall/ghc-src/Dhall/Import/UserHeaders.hs deleted file mode 100644 index 0c7e5f36b..000000000 --- a/dhall/ghc-src/Dhall/Import/UserHeaders.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NamedFieldPuns #-} - -module Dhall.Import.UserHeaders - ( defaultUserHeaders - , envOnlyUserHeaders - ) where - -import Control.Applicative ((<|>)) -import Control.Exception (tryJust) -import Control.Monad (guard) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Maybe (MaybeT(..)) -import Data.Either.Combinators (rightToMaybe) -import Data.Text (Text) -import Dhall.Import.Headers (SiteHeadersFile(..)) -import Dhall.Core - ( Directory(..) - , File(..) - , FilePrefix(..) - , ImportType - ) - -import System.Directory (getXdgDirectory, XdgDirectory(XdgConfig)) -import System.Environment (lookupEnv) -import System.FilePath ((), splitDirectories) -import System.IO.Error (isDoesNotExistError) - -import qualified Data.Text as Text -import qualified Data.Text.IO as IO -import qualified Dhall.Core as Core - -siteHeadersFile :: FilePath -> ImportType -> Text -> SiteHeadersFile -siteHeadersFile parentDirectory source fileContents = - SiteHeadersFile { parentDirectory , source, fileContents } - -{-| Resolve the raw dhall text for user headers - only from $DHALL_HEADERS, not the filesystem - -} -envOnlyUserHeaders :: MaybeT IO SiteHeadersFile -envOnlyUserHeaders = do - string <- MaybeT (lookupEnv key) - - return (siteHeadersFile "." (Core.Env (Text.pack key)) (Text.pack string)) - where - key = "DHALL_HEADERS" - -configFileOnlyUserHeaders :: MaybeT IO SiteHeadersFile -configFileOnlyUserHeaders = do - directory <- liftIO (getXdgDirectory XdgConfig "dhall") - - text <- MaybeT (tryReadFile (directory (Text.unpack filename))) - - return (siteHeadersFile directory (makeSource directory) text) - where - filename :: Text - filename = "headers.dhall" - - makeSource directory = - Core.Local Absolute File - { directory = Directory - { components = reverse (components directory) } - , file = filename - } - - components directory = map Text.pack (splitDirectories directory) - - tryReadFile path = rightToMaybe <$> - tryJust (guard . isDoesNotExistError) (IO.readFile path) - -{-| Resolve the raw dhall text for user headers, - along with the directory containing it - (which is `.` if loaded from $DHALL_HEADERS) - -} -defaultUserHeaders :: MaybeT IO SiteHeadersFile -defaultUserHeaders = envOnlyUserHeaders <|> configFileOnlyUserHeaders \ 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..f2f9d2255 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 + , siteHeadersFileExpr ) 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" + +siteHeadersFileExpr :: IO (Expr Src Import) +siteHeadersFileExpr = return (Missing) \ No newline at end of file diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index 3a4711cec..49c21a8e4 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -1261,6 +1261,10 @@ encodeImport import_ = encodeList (prefix ++ [ Encoding.encodeInt 6, Encoding.encodeString x ]) + -- ReferentiallyOpaque _ -> + -- -- these can't be represented in the language, ignore them + -- error "Impossible?" + Missing -> encodeList (prefix ++ [ Encoding.encodeInt 7 ]) where @@ -1273,7 +1277,7 @@ encodeImport import_ = Just digest -> Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) - m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;) + m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2; SiteHeaders -> error "Impossible?") Import{..} = import_ diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 8cfc8ba2f..b4645f8f9 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -127,6 +127,7 @@ module Dhall.Import ( , chainedChangeMode , emptyStatus , emptyStatusWithManager + , envUserHeaders , makeEmptyStatus , remoteStatus , remoteStatusWithManager @@ -190,19 +191,18 @@ import Dhall.Syntax ) import System.FilePath (()) +import Text.Megaparsec (SourcePos (SourcePos), mkPos) #ifdef WITH_HTTP import Dhall.Import.HTTP #endif import Dhall.Import.Headers - ( SiteHeadersFile(..) + ( normalizeHeaders + , siteHeadersTypeExpr , toHeaders , toSiteHeaders - , normalizeHeaders ) import Dhall.Import.Types -import Dhall.Import.UserHeaders (defaultUserHeaders) - import Dhall.Parser ( ParseError (..) , Parser (..) @@ -641,6 +641,11 @@ writeToSemanticCache hash bytes = do -- scratch. loadImportWithSemisemanticCache :: Chained -> StateT Status IO ImportSemantics + +loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) SiteHeaders)) = + -- SiteHeaders are loaded as Code + loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) Code)) + loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Code)) = do text <- fetchFresh importType Status {..} <- State.get @@ -1020,55 +1025,54 @@ normalizeHeadersIn url@URL { headers = Just headersExpression } = do normalizeHeadersIn url = return url --- | A no-op user headers loader used for remote contexts --- (and loading user headers themselves) -noopUserHeaders :: Maybe.MaybeT IO SiteHeadersFile -noopUserHeaders = Maybe.MaybeT (return Nothing) - --- | Given a SiteHeadersFile loader, return a SiteHeaders loader. --- TODO is this actually using the stack? We're discarding the parent directory. --- Perhaps it should literally return an expr with DHALL_HEADERS ? ~/.cache/.... -siteHeadersLoader :: Maybe.MaybeT IO SiteHeadersFile -> StateT Status IO SiteHeaders -siteHeadersLoader loadSiteHeadersFile = do - Status { _stack, ..} <- State.get - -- run load - loaded <- liftIO (Maybe.runMaybeT loadSiteHeadersFile) - case loaded of - Nothing -> return mempty - Just (SiteHeadersFile { parentDirectory, fileContents, source }) -> - _ - -- loadWith source parentDirectory fileContents - -- liftIO (toSiteHeaders headersExpr) - - -- don't go through load process again - -- TODO is this needed? I think it already caches imports... - -- State.put (Status { _siteHeaders = return loded , ..}) +-- | An empty user headers used for remote contexts +-- (and fallback when nothing is set in env or config file) +emptyUserHeaders :: Expr Src Import +emptyUserHeaders = ListLit (Just (fmap absurd siteHeadersTypeExpr)) mempty + +-- | A fake Src to annotate headers expressions with +-- We need to wrap headers expressions in a Note for error reporting, +-- and because `?` 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 - -- sourceChained :: ImportType -> Chained - -- sourceChained source = Chained (Import (ImportHashed Nothing source) Code ) + fakeSrcText = "«Origin Header Configuration»" + fakeSrcName = "[builtin]" - -- extendStack :: NonEmpty Chained -> ImportType -> NonEmpty Chained - -- extendStack existing source = pure (sourceChained source) <> existing +-- | Load headers only from the environment (used in tests) +envUserHeaders :: Expr Src Import +envUserHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) SiteHeaders)) - -- loadFile source parentDirectory fileContents = do - -- let fullStack = extendStack importStack source +-- | Load headers in env, falling back to config file +defaultUserHeaders :: IO (Expr Src Import) +defaultUserHeaders = do + fromFile <- siteHeadersFileExpr + return (ImportAlt envUserHeaders (Note headersSrc fromFile)) - -- expr <- case Dhall.Parser.exprFromText mempty fileContents of - -- Left err -> throwMissingImport (Imported fullStack err) - -- Right expr -> return expr +-- | Given a headers expression, return a site headers loader +siteHeadersLoader :: IO (Expr Src Import) -> StateT Status IO SiteHeaders +siteHeadersLoader headersExpr = do + partialExpr <- liftIO headersExpr - -- loaded <- loadWithStatus - -- (makeEmptyStatus - -- defaultNewManager - -- noopUserHeaders - -- defaultFetchRemote - -- parentDirectory) { - -- _stack = fullStack - -- } - -- IgnoreSemanticCache - -- expr + loaded <- loadWith (ImportAlt partialExpr emptyUserHeaders) + headers <- liftIO (toSiteHeaders loaded) + + -- short-circuit _siteHeaders to return this directly next time + _ <- State.modify (\state -> state { _loadSiteHeaders = return headers }) - -- toSiteHeaders loaded + return headers -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status @@ -1083,12 +1087,12 @@ emptyStatusWithManager newManager = makeEmptyStatus newManager defaultUserHeader -- | See 'emptyStatus'. makeEmptyStatus :: IO Manager - -> Maybe.MaybeT IO SiteHeadersFile + -> IO (Expr Src Import) -> (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status -makeEmptyStatus newManager loadSiteHeadersFile fetchRemote rootDirectory = - emptyStatusWith newManager (siteHeadersLoader loadSiteHeadersFile) fetchRemote rootImport +makeEmptyStatus newManager headersExpr fetchRemote rootDirectory = + emptyStatusWith newManager (siteHeadersLoader headersExpr) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1121,7 +1125,7 @@ remoteStatus = remoteStatusWithManager defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager (siteHeadersLoader noopUserHeaders) defaultFetchRemote rootImport + emptyStatusWith newManager (siteHeadersLoader (pure emptyUserHeaders)) defaultFetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1150,9 +1154,12 @@ loadWith expr₀ = case expr₀ of local (Chained (Import (ImportHashed _ (Env {})) _)) = True local (Chained (Import (ImportHashed _ (Missing {})) _)) = False - let referentiallySane = not (local child) || local parent + let referentiallySane = case import₀ of + Import _ Location -> True + Import _ SiteHeaders -> True + _ -> not (local child) || local parent - if importMode import₀ == Location || referentiallySane + if referentiallySane then return () else throwMissingImport (Imported _stack (ReferentiallyOpaque import₀)) @@ -1322,6 +1329,9 @@ dependencyToFile status import_ = flip State.evalStateT status $ do Location -> ignore + SiteHeaders -> + ignore + Code -> case importType (importHashed child) of Local filePrefix file -> do diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 4417a7ecf..16bfb796d 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -3,10 +3,10 @@ {-# LANGUAGE ViewPatterns #-} module Dhall.Import.Headers - ( SiteHeadersFile(..) + ( normalizeHeaders + , siteHeadersTypeExpr , toHeaders , toSiteHeaders - , normalizeHeaders ) where import Control.Applicative (Alternative (..), liftA2) @@ -31,13 +31,6 @@ import qualified Dhall.Map import qualified Dhall.TypeCheck import qualified Dhall.Pretty.Internal --- SiteHeadersFile is the raw configuration used to build SiteHeaders -data SiteHeadersFile = SiteHeadersFile { - parentDirectory :: FilePath, - source :: ImportType, - fileContents :: Data.Text.Text -} - -- | 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 diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index b7a2025fc..e10a96849 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -112,8 +112,8 @@ data Status = Status -- requests , _loadSiteHeaders :: StateT Status IO SiteHeaders - , _siteHeaders :: Maybe SiteHeaders - -- ^ Used to cache the user's custom headers for all remote imports + -- ^ Load the site 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. @@ -150,8 +150,6 @@ emptyStatusWith _newManager _loadSiteHeaders _remote rootImport = Status {..} _manager = Nothing - _siteHeaders = Nothing - _substitutions = Dhall.Substitution.empty _normalizer = Nothing diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 8b3109a75..2bc6ea00b 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1058,6 +1058,8 @@ data ImportType -- ^ URL of remote resource and optional headers stored in an import | Env Text -- ^ Environment variable + -- | ReferentiallyOpaque ImportType + -- ^ A potentially-local import which is allowed even from remote parents | Missing deriving (Eq, Generic, Ord, Show, NFData) @@ -1094,10 +1096,15 @@ instance Pretty ImportType where pretty (Env env) = "env:" <> prettyEnvironmentVariable env + -- pretty (ReferentiallyOpaque importType) = Pretty.pretty importType + pretty Missing = "missing" -- | How to interpret the import's contents (i.e. as Dhall code or raw text) -data ImportMode = Code | RawText | Location +-- SiteHeaders is identical to Code, except local imports with this mode +-- are allowed from any source (local or remote). This type is only used when +-- loading Site headers, it can't be set by the user. +data ImportMode = SiteHeaders | Code | RawText | Location deriving (Eq, Generic, Ord, Show, NFData) -- | A `ImportType` extended with an optional hash for semantic integrity checks @@ -1139,9 +1146,10 @@ instance Pretty Import where where suffix :: Text suffix = case importMode of - RawText -> " as Text" - Location -> " as Location" - Code -> "" + RawText -> " as Text" + Location -> " as Location" + Code -> "" + SiteHeaders -> "" {-| Returns `True` if the given `Char` is valid within an unquoted path component diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index e3ed17ddb..18ebb28f2 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -17,7 +17,6 @@ import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO import qualified Dhall.Core as Core import qualified Dhall.Import as Import -import qualified Dhall.Import.UserHeaders as UserHeaders import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util import qualified Network.HTTP.Client as HTTP @@ -112,7 +111,7 @@ successTest prefix = do let status = Import.makeEmptyStatus httpManager - UserHeaders.envOnlyUserHeaders + (return Import.envUserHeaders) Import.defaultFetchRemote directoryString From b233d2380f44cb91306cf04a8c8ba16fffcffc4b Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 18 Sep 2021 14:32:07 +1000 Subject: [PATCH 11/22] refer to site / user headers as originHeaders consistently --- dhall/ghc-src/Dhall/Import/HTTP.hs | 26 ++++++------- dhall/ghcjs-src/Dhall/Import/HTTP.hs | 6 +-- dhall/src/Dhall/Binary.hs | 7 +--- dhall/src/Dhall/Import.hs | 58 ++++++++++++++-------------- dhall/src/Dhall/Import/Headers.hs | 33 ++++++++-------- dhall/src/Dhall/Import/Types.hs | 11 +++--- dhall/src/Dhall/Syntax.hs | 8 ++-- dhall/tests/Dhall/Test/Import.hs | 4 +- 8 files changed, 73 insertions(+), 80 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index 2e2571c24..a1a9004ce 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -4,7 +4,7 @@ module Dhall.Import.HTTP ( fetchFromHttpUrl - , siteHeadersFileExpr + , originHeadersFileExpr ) where import Control.Exception (Exception) @@ -250,27 +250,27 @@ corsCompliant (Remote parentURL) childURL responseHeaders = liftIO $ do Control.Exception.throwIO (NotCORSCompliant {..}) corsCompliant _ _ _ = return () -addHeaders :: SiteHeaders -> Maybe [HTTPHeader] -> HTTP.Request -> HTTP.Request -addHeaders siteHeaders urlHeaders request = - request { HTTP.requestHeaders = (filterHeaders urlHeaders) <> originHeaders } +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)) - - originHeaders = HashMap.lookupDefault [] origin siteHeaders + + perOriginHeaders = HashMap.lookupDefault [] origin originHeaders filterHeaders = foldMap (filter (not . overridden)) overridden :: HTTPHeader -> Bool - overridden (key, _value) = any (matchesKey key) originHeaders + 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 { _loadSiteHeaders } <- State.get + Status { _loadOriginHeaders } <- State.get - siteHeaders <- _loadSiteHeaders + originHeaders <- _loadOriginHeaders manager <- newManager @@ -278,7 +278,7 @@ fetchFromHttpUrl childURL mheaders = do baseRequest <- liftIO (HTTP.parseUrlThrow childURLString) - let requestWithHeaders = addHeaders siteHeaders mheaders baseRequest + let requestWithHeaders = addHeaders originHeaders mheaders baseRequest let io = HTTP.httpLbs requestWithHeaders manager @@ -306,10 +306,10 @@ fetchFromHttpUrl childURL mheaders = do Left err -> liftIO (Control.Exception.throwIO err) Right text -> return (Data.Text.Lazy.toStrict text) -siteHeadersFileExpr :: IO (Expr Src Import) -siteHeadersFileExpr = do +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)) SiteHeaders)) \ No newline at end of file + return (Embed (Import (ImportHashed Nothing (Local Absolute file)) OriginHeaders)) \ 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 f2f9d2255..d6c923483 100644 --- a/dhall/ghcjs-src/Dhall/Import/HTTP.hs +++ b/dhall/ghcjs-src/Dhall/Import/HTTP.hs @@ -2,7 +2,7 @@ module Dhall.Import.HTTP ( fetchFromHttpUrl - , siteHeadersFileExpr + , originHeadersFileExpr ) where import Control.Monad.IO.Class (MonadIO (..)) @@ -38,5 +38,5 @@ fetchFromHttpUrl childURL Nothing = do fetchFromHttpUrl _ _ = fail "Dhall does not yet support custom headers when built using GHCJS" -siteHeadersFileExpr :: IO (Expr Src Import) -siteHeadersFileExpr = return (Missing) \ No newline at end of file +originHeadersFileExpr :: IO (Expr Src Import) +originHeadersFileExpr = return (Missing) \ No newline at end of file diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index 49c21a8e4..8d5fdaf9f 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -1261,10 +1261,6 @@ encodeImport import_ = encodeList (prefix ++ [ Encoding.encodeInt 6, Encoding.encodeString x ]) - -- ReferentiallyOpaque _ -> - -- -- these can't be represented in the language, ignore them - -- error "Impossible?" - Missing -> encodeList (prefix ++ [ Encoding.encodeInt 7 ]) where @@ -1277,7 +1273,8 @@ encodeImport import_ = Just digest -> Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) - m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2; SiteHeaders -> error "Impossible?") + -- OriginHeaders can't be encoded by the user, they're only constructed internally + m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2; OriginHeaders -> error "Impossible") Import{..} = import_ diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index b4645f8f9..7c24c44f2 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -127,7 +127,7 @@ module Dhall.Import ( , chainedChangeMode , emptyStatus , emptyStatusWithManager - , envUserHeaders + , envOriginHeaders , makeEmptyStatus , remoteStatus , remoteStatusWithManager @@ -198,9 +198,9 @@ import Dhall.Import.HTTP #endif import Dhall.Import.Headers ( normalizeHeaders - , siteHeadersTypeExpr + , originHeadersTypeExpr , toHeaders - , toSiteHeaders + , toOriginHeaders ) import Dhall.Import.Types import Dhall.Parser @@ -642,8 +642,8 @@ writeToSemanticCache hash bytes = do loadImportWithSemisemanticCache :: Chained -> StateT Status IO ImportSemantics -loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) SiteHeaders)) = - -- SiteHeaders are loaded as Code +loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) OriginHeaders)) = + -- OriginHeaders are loaded as Code loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) Code)) loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Code)) = do @@ -1027,8 +1027,8 @@ normalizeHeadersIn url = return url -- | An empty user headers used for remote contexts -- (and fallback when nothing is set in env or config file) -emptyUserHeaders :: Expr Src Import -emptyUserHeaders = ListLit (Just (fmap absurd siteHeadersTypeExpr)) mempty +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 error reporting, @@ -1052,37 +1052,37 @@ headersSrc = Src { fakeSrcName = "[builtin]" -- | Load headers only from the environment (used in tests) -envUserHeaders :: Expr Src Import -envUserHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) SiteHeaders)) +envOriginHeaders :: Expr Src Import +envOriginHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) OriginHeaders)) -- | Load headers in env, falling back to config file -defaultUserHeaders :: IO (Expr Src Import) -defaultUserHeaders = do - fromFile <- siteHeadersFileExpr - return (ImportAlt envUserHeaders (Note headersSrc fromFile)) - --- | Given a headers expression, return a site headers loader -siteHeadersLoader :: IO (Expr Src Import) -> StateT Status IO SiteHeaders -siteHeadersLoader headersExpr = do +defaultOriginHeaders :: IO (Expr Src Import) +defaultOriginHeaders = do + fromFile <- originHeadersFileExpr + return (ImportAlt envOriginHeaders (Note headersSrc fromFile)) + +-- | Given a headers expression, return an origin headers loader +originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders +originHeadersLoader headersExpr = do partialExpr <- liftIO headersExpr - loaded <- loadWith (ImportAlt partialExpr emptyUserHeaders) - headers <- liftIO (toSiteHeaders loaded) + loaded <- loadWith (ImportAlt partialExpr emptyOriginHeaders) + headers <- liftIO (toOriginHeaders loaded) - -- short-circuit _siteHeaders to return this directly next time - _ <- State.modify (\state -> state { _loadSiteHeaders = return headers }) + -- short-circuit _loadOriginHeaders to return this directly next time + _ <- State.modify (\state -> state { _loadOriginHeaders = return headers }) return headers -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = makeEmptyStatus defaultNewManager defaultUserHeaders defaultFetchRemote +emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders defaultFetchRemote emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager = makeEmptyStatus newManager defaultUserHeaders defaultFetchRemote +emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders defaultFetchRemote -- | See 'emptyStatus'. makeEmptyStatus @@ -1092,7 +1092,7 @@ makeEmptyStatus -> FilePath -> Status makeEmptyStatus newManager headersExpr fetchRemote rootDirectory = - emptyStatusWith newManager (siteHeadersLoader headersExpr) fetchRemote rootImport + emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory then Here @@ -1125,7 +1125,7 @@ remoteStatus = remoteStatusWithManager defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager (siteHeadersLoader (pure emptyUserHeaders)) defaultFetchRemote rootImport + emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) defaultFetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1156,7 +1156,7 @@ loadWith expr₀ = case expr₀ of let referentiallySane = case import₀ of Import _ Location -> True - Import _ SiteHeaders -> True + Import _ OriginHeaders -> True _ -> not (local child) || local parent if referentiallySane @@ -1228,7 +1228,7 @@ load = loadWithManager defaultNewManager loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) loadWithManager newManager = loadWithStatus - (makeEmptyStatus newManager defaultUserHeaders defaultFetchRemote ".") + (makeEmptyStatus newManager defaultOriginHeaders defaultFetchRemote ".") UseSemanticCache printWarning :: (MonadIO m) => String -> m () @@ -1244,7 +1244,7 @@ printWarning message = do -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) loadRelativeTo parentDirectory = loadWithStatus - (makeEmptyStatus defaultNewManager defaultUserHeaders defaultFetchRemote parentDirectory) + (makeEmptyStatus defaultNewManager defaultOriginHeaders defaultFetchRemote parentDirectory) -- | See 'loadRelativeTo'. loadWithStatus @@ -1329,7 +1329,7 @@ dependencyToFile status import_ = flip State.evalStateT status $ do Location -> ignore - SiteHeaders -> + OriginHeaders -> ignore Code -> diff --git a/dhall/src/Dhall/Import/Headers.hs b/dhall/src/Dhall/Import/Headers.hs index 16bfb796d..1009c2c88 100644 --- a/dhall/src/Dhall/Import/Headers.hs +++ b/dhall/src/Dhall/Import/Headers.hs @@ -4,9 +4,9 @@ module Dhall.Import.Headers ( normalizeHeaders - , siteHeadersTypeExpr + , originHeadersTypeExpr , toHeaders - , toSiteHeaders + , toOriginHeaders ) where import Control.Applicative (Alternative (..), liftA2) @@ -17,9 +17,8 @@ import Data.Void (Void) import Dhall.Core ( Chunks (..) , Expr (..) - , ImportType ) -import Dhall.Import.Types (HTTPHeader , SiteHeaders) +import Dhall.Import.Types (HTTPHeader , OriginHeaders) import Dhall.Parser (Src (..)) import qualified Data.CaseInsensitive @@ -54,24 +53,24 @@ toHeader (RecordLit m) = do toHeader _ = empty --- | Normalize, typecheck and return SiteHeaders from a given expression. -toSiteHeaders :: Expr Src Void -> IO SiteHeaders -toSiteHeaders expr = fmap convert (normalizeSiteHeaders expr) +-- | 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 -> SiteHeaders - convert (ListLit _ hs) = HashMap.fromList (sitePairs hs) + convert :: Expr s a -> OriginHeaders + convert (ListLit _ hs) = HashMap.fromList (originPairs hs) convert _ = mempty - sitePairs hs = Data.Foldable.toList (Data.Foldable.fold (mapM toSitePair hs)) + originPairs hs = Data.Foldable.toList (Data.Foldable.fold (mapM toOriginPair hs)) - toSitePair :: Expr s a -> Maybe (Text, [HTTPHeader]) - toSitePair (RecordLit m) = do + 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) - toSitePair _ = Nothing + toOriginPair _ = Nothing makeHeadersTypeExpr :: Text -> Text -> Expr Src Void makeHeadersTypeExpr keyKey valueKey = @@ -89,8 +88,8 @@ headersTypeExpr = makeHeadersTypeExpr "mapKey" "mapValue" leagacyHeadersTypeExpr :: Expr Src Void leagacyHeadersTypeExpr = makeHeadersTypeExpr "header" "value" -siteHeadersTypeExpr :: Expr Src Void -siteHeadersTypeExpr = +originHeadersTypeExpr :: Expr Src Void +originHeadersTypeExpr = App List ( Record $ Core.makeRecordField <$> Dhall.Map.fromList @@ -128,5 +127,5 @@ normalizeHeaders headersExpr = do handle handler₀ (typecheck headersTypeExpr headersExpr) -normalizeSiteHeaders :: Expr Src Void -> IO (Expr Src Void) -normalizeSiteHeaders = typecheck siteHeadersTypeExpr +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 e10a96849..e2ffb20a1 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -18,7 +18,6 @@ import Dhall.Context (Context) import Dhall.Core ( Expr , Import (..) - , ImportType , ReifiedNormalizer (..) , URL ) @@ -85,7 +84,7 @@ defaultNewManager = type HTTPHeader = (CI ByteString, ByteString) -- | A map of site origin -> HTTP headers -type SiteHeaders = HashMap Data.Text.Text [HTTPHeader] +type OriginHeaders = HashMap Data.Text.Text [HTTPHeader] {-| Used internally to track whether or not we've already warned the user about caching issues @@ -111,8 +110,8 @@ data Status = Status -- ^ Used to cache the `Dhall.Import.Manager.Manager` when making multiple -- requests - , _loadSiteHeaders :: StateT Status IO SiteHeaders - -- ^ Load the site headers from environment or configuration file. + , _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 @@ -136,11 +135,11 @@ data Status = Status -- importing relative to the given root import. emptyStatusWith :: IO Manager - -> StateT Status IO SiteHeaders + -> StateT Status IO OriginHeaders -> (URL -> StateT Status IO Data.Text.Text) -> Import -> Status -emptyStatusWith _newManager _loadSiteHeaders _remote rootImport = Status {..} +emptyStatusWith _newManager _loadOriginHeaders _remote rootImport = Status {..} where _stack = pure (Chained rootImport) diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 2bc6ea00b..420713cb9 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1101,10 +1101,10 @@ instance Pretty ImportType where pretty Missing = "missing" -- | How to interpret the import's contents (i.e. as Dhall code or raw text) --- SiteHeaders is identical to Code, except local imports with this mode +-- OriginHeaders is identical to Code, except local imports with this mode -- are allowed from any source (local or remote). This type is only used when --- loading Site headers, it can't be set by the user. -data ImportMode = SiteHeaders | Code | RawText | Location +-- loading Origin headers, it can't be set by the user. +data ImportMode = OriginHeaders | Code | RawText | Location deriving (Eq, Generic, Ord, Show, NFData) -- | A `ImportType` extended with an optional hash for semantic integrity checks @@ -1149,7 +1149,7 @@ instance Pretty Import where RawText -> " as Text" Location -> " as Location" Code -> "" - SiteHeaders -> "" + OriginHeaders -> "" {-| Returns `True` if the given `Char` is valid within an unquoted path component diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 18ebb28f2..875f35f85 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -87,8 +87,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 @@ -111,7 +109,7 @@ successTest prefix = do let status = Import.makeEmptyStatus httpManager - (return Import.envUserHeaders) + (return Import.envOriginHeaders) Import.defaultFetchRemote directoryString From 1799fd13373933f8d3a679bc9d40742a2e5188ee Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 18 Sep 2021 14:52:58 +1000 Subject: [PATCH 12/22] revert unnecessary diffs --- dhall/src/Dhall/Binary.hs | 4 +-- dhall/src/Dhall/Import.hs | 47 ++++++++++++-------------------- dhall/src/Dhall/Import/Types.hs | 2 +- dhall/src/Dhall/Syntax.hs | 4 --- dhall/tests/Dhall/Test/Import.hs | 3 +- 5 files changed, 22 insertions(+), 38 deletions(-) diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index 8d5fdaf9f..8e79b301a 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -1273,8 +1273,8 @@ encodeImport import_ = Just digest -> Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) - -- OriginHeaders can't be encoded by the user, they're only constructed internally - m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2; OriginHeaders -> error "Impossible") + -- OriginHeaders will never actually be encoded, they're only constructed internally + m = Encoding.encodeInt (case importMode of Code -> 0; OriginHeaders -> 0; RawText -> 1; Location -> 2) Import{..} = import_ diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 7c24c44f2..62ce31695 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -131,7 +131,7 @@ module Dhall.Import ( , makeEmptyStatus , remoteStatus , remoteStatusWithManager - , defaultFetchRemote + , fetchRemote , stack , cache , Depends(..) @@ -156,7 +156,7 @@ module Dhall.Import ( , HashMismatch(..) ) where -import Control.Applicative (Alternative (..)) +import Control.Applicative (Alternative (..)) import Control.Exception ( Exception , IOException @@ -203,6 +203,7 @@ import Dhall.Import.Headers , toOriginHeaders ) import Dhall.Import.Types + import Dhall.Parser ( ParseError (..) , Parser (..) @@ -382,17 +383,6 @@ instance Show CannotImportHTTPURL where <> url <> "\n" -data CannotImportFromHeadersFile = - CannotImportFromHeadersFile - deriving (Typeable) - -instance Exception CannotImportFromHeadersFile - -instance Show CannotImportFromHeadersFile where - show CannotImportFromHeadersFile = - "\n" - <> "\ESC[1;31mError\ESC[0m: Cannot import a remote URL from the headers configuration expression.\n" - {-| > canonicalize . canonicalize = canonicalize @@ -805,16 +795,16 @@ fetchFresh (Env env) = do fetchFresh Missing = throwM (MissingImports []) --- TODO revert to fetchRemove, remove from params? -defaultFetchRemote :: URL -> StateT Status IO Data.Text.Text + +fetchRemote :: URL -> StateT Status IO Data.Text.Text #ifndef WITH_HTTP -defaultFetchRemote (url@URL { headers = maybeHeadersExpression }) = do +fetchRemote (url@URL { headers = maybeHeadersExpression }) = do let maybeHeaders = fmap toHeaders maybeHeadersExpression let urlString = Text.unpack (Core.pretty url) Status { _stack } <- State.get throwMissingImport (Imported _stack (CannotImportHTTPURL urlString maybeHeaders)) #else -defaultFetchRemote url = do +fetchRemote url = do zoom remote (State.put fetchFromHTTP) fetchFromHTTP url where @@ -1025,13 +1015,13 @@ normalizeHeadersIn url@URL { headers = Just headersExpression } = do normalizeHeadersIn url = return url --- | An empty user headers used for remote contexts +-- | 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 error reporting, +-- | A fake Src to annotate headers expressions with. +-- We need to wrap headers expressions in a Note for nice error reporting, -- and because `?` handling only catches SourcedExceptions headersSrc :: Src headersSrc = Src { @@ -1068,30 +1058,29 @@ originHeadersLoader headersExpr = do loaded <- loadWith (ImportAlt partialExpr emptyOriginHeaders) headers <- liftIO (toOriginHeaders loaded) - - -- short-circuit _loadOriginHeaders to return this directly next time + + -- return cached headers next time _ <- State.modify (\state -> state { _loadOriginHeaders = return headers }) return headers -- | Default starting `Status`, importing relative to the given directory. emptyStatus :: FilePath -> Status -emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders defaultFetchRemote +emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders emptyStatusWithManager :: IO Manager -> FilePath -> Status -emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders defaultFetchRemote +emptyStatusWithManager newManager = makeEmptyStatus newManager defaultOriginHeaders -- | See 'emptyStatus'. makeEmptyStatus :: IO Manager -> IO (Expr Src Import) - -> (URL -> StateT Status IO Data.Text.Text) -> FilePath -> Status -makeEmptyStatus newManager headersExpr fetchRemote rootDirectory = +makeEmptyStatus newManager headersExpr rootDirectory = emptyStatusWith newManager (originHeadersLoader headersExpr) fetchRemote rootImport where prefix = if FilePath.isRelative rootDirectory @@ -1125,7 +1114,7 @@ remoteStatus = remoteStatusWithManager defaultNewManager -- | See `remoteStatus` remoteStatusWithManager :: IO Manager -> URL -> Status remoteStatusWithManager newManager url = - emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) defaultFetchRemote rootImport + emptyStatusWith newManager (originHeadersLoader (pure emptyOriginHeaders)) fetchRemote rootImport where rootImport = Import { importHashed = ImportHashed @@ -1228,7 +1217,7 @@ load = loadWithManager defaultNewManager loadWithManager :: IO Manager -> Expr Src Import -> IO (Expr Src Void) loadWithManager newManager = loadWithStatus - (makeEmptyStatus newManager defaultOriginHeaders defaultFetchRemote ".") + (makeEmptyStatus newManager defaultOriginHeaders ".") UseSemanticCache printWarning :: (MonadIO m) => String -> m () @@ -1244,7 +1233,7 @@ printWarning message = do -- directory. loadRelativeTo :: FilePath -> SemanticCacheMode -> Expr Src Import -> IO (Expr Src Void) loadRelativeTo parentDirectory = loadWithStatus - (makeEmptyStatus defaultNewManager defaultOriginHeaders defaultFetchRemote parentDirectory) + (makeEmptyStatus defaultNewManager defaultOriginHeaders parentDirectory) -- | See 'loadRelativeTo'. loadWithStatus diff --git a/dhall/src/Dhall/Import/Types.hs b/dhall/src/Dhall/Import/Types.hs index e2ffb20a1..10d3e09f7 100644 --- a/dhall/src/Dhall/Import/Types.hs +++ b/dhall/src/Dhall/Import/Types.hs @@ -131,7 +131,7 @@ data Status = Status } -- | Initial `Status`, parameterised over the HTTP 'Manager', --- the user headers and the remote resolver, +-- the origin headers and the remote resolver, -- importing relative to the given root import. emptyStatusWith :: IO Manager diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 420713cb9..40c78abdd 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1058,8 +1058,6 @@ data ImportType -- ^ URL of remote resource and optional headers stored in an import | Env Text -- ^ Environment variable - -- | ReferentiallyOpaque ImportType - -- ^ A potentially-local import which is allowed even from remote parents | Missing deriving (Eq, Generic, Ord, Show, NFData) @@ -1096,8 +1094,6 @@ instance Pretty ImportType where pretty (Env env) = "env:" <> prettyEnvironmentVariable env - -- pretty (ReferentiallyOpaque importType) = Pretty.pretty importType - pretty Missing = "missing" -- | How to interpret the import's contents (i.e. as Dhall code or raw text) diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 875f35f85..9235c748b 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -109,8 +109,7 @@ successTest prefix = do let status = Import.makeEmptyStatus httpManager - (return Import.envOriginHeaders) - Import.defaultFetchRemote + (pure Import.envOriginHeaders) directoryString let load = From 9e51f6b0f9718d4bd4841e5dceeb33f9c828848a Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 18 Sep 2021 15:01:20 +1000 Subject: [PATCH 13/22] minor --- dhall/dhall-lang | 2 +- dhall/src/Dhall/Import.hs | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/dhall/dhall-lang b/dhall/dhall-lang index 9bff2e8c6..6e65dfbb4 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit 9bff2e8c611120bfe77df2ed021d89df5358b2fa +Subproject commit 6e65dfbb45ce8385bb9300bf4208047f8d6c2a60 diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 62ce31695..aedc187f3 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -1055,7 +1055,6 @@ defaultOriginHeaders = do originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders originHeadersLoader headersExpr = do partialExpr <- liftIO headersExpr - loaded <- loadWith (ImportAlt partialExpr emptyOriginHeaders) headers <- liftIO (toOriginHeaders loaded) From 85afb69478345df70d53335d711d44fb570cd770 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 19 Sep 2021 22:15:09 +1000 Subject: [PATCH 14/22] Load origin headers with an empty stack --- dhall/ghc-src/Dhall/Import/HTTP.hs | 2 +- dhall/ghcjs-src/Dhall/Import/HTTP.hs | 2 +- dhall/src/Dhall/Import.hs | 33 +++++++++++++++++++++++----- 3 files changed, 30 insertions(+), 7 deletions(-) diff --git a/dhall/ghc-src/Dhall/Import/HTTP.hs b/dhall/ghc-src/Dhall/Import/HTTP.hs index a1a9004ce..b86d139cb 100644 --- a/dhall/ghc-src/Dhall/Import/HTTP.hs +++ b/dhall/ghc-src/Dhall/Import/HTTP.hs @@ -312,4 +312,4 @@ originHeadersFileExpr = do 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)) OriginHeaders)) \ No newline at end of file + 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 d6c923483..228764bd5 100644 --- a/dhall/ghcjs-src/Dhall/Import/HTTP.hs +++ b/dhall/ghcjs-src/Dhall/Import/HTTP.hs @@ -39,4 +39,4 @@ fetchFromHttpUrl _ _ = fail "Dhall does not yet support custom headers when built using GHCJS" originHeadersFileExpr :: IO (Expr Src Import) -originHeadersFileExpr = return (Missing) \ No newline at end of file +originHeadersFileExpr = return Missing \ No newline at end of file diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index aedc187f3..70e43cbd0 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -1043,25 +1043,48 @@ headersSrc = Src { -- | Load headers only from the environment (used in tests) envOriginHeaders :: Expr Src Import -envOriginHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DHALL_HEADERS")) OriginHeaders)) +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) defaultOriginHeaders = do fromFile <- originHeadersFileExpr - return (ImportAlt envOriginHeaders (Note headersSrc fromFile)) + return (Note headersSrc (ImportAlt envOriginHeaders (Note headersSrc fromFile))) -- | Given a headers expression, return an origin headers loader originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders originHeadersLoader headersExpr = do - partialExpr <- liftIO headersExpr - loaded <- loadWith (ImportAlt partialExpr emptyOriginHeaders) - headers <- liftIO (toOriginHeaders loaded) + + -- Load the headers using a parallel state with an empty impport chain. + -- We also set _loadOriginHeaders to prevent reentrant loads. + + status <- State.get + + let headerLoadStatus = status { + _stack = pure (NonEmpty.last (_stack status)), + _loadOriginHeaders = reentrantLoad + } + + (headers, _) <- liftIO (State.runStateT doLoad headerLoadStatus) -- return cached headers next time _ <- State.modify (\state -> state { _loadOriginHeaders = return headers }) return headers + where + + -- The builtin Cycle error should make this unnecessary, + -- but loadWith raises ReferentiallyOpaque before we have a chance to + -- raise a Cycle, and the former is caught by dhall's `?` operator. + reentrantLoad = do + Status { _stack } <- State.get + let (Chained parent) = NonEmpty.head _stack + throwMissingImport (Imported _stack (Cycle parent)) + + 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 From dd85fbad9edb130d32b8f3ce08279c8562d67fe3 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sun, 19 Sep 2021 22:19:29 +1000 Subject: [PATCH 15/22] revert the addition of OriginHeaders ImportMode --- dhall/src/Dhall/Binary.hs | 3 +-- dhall/src/Dhall/Import.hs | 15 ++------------- dhall/src/Dhall/Syntax.hs | 6 +----- 3 files changed, 4 insertions(+), 20 deletions(-) diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index 8e79b301a..fdcae435e 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -1273,8 +1273,7 @@ encodeImport import_ = Just digest -> Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) - -- OriginHeaders will never actually be encoded, they're only constructed internally - m = Encoding.encodeInt (case importMode of Code -> 0; OriginHeaders -> 0; RawText -> 1; Location -> 2) + m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2) Import{..} = import_ diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 70e43cbd0..228b6f2f6 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -631,11 +631,6 @@ writeToSemanticCache hash bytes = do -- scratch. loadImportWithSemisemanticCache :: Chained -> StateT Status IO ImportSemantics - -loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) OriginHeaders)) = - -- OriginHeaders are loaded as Code - loadImportWithSemisemanticCache (Chained (Import (ImportHashed hash importType) Code)) - loadImportWithSemisemanticCache (Chained (Import (ImportHashed _ importType) Code)) = do text <- fetchFresh importType Status {..} <- State.get @@ -1165,12 +1160,9 @@ loadWith expr₀ = case expr₀ of local (Chained (Import (ImportHashed _ (Env {})) _)) = True local (Chained (Import (ImportHashed _ (Missing {})) _)) = False - let referentiallySane = case import₀ of - Import _ Location -> True - Import _ OriginHeaders -> True - _ -> not (local child) || local parent + let referentiallySane = not (local child) || local parent - if referentiallySane + if importMode import₀ == Location || referentiallySane then return () else throwMissingImport (Imported _stack (ReferentiallyOpaque import₀)) @@ -1340,9 +1332,6 @@ dependencyToFile status import_ = flip State.evalStateT status $ do Location -> ignore - OriginHeaders -> - ignore - Code -> case importType (importHashed child) of Local filePrefix file -> do diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 40c78abdd..6f85b9990 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1097,10 +1097,7 @@ instance Pretty ImportType where pretty Missing = "missing" -- | How to interpret the import's contents (i.e. as Dhall code or raw text) --- OriginHeaders is identical to Code, except local imports with this mode --- are allowed from any source (local or remote). This type is only used when --- loading Origin headers, it can't be set by the user. -data ImportMode = OriginHeaders | Code | RawText | Location +data ImportMode = Code | RawText | Location deriving (Eq, Generic, Ord, Show, NFData) -- | A `ImportType` extended with an optional hash for semantic integrity checks @@ -1145,7 +1142,6 @@ instance Pretty Import where RawText -> " as Text" Location -> " as Location" Code -> "" - OriginHeaders -> "" {-| Returns `True` if the given `Char` is valid within an unquoted path component From 88f6fbd4b1558ba976ed91d3a4b0b690c26900a2 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Mon, 20 Sep 2021 07:24:26 +1000 Subject: [PATCH 16/22] reset dhall-lang submodule --- dhall/dhall-lang | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall/dhall-lang b/dhall/dhall-lang index 6e65dfbb4..9bff2e8c6 160000 --- a/dhall/dhall-lang +++ b/dhall/dhall-lang @@ -1 +1 @@ -Subproject commit 6e65dfbb45ce8385bb9300bf4208047f8d6c2a60 +Subproject commit 9bff2e8c611120bfe77df2ed021d89df5358b2fa From c77f5a7efbdd7995fa5a5a2f1816a928f18690b7 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Tue, 21 Sep 2021 21:05:27 +1000 Subject: [PATCH 17/22] loadOriginHeaders: use parent stack instead of special-casing reentrant calls --- dhall/src/Dhall/Import.hs | 23 ++++++++--------------- 1 file changed, 8 insertions(+), 15 deletions(-) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 228b6f2f6..653f03c26 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -168,7 +168,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.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) @@ -1050,15 +1051,14 @@ defaultOriginHeaders = do originHeadersLoader :: IO (Expr Src Import) -> StateT Status IO OriginHeaders originHeadersLoader headersExpr = do - -- Load the headers using a parallel state with an empty impport chain. - -- We also set _loadOriginHeaders to prevent reentrant loads. + -- Load the headers using the parent stack, which should always be a local + -- import (we only load headers for the first remote import) status <- State.get - let headerLoadStatus = status { - _stack = pure (NonEmpty.last (_stack status)), - _loadOriginHeaders = reentrantLoad - } + let parentStack = fromMaybe abortEmptyStack (nonEmpty (NonEmpty.tail (_stack status))) + + let headerLoadStatus = status { _stack = parentStack } (headers, _) <- liftIO (State.runStateT doLoad headerLoadStatus) @@ -1067,14 +1067,7 @@ originHeadersLoader headersExpr = do return headers where - - -- The builtin Cycle error should make this unnecessary, - -- but loadWith raises ReferentiallyOpaque before we have a chance to - -- raise a Cycle, and the former is caught by dhall's `?` operator. - reentrantLoad = do - Status { _stack } <- State.get - let (Chained parent) = NonEmpty.head _stack - throwMissingImport (Imported _stack (Cycle parent)) + abortEmptyStack = Core.internalError "Origin headers loaded with an empty stack" doLoad = do partialExpr <- liftIO headersExpr From 02a65a34329d3beebe3ab853e38c0542f237daa6 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Fri, 24 Sep 2021 13:42:56 +1000 Subject: [PATCH 18/22] fix compilation failure when building without http --- dhall/src/Dhall/Import.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 653f03c26..9fcfa14bf 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -196,6 +196,8 @@ import Text.Megaparsec (SourcePos (SourcePos), mkPos) #ifdef WITH_HTTP import Dhall.Import.HTTP +#else +originHeadersFileExpr = emptyOriginHeaders #endif import Dhall.Import.Headers ( normalizeHeaders From a78e9425843ff40d251c85bf4295ccefe5df1fa1 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Fri, 24 Sep 2021 14:34:35 +1000 Subject: [PATCH 19/22] revert unnecessary diffs --- dhall/ghcjs-src/Dhall/Import/HTTP.hs | 2 +- dhall/src/Dhall/Binary.hs | 2 +- dhall/src/Dhall/Import.hs | 1 - dhall/src/Dhall/Syntax.hs | 6 +++--- 4 files changed, 5 insertions(+), 6 deletions(-) diff --git a/dhall/ghcjs-src/Dhall/Import/HTTP.hs b/dhall/ghcjs-src/Dhall/Import/HTTP.hs index 228764bd5..eea74be0d 100644 --- a/dhall/ghcjs-src/Dhall/Import/HTTP.hs +++ b/dhall/ghcjs-src/Dhall/Import/HTTP.hs @@ -39,4 +39,4 @@ fetchFromHttpUrl _ _ = fail "Dhall does not yet support custom headers when built using GHCJS" originHeadersFileExpr :: IO (Expr Src Import) -originHeadersFileExpr = return Missing \ No newline at end of file +originHeadersFileExpr = return Missing diff --git a/dhall/src/Dhall/Binary.hs b/dhall/src/Dhall/Binary.hs index fdcae435e..3a4711cec 100644 --- a/dhall/src/Dhall/Binary.hs +++ b/dhall/src/Dhall/Binary.hs @@ -1273,7 +1273,7 @@ encodeImport import_ = Just digest -> Encoding.encodeBytes ("\x12\x20" <> Data.ByteArray.convert digest) - m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2) + m = Encoding.encodeInt (case importMode of Code -> 0; RawText -> 1; Location -> 2;) Import{..} = import_ diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 9fcfa14bf..4930b2bd1 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -3,7 +3,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} diff --git a/dhall/src/Dhall/Syntax.hs b/dhall/src/Dhall/Syntax.hs index 6f85b9990..8b3109a75 100644 --- a/dhall/src/Dhall/Syntax.hs +++ b/dhall/src/Dhall/Syntax.hs @@ -1139,9 +1139,9 @@ instance Pretty Import where where suffix :: Text suffix = case importMode of - RawText -> " as Text" - Location -> " as Location" - Code -> "" + RawText -> " as Text" + Location -> " as Location" + Code -> "" {-| Returns `True` if the given `Char` is valid within an unquoted path component From dd515d9cab97f1d69c43b0205cbd44005b079410 Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Fri, 24 Sep 2021 21:07:11 +1000 Subject: [PATCH 20/22] raise haddock coverage in Import module --- dhall/src/Dhall/Import.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index 309d04356..ee4f6ffd4 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -792,7 +792,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 @@ -1079,6 +1079,7 @@ originHeadersLoader headersExpr = do emptyStatus :: FilePath -> Status emptyStatus = makeEmptyStatus defaultNewManager defaultOriginHeaders +-- | See 'emptyStatus' emptyStatusWithManager :: IO Manager -> FilePath From 0d9ffa24cf8e428c4513ad83819ca52b2f396ecb Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 25 Sep 2021 10:00:53 +1000 Subject: [PATCH 21/22] fix haddock warning --- dhall/src/Dhall/Import.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index ee4f6ffd4..c1620179d 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -1019,7 +1019,7 @@ 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 `?` handling only catches SourcedExceptions +-- and because ImportAlt handling only catches SourcedExceptions headersSrc :: Src headersSrc = Src { srcStart = SourcePos { From 770cbab98fb5b495efdab05c758becaec8d0fb3f Mon Sep 17 00:00:00 2001 From: Tim Cuthbertson Date: Sat, 25 Sep 2021 10:31:26 +1000 Subject: [PATCH 22/22] fix compilation error when HTTP is disabled --- dhall/src/Dhall/Import.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/dhall/src/Dhall/Import.hs b/dhall/src/Dhall/Import.hs index c1620179d..47c8d18df 100644 --- a/dhall/src/Dhall/Import.hs +++ b/dhall/src/Dhall/Import.hs @@ -195,8 +195,6 @@ import Text.Megaparsec (SourcePos (SourcePos), mkPos) #ifdef WITH_HTTP import Dhall.Import.HTTP -#else -originHeadersFileExpr = emptyOriginHeaders #endif import Dhall.Import.Headers ( normalizeHeaders @@ -1044,9 +1042,13 @@ envOriginHeaders = Note headersSrc (Embed (Import (ImportHashed Nothing (Env "DH -- | 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