WorkspaceTest.hs

module HurlWorkbench.Workspace.WorkspaceTest (tests) where

import Data.Generics.Labels ()
import Data.Map.Strict qualified as Map
import Data.Text qualified as Text
import Data.Text.IO qualified as Text.IO
import HurlWorkbench.Prelude
import HurlWorkbench.Workspace.Context
import HurlWorkbench.Workspace.Decode
import HurlWorkbench.Workspace.Discover
import HurlWorkbench.Workspace.Error
import HurlWorkbench.Workspace.Types
import HurlWorkbench.Workspace.Validate
import System.Directory (canonicalizePath, createDirectoryIfMissing, createFileLink)
import System.FilePath ((</>))
import System.IO.Temp (withSystemTempDirectory)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))

tests :: TestTree
tests =
  testGroup
    "workspace"
    [ decodingTests,
      discoveryTests,
      validationTests,
      literalTests
    ]

fixture :: FilePath -> FilePath
fixture name = "test/fixtures/workspaces" </> name </> "hurl-workbench.dhall"

--------------------------------------------------------------------------------
-- Decoding

decodingTests :: TestTree
decodingTests =
  testGroup
    "decoding"
    [ testCase "frozen old service suites normalize additive fields and run unions" $ do
        ws <- decodeOrFail (fixture "old-service-suite")
        map suiteServices (ws ^. #suites) @?= [[ServiceName "old"]]
        map (view #setup) (ws ^. #suites) @?= [[]]
        map (view #commandTimeoutSeconds) (ws ^. #suites) @?= [60],
      testCase "frozen populated old suites default to shared state" $ do
        old <- decodeOrFail (fixture "old-suite")
        shared <- decodeOrFail (fixture "shared-suite")
        old @?= shared
        map (view #isolation) (old ^. #suites) @?= [SharedState]
        independent <- decodeOrFail (fixture "independent-suite")
        independent @?= (shared & #suites .~ map (\suite -> suite & #isolation .~ IndependentState) (shared ^. #suites)),
      testCase "invalid isolation values fail typed decode" $
        withSystemTempDirectory "hurl-isolation" $ \dir -> do
          schema <- canonicalizePath schemaPackage
          for_ ["42", "< Wrong >.Wrong"] $ \policy -> do
            let manifest = dir </> manifestFileName
            Text.IO.writeFile manifest ("let S = " <> Text.pack schema <> " in S.Workspace::{ schemaVersion = 1, suites = [{ name = \"bad\", runs = [] : List S.RunReference, service = None Text, failFast = False, description = None Text, isolation = " <> policy <> " }] }")
            decodeWorkspaceFile manifest >>= \case
              Left DhallFailure {} -> pure ()
              other -> assertFailure ("expected invalid policy, got " <> show other),
      policyDecodingTests,
      testCase "frozen old service and readiness records inherit" $
        for_ ["old-command", "old-http"] $ \name -> do
          ws <- decodeOrFail (fixture name)
          map (view (#command . #environmentPolicy)) (ws ^. #services) @?= [Inherit],
      testCase "completion-based and fully specified manifests decode identically" $ do
        completed <- decodeOrFail (fixture "minimal")
        explicit <- decodeOrFail (fixture "minimal-explicit")
        completed @?= explicit
        completed ^. #schemaVersion @?= 1
        map (view #defaultValue) (completed ^. #parameters)
          @?= [Just (literal "https://api.example.test")],
      testCase "a manifest may import sibling Dhall modules" $ do
        ws <- decodeOrFail (fixture "full")
        map (unParameterName . view #name) (ws ^. #parameters)
          @?= ["auth_url", "base_url", "client_id", "client_secret", "top"],
      testCase "an unsupported schema version is reported before typed decoding" $ do
        path <- canonicalizePath (fixture "schema-version")
        result <- decodeWorkspaceFile path
        result @?= Left (UnsupportedSchemaVersion path 2 1),
      testCase "a Dhall type error is reported with the manifest path" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          let manifest = dir </> manifestFileName
          Text.IO.writeFile manifest "{ schemaVersion = 1, fragments = 42 }"
          result <- decodeWorkspaceFile manifest
          case result of
            Left (DhallFailure path message) -> do
              path @?= manifest
              assertBool "mentions the mismatch" ("doesn't match annotation" `Text.isInfixOf` message)
              assertBool "contains no ANSI escapes" (not ("\ESC" `Text.isInfixOf` message))
            other -> assertFailure ("expected a Dhall failure, got " <> show other)
    ]

decodeOrFail :: FilePath -> IO Workspace
decodeOrFail path =
  decodeWorkspaceFile path >>= \case
    Right ws -> pure ws
    Left err -> assertFailure (Text.unpack (renderWorkspaceError err))

literal :: Text -> HurlValueLiteral
literal value = either (error . show) id (mkHurlValueLiteral value)

--------------------------------------------------------------------------------
-- Discovery

discoveryTests :: TestTree
discoveryTests =
  testGroup
    "discovery"
    [ testCase "finds the manifest from a nested child directory" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          writeManifest dir []
          let nested = dir </> "a" </> "b" </> "c"
          createDirectoryIfMissing True nested
          result <- discoverWorkspace Nothing nested
          result @?= Right (DiscoveredWorkspace (dir </> manifestFileName)),
      testCase "an explicit manifest wins over discovery" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          writeManifest dir []
          let other = dir </> "other"
          createDirectoryIfMissing True other
          writeManifest other []
          result <- discoverWorkspace (Just ("other" </> manifestFileName)) dir
          result @?= Right (ExplicitWorkspace (other </> manifestFileName)),
      testCase "a missing explicit manifest is an error, even when discovery would succeed" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          writeManifest dir []
          result <- discoverWorkspace (Just "missing.dhall") dir
          result @?= Left (ManifestNotFound (dir </> "missing.dhall")),
      testCase "discovery stops at the filesystem root" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          result <- discoverWorkspace Nothing dir
          result @?= Left (NoWorkspaceFound dir)
    ]

-- | Write a manifest with the given @(name, path)@ fragments, importing the
--   repository schema by absolute path.
writeManifest :: FilePath -> [(Text, Text)] -> IO ()
writeManifest dir fragmentList = do
  schema <- canonicalizePath schemaPackage
  writeManifestWithSchema schema dir fragmentList

-- | The repository schema, relative to the package directory in which
--   @cabal test@ runs.
schemaPackage :: FilePath
schemaPackage = "schema/package.dhall"

--------------------------------------------------------------------------------
-- Validation

validationTests :: TestTree
validationTests =
  testGroup
    "validation"
    [ testCase "independent suites cannot declare a shared service" $ do
        original <- validFixture "full"
        let context = validatedContext original
            suites = map (\suite -> suite & #isolation .~ IndependentState) (validatedWorkspace original ^. #suites)
        validateWorkspace (context & #workspace . #suites .~ suites) >>= \case
          Left issues -> assertBool "service rejected" (any (Text.isInfixOf "cannot declare a shared managed service" . view #message) issues)
          Right _ -> assertFailure "expected invalid independent managed suite",
      testCase "a complete workspace validates and offers typed lookups" $ do
        vw <- validFixture "full"
        Map.keys (validatedWorkflows vw) @?= [WorkflowName "list-members", WorkflowName "list-properties"]
        let fragmentsOf name = maybe [] (view #fragments) (lookupWorkflow (WorkflowName name) vw)
        -- One OAuth fragment is shared by both resource workflows.
        take 1 (fragmentsOf "list-properties") @?= [FragmentName "oauth"]
        take 1 (fragmentsOf "list-members") @?= [FragmentName "oauth"]
        fmap (view #safety) (lookupRecipe (RecipeName "top-properties") vw) @?= Just ReadOnly
        fmap (length . view #cases) (lookupMatrix (MatrixName "property-page-sizes") vw) @?= Just 2
        fmap (view #service) (lookupSuite (SuiteName "smoke") vw) @?= Just (Just (ServiceName "api"))
        root <- canonicalizePath "test/fixtures/workspaces/full"
        validatedRoot vw @?= WorkspaceRoot root
        lookupFragmentFile (FragmentName "oauth") vw @?= Just (root </> "hurl/oauth.hurl"),
      testCase "every unresolved reference is reported together, in stable order" $ do
        issues <- invalidFixture "missing-reference"
        issues
          @?= [ ValidationIssue "workflows/empty/fragments" "workflow must list at least one fragment",
                ValidationIssue "workflows/flow/fragments" "unknown fragment \"missing-fragment\"",
                ValidationIssue "workflows/flow/parameters" "unknown parameter \"missing_parameter\"",
                ValidationIssue "recipes/orphan/workflow" "unknown workflow \"missing-workflow\"",
                ValidationIssue "matrices/grid/recipe" "unknown recipe \"missing-recipe\"",
                ValidationIssue "matrices/grid/cases" "matrix must have at least one case",
                ValidationIssue "suites/all/runs" "unknown matrix \"missing-matrix\"",
                ValidationIssue "suites/all/service" "unknown service \"missing-service\""
              ]
        again <- invalidFixture "missing-reference"
        again @?= issues,
      testCase "duplicate and malformed names are reported" $ do
        issues <- invalidFixture "duplicate"
        map (view #location) issues @?= ["fragments/a", "workflows/9-bad name", "workflows/flow"]
        assertMentions issues "duplicate fragment name declared 2 times"
        assertMentions issues "duplicate workflow name declared 2 times",
      testCase "unsafe fragment paths are rejected" $ do
        issues <- invalidFixture "escaping-path"
        issues
          @?= [ ValidationIssue "fragments/absolute/path" "path \"/etc/hosts\" must be relative to the workspace root",
                ValidationIssue "fragments/missing/path" "path \"hurl/missing.hurl\" does not exist as a regular file",
                ValidationIssue "fragments/not-hurl/path" "fragment path \"outside-notes.txt\" must end in .hurl",
                ValidationIssue "fragments/parent/path" "path \"../minimal/hurl/health.hurl\" escapes the workspace root"
              ],
      testCase "a symlink that leaves the workspace is rejected" $
        withSystemTempDirectory "hurl-workbench" $ \dir -> do
          let workspaceDir = dir </> "workspace"
          createDirectoryIfMissing True (workspaceDir </> "hurl")
          Text.IO.writeFile (dir </> "outside.hurl") "GET https://example.test\n"
          Text.IO.writeFile (workspaceDir </> "hurl" </> "inside.hurl") "GET https://example.test\n"
          createFileLink (dir </> "outside.hurl") (workspaceDir </> "hurl" </> "escape.hurl")
          createFileLink (workspaceDir </> "hurl" </> "inside.hurl") (workspaceDir </> "hurl" </> "alias.hurl")
          writeManifest workspaceDir [("escape", "hurl/escape.hurl"), ("alias", "hurl/alias.hurl")]
          issues <- invalidManifest (workspaceDir </> manifestFileName)
          issues @?= [ValidationIssue "fragments/escape/path" "path \"hurl/escape.hurl\" escapes the workspace root"],
      testCase "a secret with a committed default is rejected" $ do
        issues <- invalidFixture "secret-default"
        issues @?= [ValidationIssue "parameters/api_key" "secret parameters must not have a committed defaultValue"],
      testCase "values that Hurl variable files cannot carry are rejected with their location" $ do
        issues <- invalidFixture "invalid-value"
        map (view #location) issues
          @?= ["parameters/multiline/defaultValue", "parameters/newUuid", "parameters/padded/defaultValue"]
    ]
  where
    assertMentions issues needle =
      assertBool
        ("expected an issue mentioning " <> Text.unpack needle)
        (any (Text.isInfixOf needle . view #message) issues)

writeManifestWithSchema :: FilePath -> FilePath -> [(Text, Text)] -> IO ()
writeManifestWithSchema schema dir fragmentList =
  Text.IO.writeFile (dir </> manifestFileName) $
    Text.unlines
      [ "let Schema = " <> Text.pack schema,
        "in Schema.Workspace::{ schemaVersion = 1, fragments = ["
          <> Text.intercalate ", " [fragmentLiteral name path | (name, path) <- fragmentList]
          <> "] : List Schema.Fragment.Type }"
      ]
  where
    fragmentLiteral name path = "Schema.Fragment::{ name = \"" <> name <> "\", path = \"" <> path <> "\" }"

loadManifest :: FilePath -> IO (Either (NonEmpty ValidationIssue) ValidatedWorkspace)
loadManifest manifest = do
  context <-
    discoverWorkspace (Just manifest) "." >>= \case
      Left err -> assertFailure (Text.unpack (renderWorkspaceError err))
      Right source ->
        loadWorkspaceContext source >>= \case
          Left err -> assertFailure (Text.unpack (renderWorkspaceError err))
          Right ctx -> pure ctx
  validateWorkspace context

validFixture :: FilePath -> IO ValidatedWorkspace
validFixture name =
  loadManifest (fixture name) >>= \case
    Right vw -> pure vw
    Left issues -> assertFailure (Text.unpack (Text.unlines (map renderValidationIssue (toList issues))))

invalidFixture :: FilePath -> IO [ValidationIssue]
invalidFixture = invalidManifest . fixture

invalidManifest :: FilePath -> IO [ValidationIssue]
invalidManifest manifest =
  loadManifest manifest >>= \case
    Right _ -> assertFailure "expected validation to fail"
    Left issues -> pure (toList issues)

--------------------------------------------------------------------------------
-- Hurl value literals

literalTests :: TestTree
literalTests =
  testGroup
    "HurlValueLiteral"
    [ testCase "accepts values Hurl reads back unchanged" $
        for_ ["", "true", "null", "42", "3.5", "a=b", "has inner space", "\"quoted\""] $ \value ->
          fmap hurlValueLiteralText (mkHurlValueLiteral value) @?= Right value,
      testCase "rejects line breaks and NUL" $
        for_ ["a\nb", "a\rb", "a\0b"] $ \value ->
          mkHurlValueLiteral value @?= Left ContainsLineBreakOrNul,
      testCase "rejects surrounding whitespace that Hurl trims" $
        for_ [" a", "a ", "\ta", "a\x2028", "\x85"] $ \value ->
          mkHurlValueLiteral value @?= Left SurroundingWhitespace
    ]

policyDecodingTests :: TestTree
policyDecodingTests =
  testGroup
    "command policies"
    [ testCase "default, explicit inheritance, and empty clean policies" $
        withSystemTempDirectory "policy-decode" $ \dir -> do
          for_ [("", Inherit), (", environmentPolicy = Schema.EnvironmentPolicy.Inherit", Inherit), (", environmentPolicy = Schema.EnvironmentPolicy.Clean ([] : List Text)", Clean [])] $ \(field, expected) -> do
            writePolicyManifest dir field
            ws <- decodeOrFail (dir </> manifestFileName)
            map (view (#command . #environmentPolicy)) (ws ^. #services) @?= [expected],
      testCase "malformed policy types fail decoding" $
        withSystemTempDirectory "policy-malformed" $ \dir -> do
          for_ ["42", "< Inherit | Clean : Text >.Clean \"PATH\""] $ \value -> do
            writePolicyManifest dir (", environmentPolicy = " <> value)
            decodeWorkspaceFile (dir </> manifestFileName) >>= \case
              Left (DhallFailure _ _) -> pure ()
              other -> assertFailure (show other),
      testCase "invalid and duplicate inherited names reject deterministically in both commands" $
        withSystemTempDirectory "policy-validation" $ \dir -> do
          writePolicyManifest dir ", environmentPolicy = Schema.EnvironmentPolicy.Clean [ \"\", \"9BAD\", \"A=B\", \"A B\", \"PATH\", \"PATH\" ]"
          loaded <- loadWorkspaceContext (ExplicitWorkspace (dir </> manifestFileName)) >>= either (assertFailure . show) pure
          let extraNames = Clean ["A\NULB", "A\nB", "A\tB"]
              withExtra = loaded & #workspace . #services %~ map (\service -> service & #command . #environmentPolicy .~ extraNames)
          validateWorkspace withExtra >>= \case
            Left issues -> assertBool "NUL and whitespace rejected" (length (toList issues) >= 3)
            Right _ -> assertFailure "expected invalid control characters"
          first <- validateWorkspace loaded
          second <- validateWorkspace loaded
          case (first, second) of
            (Left issues, Left again) -> do
              issues @?= again
              length (toList issues) @?= 10
              assertBool "readiness locations present" (any (Text.isInfixOf "/readiness/command/environmentPolicy" . view #location) (toList issues))
            _ -> assertFailure "expected static policy errors"
    ]

writePolicyManifest :: FilePath -> Text -> IO ()
writePolicyManifest dir policyField = do
  schema <- canonicalizePath schemaPackage
  Text.IO.writeFile (dir </> manifestFileName) $
    "let Schema = " <> Text.pack schema <> " let command = Schema.CommandSpec::{ executable = \"/usr/bin/true\" " <> policyField <> " } in Schema.Workspace::{ schemaVersion = 1, services = [ Schema.Service::{ name = \"policy\", command = command, readiness = Schema.Readiness.Command Schema.CommandReadiness::{ command = command } } ] }"