Import.hs

{-# LANGUAGE CPP               #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications  #-}

-- FIXME: Re-enable deprecation warnings after removing support for turtle < 1.6.
{-# OPTIONS_GHC -Wno-deprecations #-}

module Dhall.Test.Import where

import Control.Exception (SomeException)
import Data.Foldable     (fold)
import Data.Text         (Text, isSuffixOf)
import Data.Void         (Void)
import Prelude           hiding (FilePath)
import Test.Tasty        (TestTree)
import Turtle            (FilePath, toText, (</>))

import qualified Control.Exception                as Exception
import qualified Control.Monad                    as Monad
import qualified Control.Monad.Trans.State.Strict as State
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.Parser                     as Parser
import qualified Dhall.Test.Util                  as Test.Util
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"

getTests :: IO TestTree
getTests = do
    let flakyTests =
            [ -- This test is flaky, occasionally failing with:
              --
              --     Error: Remote host not found
              --
              --     URL: https://test.dhall-lang.org/Bool/package.dhall
              importDirectory </> "success/headerForwardingA.dhall"
            , importDirectory </> "success/unit/RemoteAsTextA.dhall"
            , importDirectory </> "success/unit/SimpleRemoteA.dhall"
            , importDirectory </> "success/unit/asLocation/RemoteChain1A.dhall"
            , importDirectory </> "success/unit/asLocation/RemoteChain2A.dhall"
            , importDirectory </> "success/unit/asLocation/RemoteChain3A.dhall"
            , importDirectory </> "success/unit/asLocation/RemoteChainMissingA.dhall"
            ]

    successTests <- Test.Util.discover (Turtle.chars <* "A.dhall") successTest (do
        path <- Turtle.lstree (importDirectory </> "success")

        Monad.guard (path `notElem` flakyTests)

        return path )

    failureTests <- Test.Util.discover (Turtle.chars <* ".dhall") failureTest (do
        path <- Turtle.lstree (importDirectory </> "failure")

        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)
        _ <- Monad.guard (not ("ENV.dhall" `isSuffixOf` (fold (toText path))))
        return path )

    let testTree =
            Tasty.testGroup "import tests"
                [ successTests
                , failureTests
                ]

    return testTree

successTest :: Text -> TestTree
successTest prefix = do
    let inputPath = Text.unpack (prefix <> "A.dhall")

    let expectedPath = Text.unpack (prefix <> "B.dhall")

    let directoryString = FilePath.takeDirectory inputPath

    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

        text <- Text.IO.readFile inputPath

        expectedText <- Text.IO.readFile expectedPath

        actualExpr <- Core.throws (Parser.exprFromText mempty text)

        expectedExpr <- Core.throws (Parser.exprFromText mempty expectedText)

        let originalCache = "dhall-lang/tests/import/cache"

#if defined(WITH_HTTP) && defined(NETWORK_TESTS)
        let httpManager =
                HTTP.newManager
                    HTTP.tlsManagerSettings
                        { HTTP.managerResponseTimeout = HTTP.responseTimeoutMicro (120 * 1000 * 1000) }

        let status =
                Import.makeEmptyStatus
                    httpManager
                    (pure Import.envOriginHeaders)
                    directoryString
#else
        let status = Import.emptyStatus directoryString
#endif

        let load =
                State.evalStateT
                    (Test.Util.loadWith actualExpr)
                    status

        let usesCache = [ "hashFromCache"
                        , "unit/asLocation/Hash"
                        , "unit/IgnorePoisonedCache"
                        , "unit/DontCacheIfHash"
                        ]

        let endsIn path' =
                not (null (Turtle.match (Turtle.ends path') (Test.Util.toDhallPath prefix)))

        let buildNewCache = do
                tempdir <- fmap Turtle.decodeString (Turtle.managed (Temp.withSystemTempDirectory "dhall-cache"))
                Turtle.liftIO (Turtle.cptree originalCache tempdir)
                return tempdir

        let cacheSetup =
                if any endsIn usesCache
                    then do
                        cacheDir <- buildNewCache

                        let set = do
                                m <- Turtle.need "XDG_CACHE_HOME"

                                Turtle.export "XDG_CACHE_HOME" (Turtle.format Turtle.fp cacheDir)

                                return m

                        let reset Nothing = do
                                Turtle.unset "XDG_CACHE_HOME"
                            reset (Just x) = do
                                Turtle.export "XDG_CACHE_HOME" x

                        _ <- Turtle.managed (Exception.bracket set reset)
                        return ()
                else pure ()

        let setup = cacheSetup >> Test.Util.managedTestEnvironment prefix

        let resolve = Turtle.with setup (const load)

        let handler :: SomeException -> IO (Core.Expr Parser.Src Void)
            handler exception = Tasty.HUnit.assertFailure (show exception)

        actualResolved <- Exception.handle handler resolve

        expectedResolved <- Import.assertNoImports expectedExpr

        let actual = Core.normalize actualResolved :: Core.Expr Void Void

        let expected = Core.normalize expectedResolved :: Core.Expr Void Void

        let message =
                "The imported expression did not match the expected output"

        Tasty.HUnit.assertEqual message expected actual)

failureTest :: Text -> TestTree
failureTest prefix = do
    let path = prefix <> ".dhall"

    let pathString = Text.unpack path

    Tasty.HUnit.testCase pathString (do
        actualExpr <- do
          Core.throws (Parser.exprFromText mempty (Test.Util.toDhallPath path))

        let setup = Test.Util.managedTestEnvironment prefix

        let run = Exception.catch @SomeException
              (Test.Util.load actualExpr >> return True)
              (\_ -> return False)

        succeeded <- Turtle.with setup (const run)

        if succeeded
            then fail "Import should have failed, but it succeeds"
            else return () )