Fix tests to pass with -f-with-http (#2382)

Gabriella439 · web-flow · commit c1c2a342dd22 · 2022-04-07T22:21:19.000-07:00
… partly by mocking some imports better and partly by disabling some tests that are not worth the effort to mock. Fixes #2380
diff --git 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
@@ -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
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP               #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications  #-}
 
@@ -21,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"
 
@@ -62,6 +67,18 @@ getTests = do
         let expectedSuccesses =
                 [ importDirectory </> "failure/unit/DontRecoverCycle.dhall"
                 , importDirectory </> "failure/unit/DontRecoverTypeError.dhall"
+#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
+                , 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 +101,15 @@ successTest prefix = do
 
     let directoryString = FilePath.takeDirectory inputPath
 
-    let expectedFailures = [ ]
+    let expectedFailures =
+            [
+#if !(defined(WITH_HTTP) && defined(NETWORK_TESTS))
+              importDirectory </> "success/originHeadersImportFromEnv"
+            , importDirectory </> "success/originHeadersImport"
+            , importDirectory </> "success/originHeadersOverride"
+            , importDirectory </> "success/unit/asLocation/RemoteChainEnv"
+#endif
+            ]
 
     Test.Util.testCase prefix expectedFailures (do
 
@@ -98,6 +123,7 @@ successTest prefix = do
 
         let originalCache = "dhall-lang/tests/import/cache"
 
+#if defined(WITH_HTTP) && defined(NETWORK_TESTS)
         let httpManager =
                 HTTP.newManager
                     HTTP.tlsManagerSettings
@@ -108,6 +134,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/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
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP               #-}
+{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes        #-}
 {-# LANGUAGE ViewPatterns      #-}
@@ -49,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
@@ -64,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
@@ -104,62 +106,85 @@ 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
 
 #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
@@ -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

Original file line number	Diff line number	Diff line change
`@@ -59,7 +59,7 @@ successTest :: Text -> TestTree`
`59`	`59`	`successTest prefix = do`
`60`	`60`	`let expectedFailures =`
`61`	`61`	`[]`
`62`		`-#ifdef WITH_HTTP`
	`62`	`+#if defined(WITH_HTTP) && defined(NETWORK_TESTS)`
`63`	`63`	`#else`
`64`	`64`	`++ [ typeInferenceDirectory </> "success/CacheImports"`
`65`	`65`	`]`