From baffd2a4cff66e0f05d164a736827b49ecf759e8 Mon Sep 17 00:00:00 2001 From: Gabriella Gonzalez Date: Sat, 12 Feb 2022 18:52:46 -0800 Subject: [PATCH 1/2] Fix tests to pass with `-f-with-http` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit … partly by mocking some imports better and partly by disabling some tests that are not worth the effort to mock. Fixes https://github.com/dhall-lang/dhall-haskell/issues/2380 --- dhall/tests/Dhall/Test/Import.hs | 27 +++++++- dhall/tests/Dhall/Test/Util.hs | 114 +++++++++++++++++++------------ nix/shared.nix | 9 +-- 3 files changed, 99 insertions(+), 51 deletions(-) diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 495585d1d..647870664 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} @@ -62,6 +63,18 @@ getTests = do let expectedSuccesses = [ importDirectory "failure/unit/DontRecoverCycle.dhall" , importDirectory "failure/unit/DontRecoverTypeError.dhall" +#ifndef WITH_HTTP + -- We attempt to simulate test.dhall-lang.org, but even so + -- some tests unexpectedly succeed due to the inadequacy of + -- the simulation + , importDirectory "failure/unit/cors/OnlySelf.dhall" + , importDirectory "failure/unit/cors/OnlyOther.dhall" + , importDirectory "failure/unit/cors/Null.dhall" + , importDirectory "failure/unit/cors/TwoHops.dhall" + , importDirectory "failure/unit/cors/Empty.dhall" + , importDirectory "failure/unit/cors/NoCORS.dhall" + , importDirectory "failure/originHeadersFromRemote.dhall" +#endif ] _ <- Monad.guard (path `notElem` expectedSuccesses) @@ -84,7 +97,15 @@ successTest prefix = do let directoryString = FilePath.takeDirectory inputPath - let expectedFailures = [ ] + let expectedFailures = + [ +#ifndef WITH_HTTP + importDirectory "success/originHeadersImportFromEnv" + , importDirectory "success/originHeadersImport" + , importDirectory "success/originHeadersOverride" + , importDirectory "success/unit/asLocation/RemoteChainEnv" +#endif + ] Test.Util.testCase prefix expectedFailures (do @@ -98,6 +119,7 @@ successTest prefix = do let originalCache = "dhall-lang/tests/import/cache" +#ifdef WITH_HTTP let httpManager = HTTP.newManager HTTP.tlsManagerSettings @@ -108,6 +130,9 @@ successTest prefix = do httpManager (pure Import.envOriginHeaders) directoryString +#else + let status = Import.emptyStatus directoryString +#endif let load = State.evalStateT diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 89b90c122..7b4bbb2c8 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ViewPatterns #-} @@ -33,7 +34,9 @@ import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core ( Chunks (..) + , Directory (..) , Expr (..) + , File (..) , Import , Normalizer , ReifiedNormalizer (..) @@ -111,55 +114,78 @@ loadWith = Dhall.Import.loadWith #else loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith expr = do - let mockRemote' url = do - liftIO . putStrLn $ "\nTesting without real HTTP support --" - ++ " using mock HTTP client to resolve remote import." - mockRemote url - zoom Dhall.Import.remote (State.put mockRemote') + zoom Dhall.Import.remote (State.put mockRemote) Dhall.Import.loadWith expr mockRemote :: Dhall.Core.URL -> StateT Status IO Data.Text.Text --- Matches anything pointing to --- `https://raw.githubusercontent.com/dhall-lang/dhall-lang/master/` -mockRemote (URL { authority = "raw.githubusercontent.com" - , path = Dhall.Core.File (Dhall.Core.Directory components) file }) - | take 3 (reverse components) == ["dhall-lang", "dhall-lang", "master"] = do - let dropEnd n ls = take (length ls - n) ls - let localDir = dropEnd 3 components ++ ["dhall-lang"] - - localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file) - liftIO $ Data.Text.IO.readFile localPath - --- Matches anything pointing to --- `https://test.dhall-lang.org/Bool/package.dhall`; checks that a `test` header --- is present and redirects to the local copy of the prelude. -mockRemote (URL { authority = "test.dhall-lang.org" - , path = Dhall.Core.File (Dhall.Core.Directory components) file - , headers = Just headersExpr }) = - case Data.Foldable.find ((== "test") . fst) hs of - Nothing -> fail $ "(mock http) Tried to load an import from " - ++"\"test.dhall-lang.org\"" - ++ "without setting the \"test\" header field." - Just (_, _) -> do - let localDir = components ++ ["Prelude", "dhall-lang"] - localPath <- Dhall.Import.localToPath Dhall.Core.Here (Dhall.Core.File (Dhall.Core.Directory localDir) file) - liftIO $ Data.Text.IO.readFile localPath - where - hs = Dhall.Import.toHeaders headersExpr - --- Emulates `https://httpbin.org/user-agent` -mockRemote (URL { authority = "httpbin.org" - , path = Dhall.Core.File (Dhall.Core.Directory []) "user-agent" - , headers = Just headersExpr }) = - case Data.Foldable.find ((== "user-agent") . fst) hs of - Nothing -> fail $ "(mock http) Tried to read the user agent via " - ++ "\"httpbin.com/user-agent\" without supplying one " - ++ "in the header!" - Just (_, userAgent) -> do +mockRemote + url@URL + { authority = "raw.githubusercontent.com" + , path = File (Directory components) file + } = do + let localDir = case reverse components of + "dhall-lang" : "dhall-lang" : _ : rest -> + reverse ("dhall-lang" : rest) + "Nadrieril" : "dhall-rust" : _ : "dhall" : rest -> + reverse ("dhall-lang" : rest) + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) + + localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file) + + liftIO (Data.Text.IO.readFile localPath) + +mockRemote + URL { authority = "prelude.dhall-lang.org" + , path = File (Directory components) file + } = do + let localDir = components ++ [ "Prelude", "dhall-lang" ] + + localPath <- Dhall.Import.localToPath Dhall.Core.Here (File (Directory localDir) file) + + liftIO (Data.Text.IO.readFile localPath) + +mockRemote url@URL{ authority = "test.dhall-lang.org", path, headers } = + case (path, fmap Dhall.Import.toHeaders headers) of + (File (Directory []) "foo", Just [("test", _)]) -> + return "./bar" + (File (Directory []) "bar", Just [("test", _)]) -> + return "True" + (File (Directory ["cors"]) "AllowedAll.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlyGithub.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlySelf.dhall", _) -> + return "42" + (File (Directory ["cors"]) "OnlyOther.dhall", _) -> + return "42" + (File (Directory ["cors"]) "Empty.dhall", _) -> + return "42" + (File (Directory ["cors"]) "NoCORS.dhall", _) -> + return "42" + (File (Directory ["cors"]) "Null.dhall", _) -> + return "42" + (File (Directory ["cors"]) "SelfImportAbsolute.dhall", _) -> + return "https://test.dhall-lang.org/cors/NoCORS.dhall" + (File (Directory ["cors"]) "SelfImportRelative.dhall", _) -> + return "./NoCORS.dhall" + (File (Directory ["cors"]) "TwoHopsFail.dhall", _) -> + return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlySelf.dhall" + (File (Directory ["cors"]) "TwoHopsSuccess.dhall", _) -> + return "https://raw.githubusercontent.com/dhall-lang/dhall-lang/5ff7ecd2411894dd9ce307dc23020987361d2d43/tests/import/data/cors/OnlyGithub.dhall" + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) + +mockRemote url@URL{ authority = "httpbin.org", path, headers } = + case (path, fmap Dhall.Import.toHeaders headers) of + (File (Directory []) "user-agent", Just [("user-agent", userAgent)]) -> do let agentText = Data.Text.Encoding.decodeUtf8 userAgent + return ("{\n \"user-agent\": \"" <> agentText <> "\"\n}\n") - where - hs = Dhall.Import.toHeaders headersExpr + (File (Directory []) "user-agent", Nothing) -> do + return ("{\n \"user-agent\": \"Dhall\"\n}\n") + _ -> do + fail ("Unable to mock URL: " <> Text.unpack (Dhall.Core.pretty url)) mockRemote url = do let urlString = Text.unpack (Dhall.Core.pretty url) diff --git a/nix/shared.nix b/nix/shared.nix index 34d42f2b3..3c95c8578 100644 --- a/nix/shared.nix +++ b/nix/shared.nix @@ -150,12 +150,9 @@ let ).overrideAttrs (old: { XDG_CACHE_HOME=".cache"; }); dhall-no-http = - # The import tests fail with HTTP support compiled out - pkgsNew.haskell.lib.dontCheck - (pkgsNew.haskell.lib.appendConfigureFlag - haskellPackagesNew.dhall - [ "-f-with-http" ] - ); + pkgsNew.haskell.lib.appendConfigureFlag + haskellPackagesNew.dhall + [ "-f-with-http" ]; dhall-bash = haskellPackagesNew.callCabal2nix From 4c87963770a5ba34846951c2160ff6061b887d94 Mon Sep 17 00:00:00 2001 From: hololeap Date: Tue, 22 Mar 2022 13:56:24 -0600 Subject: [PATCH 2/2] Add `network-tests` flag to toggle tests which require internet (#2383) Allows for disabling network-dependent tests independently of the `with-http` flag. --- dhall/dhall.cabal | 8 ++++++++ dhall/src/Dhall/Tutorial.hs | 11 +++++++++++ dhall/tests/Dhall/Test/Import.hs | 14 +++++++++----- dhall/tests/Dhall/Test/TypeInference.hs | 2 +- dhall/tests/Dhall/Test/Util.hs | 11 +++++------ 5 files changed, 34 insertions(+), 12 deletions(-) diff --git a/dhall/dhall.cabal b/dhall/dhall.cabal index b005eb23e..6236c15c9 100644 --- a/dhall/dhall.cabal +++ b/dhall/dhall.cabal @@ -196,6 +196,11 @@ Flag cross Default: False Manual: True +Flag network-tests + Description: Enable tests which depend on an internet connection + Default: True + Manual: True + Common common Build-Depends: base >= 4.11.0.0 && < 5 , @@ -253,6 +258,9 @@ Common common if flag(use-http-client-tls) CPP-Options: -DUSE_HTTP_CLIENT_TLS + if flag(network-tests) + CPP-Options: + -DNETWORK_TESTS GHC-Options: -Wall -Wcompat -Wincomplete-uni-patterns diff --git a/dhall/src/Dhall/Tutorial.hs b/dhall/src/Dhall/Tutorial.hs index ebc61f2dd..417fbbec1 100644 --- a/dhall/src/Dhall/Tutorial.hs +++ b/dhall/src/Dhall/Tutorial.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE CPP #-} {-| Dhall is a programming language specialized for configuration files. This module contains a tutorial explaining how to author configuration files @@ -375,13 +376,23 @@ import Dhall -- -- ... and you can reference that expression either directly: -- +#if defined(WITH_HTTP) && defined(USE_HTTP_CLIENT_TLS) && defined(NETWORK_TESTS) -- >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- True +#else +-- > >>> input auto "https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- > True +#endif -- -- ... or inside of a larger expression: -- +#if defined(WITH_HTTP) && defined(USE_HTTP_CLIENT_TLS) && defined(NETWORK_TESTS) -- >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool -- False +#else +-- > >>> input auto "False == https://raw.githubusercontent.com/dhall-lang/dhall-haskell/18e4e9a18dc53271146df3ccf5b4177c3552236b/examples/True" :: IO Bool +-- > False +#endif -- -- You're not limited to hosting Dhall expressions on GitHub. You can host a -- Dhall expression anywhere that you can host UTF8-encoded text on the web, diff --git a/dhall/tests/Dhall/Test/Import.hs b/dhall/tests/Dhall/Test/Import.hs index 647870664..59fcd48b7 100644 --- a/dhall/tests/Dhall/Test/Import.hs +++ b/dhall/tests/Dhall/Test/Import.hs @@ -22,14 +22,18 @@ import qualified Dhall.Core as Core import qualified Dhall.Import as Import import qualified Dhall.Parser as Parser import qualified Dhall.Test.Util as Test.Util -import qualified Network.HTTP.Client as HTTP -import qualified Network.HTTP.Client.TLS as HTTP import qualified System.FilePath as FilePath import qualified System.IO.Temp as Temp import qualified Test.Tasty as Tasty import qualified Test.Tasty.HUnit as Tasty.HUnit import qualified Turtle +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP +#endif + + importDirectory :: FilePath importDirectory = "./dhall-lang/tests/import" @@ -63,7 +67,7 @@ getTests = do let expectedSuccesses = [ importDirectory "failure/unit/DontRecoverCycle.dhall" , importDirectory "failure/unit/DontRecoverTypeError.dhall" -#ifndef WITH_HTTP +#if !(defined(WITH_HTTP) && defined(NETWORK_TESTS)) -- We attempt to simulate test.dhall-lang.org, but even so -- some tests unexpectedly succeed due to the inadequacy of -- the simulation @@ -99,7 +103,7 @@ successTest prefix = do let expectedFailures = [ -#ifndef WITH_HTTP +#if !(defined(WITH_HTTP) && defined(NETWORK_TESTS)) importDirectory "success/originHeadersImportFromEnv" , importDirectory "success/originHeadersImport" , importDirectory "success/originHeadersOverride" @@ -119,7 +123,7 @@ successTest prefix = do let originalCache = "dhall-lang/tests/import/cache" -#ifdef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) let httpManager = HTTP.newManager HTTP.tlsManagerSettings diff --git a/dhall/tests/Dhall/Test/TypeInference.hs b/dhall/tests/Dhall/Test/TypeInference.hs index d542521ed..561f06cd5 100644 --- a/dhall/tests/Dhall/Test/TypeInference.hs +++ b/dhall/tests/Dhall/Test/TypeInference.hs @@ -59,7 +59,7 @@ successTest :: Text -> TestTree successTest prefix = do let expectedFailures = [] -#ifdef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) #else ++ [ typeInferenceDirectory "success/CacheImports" ] diff --git a/dhall/tests/Dhall/Test/Util.hs b/dhall/tests/Dhall/Test/Util.hs index 7b4bbb2c8..79b8e1721 100644 --- a/dhall/tests/Dhall/Test/Util.hs +++ b/dhall/tests/Dhall/Test/Util.hs @@ -34,9 +34,7 @@ import Data.Void (Void) import Dhall.Context (Context) import Dhall.Core ( Chunks (..) - , Directory (..) , Expr (..) - , File (..) , Import , Normalizer , ReifiedNormalizer (..) @@ -52,7 +50,6 @@ import Turtle (FilePath, Pattern, Shell, fp) import qualified Control.Exception import qualified Control.Foldl as Foldl import qualified Control.Monad.Trans.State.Strict as State -import qualified Data.Foldable import qualified Data.Functor import qualified Data.Text as Text import qualified Data.Text.IO as Text.IO @@ -67,9 +64,11 @@ import qualified Test.Tasty as Tasty import qualified Test.Tasty.ExpectedFailure as Tasty.ExpectedFailure import qualified Turtle -#ifndef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) +import qualified Data.Foldable +#else import Control.Monad.IO.Class (MonadIO (..)) -import Dhall.Core (URL (..)) +import Dhall.Core (URL (..), File (..), Directory (..)) import Lens.Family.State.Strict (zoom) import qualified Data.Foldable @@ -107,7 +106,7 @@ loadRelativeTo rootDirectory semanticCacheMode expression = (loadWith expression) (Dhall.Import.emptyStatus rootDirectory) { _semanticCacheMode = semanticCacheMode } -#ifdef WITH_HTTP +#if defined(WITH_HTTP) && defined(NETWORK_TESTS) loadWith :: Expr Src Import -> StateT Status IO (Expr Src Void) loadWith = Dhall.Import.loadWith