diff --git a/seihou-core.cabal b/seihou-core.cabal --- a/seihou-core.cabal +++ b/seihou-core.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: seihou-core -version: 0.12.1.0 +version: 0.13.0.0 synopsis: Core library for Seihou project scaffolding description: Core library for Seihou, a composable project scaffolding system. @@ -134,6 +134,7 @@ generic-lens >=2.2 && <3, lens >=5.2 && <6, process >=1.6 && <2, + regex-tdfa >=1.3.2 && <1.4, temporary >=1.3 && <2, text >=2.0 && <3, time >=1.12 && <2, diff --git a/src/Seihou/Composition/Resolve.hs b/src/Seihou/Composition/Resolve.hs --- a/src/Seihou/Composition/Resolve.hs +++ b/src/Seihou/Composition/Resolve.hs @@ -30,7 +30,7 @@ import Seihou.Core.ArtifactOriginDetect (OriginInfo (..), readOriginInfo) import Seihou.Core.Module (discoverModule, validateModule) import Seihou.Core.Types -import Seihou.Core.Variable (coerceValue, resolveVariablesWithSaved) +import Seihou.Core.Variable (coerceValue, resolveVariablesWithSaved, resolveVariablesWithSources) import Seihou.Dhall.Eval (evalModuleFromFile) import Seihou.Effect.Console (Console, isInteractive, putText) import Seihou.Interaction.Prompt (promptForVar, runPrompts, runPromptsChecked) @@ -177,7 +177,24 @@ Map VarName Text -> Map VarName Text -> Eff es (Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar))) -resolveWithPromptPermission permission modulesInOrder savedValues cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig = do +resolveWithPromptPermission permission modulesInOrder savedValues cliOverrides = + resolveWithSources permission modulesInOrder savedValues (Map.map (\raw -> (raw, FromCLI)) cliOverrides) + +resolveWithSources :: + (Console :> es) => + PromptPermission -> + [(ModuleInstance, Module, FilePath)] -> + SavedInstanceValues -> + Map VarName (Text, VarSource) -> + Map Text Text -> + Text -> + Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Eff es (Either [VarError] (Map ModuleInstance (Map VarName ResolvedVar))) +resolveWithSources permission modulesInOrder savedValues cliOverrides envVars namespace context localConfig nsConfig ctxConfig globalConfig = do interactive <- case permission of PromptsAllowed -> isInteractive PromptsForbidden -> pure False @@ -198,7 +215,7 @@ adjustedDecls = map (injectExportDefault visibleExports) (m ^. #vars) myParentVars = Map.findWithDefault Map.empty inst parentVarsMap saved = Map.findWithDefault Map.empty inst savedValues - case resolveVariablesWithSaved adjustedDecls cliOverrides saved envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of + case resolveVariablesWithSources adjustedDecls cliOverrides saved envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of Right resolved -> do let declaredNames = Set.fromList (map (^. #name) (m ^. #vars)) inherited = @@ -247,8 +264,8 @@ else do let promptedOverrides = Map.union cliOverrides $ - Map.map (varValueToText . (^. #value)) prompted - case resolveVariablesWithSaved adjustedDecls promptedOverrides saved envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of + Map.map (\rv -> (varValueToText (rv ^. #value), FromPrompt)) prompted + case resolveVariablesWithSources adjustedDecls promptedOverrides saved envVars namespace context localConfig nsConfig ctxConfig globalConfig myParentVars of Left errs' -> pure (Left errs') Right resolved -> do let resolvedWithPromptSource = @@ -316,7 +333,7 @@ interactive <- case permission of PromptsForbidden -> pure False PromptsAllowed -> isInteractive - let explicit = Map.union cli literals + let explicit = Map.union (Map.map (\raw -> (raw, FromCLI)) cli) (Map.map (\raw -> (raw, FromRecipeBinding)) literals) historical d = nubOrdBy id @@ -333,7 +350,7 @@ length (historical d) > 1 ] replay = fromMaybe (Map.fromList [(d ^. #name, raw) | d <- decls, [raw] <- [historical d]]) recorded - results = [resolveVariablesWithSaved [d] explicit replay env ns ctx local nsCfg ctxCfg global Map.empty | d <- decls] + results = [resolveVariablesWithSources [d] explicit replay env ns ctx local nsCfg ctxCfg global Map.empty | d <- decls] values = Map.unions [v | Right v <- results] errors = concat [e | Left e <- results] (_, fatal) = partitionErrors errors @@ -361,18 +378,15 @@ Right extras -> do let recipeValues = Map.union extras current omissions = [MissingRequiredVar (d ^. #name) | d <- decls, d ^. #required, not (Map.member (d ^. #name) recipeValues)] - broadcast = Map.map (varValueToText . (^. #value)) recipeValues + broadcast = Map.map (\rv -> (varValueToText (rv ^. #value), rv ^. #source)) recipeValues if not (null omissions) then pure (Left omissions) else do let owned = Set.fromList (map (^. #name) decls) consumers = [(i, m & #prompts %~ filter (\p -> not (Set.member (p ^. #var) owned)), dir) | (i, m, dir) <- modules] - resolved <- resolveWithPromptPermission permission consumers saved (Map.union explicit broadcast) env ns ctx local nsCfg ctxCfg global - pure $ fmap (\perModule -> (recipeValues, Map.map (Map.mapWithKey (restoreSource recipeValues)) perModule)) resolved + resolved <- resolveWithSources permission consumers saved (Map.union explicit broadcast) env ns ctx local nsCfg ctxCfg global + pure $ fmap (\perModule -> (recipeValues, perModule)) resolved where - restoreSource recipeValues name rv = case Map.lookup name recipeValues of - Just recipeValue | not (Map.member name cli || Map.member name literals) -> rv & #source .~ recipeValue ^. #source - _ -> rv confirmValues [] acc = pure (Right acc) confirmValues ((name, rv) : rest) acc | rv ^. #source /= FromDefault = confirmValues rest acc diff --git a/src/Seihou/Core/Blueprint.hs b/src/Seihou/Core/Blueprint.hs --- a/src/Seihou/Core/Blueprint.hs +++ b/src/Seihou/Core/Blueprint.hs @@ -25,6 +25,7 @@ import Seihou.Core.Migration (BlueprintMigration (..), EntailedEdge (..)) import Seihou.Core.Module (defaultSearchPaths, discoverRunnable, isValidModuleName) import Seihou.Core.Types +import Seihou.Core.Variable (isValidVarBindingName) import Seihou.Core.Version (parseVersion) import Seihou.Prelude import System.Directory (doesFileExist) @@ -376,12 +377,3 @@ let n = dep ^. #module_ . #unModuleName in ["invalid baseModule name: " <> n | not (isValidModuleName n)] <> ["baseModule '" <> n <> "' has invalid var binding name: " <> vn | VarName vn <- Map.keys (dep ^. #vars), not (isValidVarBindingName vn)] - where - isValidVarBindingName :: Text -> Bool - isValidVarBindingName t = case T.uncons t of - Nothing -> False - Just (c, rest) -> - (c >= 'a' && c <= 'z') - && T.all - (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-' || ch == '.') - rest diff --git a/src/Seihou/Core/CommandVar.hs b/src/Seihou/Core/CommandVar.hs --- a/src/Seihou/Core/CommandVar.hs +++ b/src/Seihou/Core/CommandVar.hs @@ -11,7 +11,7 @@ import Seihou.Core.Expr (evalExpr) import Seihou.Core.Path (validateProjectRelativePath) import Seihou.Core.Types -import Seihou.Core.Variable (coerceValue, validateVarValue) +import Seihou.Core.Variable (coerceValue, validateVarValueFrom) import Seihou.Effect.Process (Process, runProcess) import Seihou.Prelude import System.Exit (ExitCode (..)) @@ -112,7 +112,7 @@ Left (ValidationFailed (cv ^. #name) ("command output exceeds maxBytes " <> T.pack (show n))) _ -> do value <- coerceValue (decl ^. #name) (decl ^. #type_) output - validateVarValue decl value + validateVarValueFrom (FromCommand (cv ^. #run)) decl value Right ResolvedVar { value = value, diff --git a/src/Seihou/Core/Recipe.hs b/src/Seihou/Core/Recipe.hs --- a/src/Seihou/Core/Recipe.hs +++ b/src/Seihou/Core/Recipe.hs @@ -12,6 +12,7 @@ import Seihou.Core.Expr (exprRefs) import Seihou.Core.Module (isValidModuleName) import Seihou.Core.Types +import Seihou.Core.Variable (isValidVarBindingName, validateVarPattern) -- | Validate a 'Recipe' against recipe-specific rules. -- Returns 'Right' with the recipe if all rules pass, or 'Left' with a @@ -21,7 +22,7 @@ -- 1. Name matches @[a-z][a-z0-9-]*@ -- 2. At least one module listed -- 3. No duplicate module names in the list --- 4. All variable binding names in module entries match @[a-z][a-z0-9.-]*@ +-- 4. All variable binding names in module entries match @[a-z][A-Za-z0-9.-]*@ -- 5. Recipe variable declarations are unique -- 6. Prompt targets and condition references name declared recipe variables validateRecipe :: Recipe -> Either [Text] Recipe @@ -62,7 +63,7 @@ | Set.member x seen && not (Set.member x reported) = x : findDupes seen (Set.insert x reported) xs | otherwise = findDupes (Set.insert x seen) reported xs --- Rule 4: Variable binding names must match [a-z][a-z0-9.-]* +-- Rule 4: Variable binding names must match [a-z][A-Za-z0-9.-]* checkVarBindingNames :: Recipe -> [Text] checkVarBindingNames recipe = concatMap checkDep (recipe ^. #modules) @@ -76,13 +77,6 @@ ) (Map.keys (dep ^. #vars)) - isValidVarBindingName :: Text -> Bool - isValidVarBindingName t = case T.uncons t of - Nothing -> False - Just (c, rest) -> - (c >= 'a' && c <= 'z') - && T.all (\ch -> (ch >= 'a' && ch <= 'z') || (ch >= '0' && ch <= '9') || ch == '-' || ch == '.') rest - -- Descriptor-local checks deliberately require no values or member schemas. checkRecipeVarsAndPrompts :: Recipe -> [Text] checkRecipeVarsAndPrompts recipe = @@ -97,5 +91,7 @@ | (name@(VarName ref), _) <- refs, undeclared name ] - in map (\name -> "vars: duplicate variable declaration '" <> name <> "'") (findDupes Set.empty Set.empty names) + patternErrors = ["vars: '" <> name <> "' " <> msg | d <- recipe ^. #vars, Left (ValidationFailed (VarName name) msg) <- [validateVarPattern d]] + in patternErrors + <> map (\name -> "vars: duplicate variable declaration '" <> name <> "'") (findDupes Set.empty Set.empty names) <> concatMap promptErrors (recipe ^. #prompts) diff --git a/src/Seihou/Core/Types.hs b/src/Seihou/Core/Types.hs --- a/src/Seihou/Core/Types.hs +++ b/src/Seihou/Core/Types.hs @@ -517,6 +517,7 @@ -- | Tracks where a variable's value came from (for provenance / @--explain@). data VarSource = FromCLI + | FromRecipeBinding | FromApplication | FromEnv Text | FromLocalConfig diff --git a/src/Seihou/Core/Variable.hs b/src/Seihou/Core/Variable.hs --- a/src/Seihou/Core/Variable.hs +++ b/src/Seihou/Core/Variable.hs @@ -1,6 +1,11 @@ module Seihou.Core.Variable ( resolveVariables, resolveVariablesWithSaved, + resolveVariablesWithSources, + isValidVarBindingName, + validateVarPattern, + validateVarValueFrom, + formatVarSource, coerceValue, coerceDefault, validateVarValue, @@ -19,7 +24,17 @@ import Data.Text qualified as T import Seihou.Core.Types import Seihou.Prelude +import Text.Regex.TDFA (CompOption (..), defaultCompOpt, defaultExecOpt) +import Text.Regex.TDFA.Text qualified as Regex +-- | Binding names follow the variable vocabulary, including camelCase segments. +isValidVarBindingName :: Text -> Bool +isValidVarBindingName t = case T.uncons t of + Nothing -> False + Just (c, rest) -> lower c && T.all (\x -> lower x || (x >= 'A' && x <= 'Z') || (x >= '0' && x <= '9') || x == '.' || x == '-') rest + where + lower c = c >= 'a' && c <= 'z' + -- | Derive the environment variable name for a given variable. -- @VarName "project.name"@ becomes @"SEIHOU_VAR_PROJECT_NAME"@. envVarName :: VarName -> Text @@ -76,9 +91,12 @@ checkValidation :: VarName -> Validation -> VarValue -> Either VarError () checkValidation name (ValPattern pat) (VText t) = - if simplePatternMatch pat t - then Right () - else Left (ValidationFailed name ("value does not match pattern: " <> pat)) + do + regex <- compilePattern name pat + case Regex.execute regex t of + Left err -> Left (ValidationFailed name ("pattern execution failed: " <> T.pack err)) + Right Nothing -> Left (ValidationFailed name ("value does not match pattern: " <> pat)) + Right (Just _) -> Right () checkValidation name (ValPattern _) _ = Left (ValidationFailed name "pattern validation requires a text value") checkValidation name (ValRange lo hi) (VInt n) @@ -119,21 +137,37 @@ checkValidation name (ValMaxLength _) _ = Left (ValidationFailed name "max-length validation requires a text value") --- | Simple pattern matching for variable validation. --- For M2, this checks whether the text matches the character class pattern --- @[a-z][a-z0-9-]*@ style patterns. A full regex library can be added later. -simplePatternMatch :: Text -> Text -> Bool -simplePatternMatch pat t - | pat == "[a-z][a-z0-9-]*" = - case T.uncons t of - Just (c, rest) -> - isLowerAlpha c && T.all (\x -> isLowerAlpha x || isDigit x || x == '-') rest - Nothing -> False - | otherwise = True -- unknown patterns pass by default +-- | Compile a whole-value POSIX extended pattern without throwing on bad syntax. +compilePattern :: VarName -> Text -> Either VarError Regex.Regex +compilePattern name pat = do + -- Check the author's pattern separately: the surrounding group must not + -- accidentally balance an unmatched parenthesis in the declaration. + _ <- compile (if T.null pat then "()" else pat) + compile ("^(" <> pat <> ")$") where - isLowerAlpha c = c >= 'a' && c <= 'z' - isDigit c = c >= '0' && c <= '9' + -- regex-tdfa CompOption has no Generic instance; record update syntax is required. + compile patternText = case Regex.compile (defaultCompOpt {multiline = False}) defaultExecOpt patternText of + Left err -> Left (ValidationFailed name ("invalid pattern '" <> pat <> "'; correct the declaration's validation: " <> T.pack err)) + Right regex -> Right regex +-- | Check declarations even when an optional input has no selected value. +validateVarPattern :: VarDecl -> Either VarError () +validateVarPattern decl = case decl ^. #validation of + Just (ValPattern pat) -> () <$ compilePattern (decl ^. #name) pat + _ -> Right () + +-- | Attach the selected source while it is still available, without displaying +-- potentially secret values. The suggested override is supported by run/update. +validateVarValueFrom :: VarSource -> VarDecl -> VarValue -> Either VarError () +validateVarValueFrom source decl val = case validateVarValue decl val of + Left (ValidationFailed name msg) -> + Left (ValidationFailed name ("from " <> formatVarSource source <> ": " <> msg <> "; supply --var " <> name ^. #unVarName <> "=" <> correction <> " satisfying the constraint")) + other -> other + where + correction = case decl ^. #default_ of + Just (VText raw) | Right () <- validateVarValue decl (VText raw) -> raw + _ -> "VALUE" + -- | Resolve all variables for a module given CLI overrides, environment variables, -- four config file layers, and parent-supplied variable bindings. -- @@ -179,39 +213,58 @@ Map VarName Text -> -- Global config Map VarName (Text, ModuleName) -> -- Parent-supplied vars Either [VarError] (Map VarName ResolvedVar) -resolveVariablesWithSaved decls cliOverrides savedValues envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars = +resolveVariablesWithSaved decls cliOverrides = + resolveVariablesWithSources decls (Map.map (\raw -> (raw, FromCLI)) cliOverrides) + +-- | Resolve explicit inputs carrying their actual source (recipe bindings and +-- already accepted recipe inputs use the same precedence as explicit values). +resolveVariablesWithSources :: + [VarDecl] -> + Map VarName (Text, VarSource) -> + Map VarName Text -> + Map Text Text -> + Text -> + Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName Text -> + Map VarName (Text, ModuleName) -> + Either [VarError] (Map VarName ResolvedVar) +resolveVariablesWithSources decls explicitValues savedValues envVars namespace context localConfig nsConfig ctxConfig globalConfig parentVars = case partitionResults (map resolveOne decls) of ([], resolved) -> Right (Map.fromList (catMaybes resolved)) (errs, _) -> Left errs where resolveOne :: VarDecl -> Either VarError (Maybe (VarName, ResolvedVar)) - resolveOne decl = + resolveOne decl = do + validateVarPattern decl let name = (decl ^. #name) ty = (decl ^. #type_) - in case lookupCLI name ty of + case lookupCLI name ty of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupSaved name ty of + Just result -> fmap Just (result >>= validateAndWrap decl) + Nothing -> case lookupEnv name ty of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupSaved name ty of + Nothing -> case lookupConfig name ty localConfig FromLocalConfig of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupEnv name ty of + Nothing -> case lookupConfig name ty nsConfig (FromNamespaceConfig namespace) of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupConfig name ty localConfig FromLocalConfig of + Nothing -> case lookupConfig name ty ctxConfig (FromContextConfig context) of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupConfig name ty nsConfig (FromNamespaceConfig namespace) of + Nothing -> case lookupConfig name ty globalConfig FromGlobalConfig of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupConfig name ty ctxConfig (FromContextConfig context) of + Nothing -> case lookupParent name ty of Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupConfig name ty globalConfig FromGlobalConfig of - Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case lookupParent name ty of - Just result -> fmap Just (result >>= validateAndWrap decl) - Nothing -> case decl ^. #default_ of - Just defVal -> - case coerceDefault name ty defVal of - Left err -> Left err - Right val -> fmap Just (validateAndWrap decl (val, FromDefault)) - Nothing - | decl ^. #required -> Left (MissingRequiredVar name) - | otherwise -> Right Nothing + Nothing -> case decl ^. #default_ of + Just defVal -> + case coerceDefault name ty defVal of + Left err -> Left err + Right val -> fmap Just (validateAndWrap decl (val, FromDefault)) + Nothing + | decl ^. #required -> Left (MissingRequiredVar name) + | otherwise -> Right Nothing lookupSaved :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) lookupSaved name ty = @@ -233,12 +286,12 @@ lookupCLI :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) lookupCLI name ty = - case Map.lookup name cliOverrides of + case Map.lookup name explicitValues of Nothing -> Nothing - Just rawText -> + Just (rawText, source) -> Just $ case coerceValue name ty rawText of Left err -> Left err - Right val -> Right (val, FromCLI) + Right val -> Right (val, source) lookupEnv :: VarName -> VarType -> Maybe (Either VarError (VarValue, VarSource)) lookupEnv name ty = @@ -261,7 +314,7 @@ validateAndWrap :: VarDecl -> (VarValue, VarSource) -> Either VarError (VarName, ResolvedVar) validateAndWrap decl (val, source) = - case validateVarValue decl val of + case validateVarValueFrom source decl val of Left err -> Left err Right () -> Right @@ -306,18 +359,23 @@ showValue (VInt n) = T.pack (show n) showValue (VList vs) = "[" <> T.intercalate ", " (map showValue vs) <> "]" - showSource :: VarSource -> Text - showSource FromCLI = "[--var]" - showSource FromApplication = "[application]" - showSource (FromEnv envKey) = "[env " <> envKey <> "]" - showSource FromLocalConfig = "[local config]" - showSource (FromNamespaceConfig ns) = "[namespace: " <> ns <> "]" - showSource (FromContextConfig ctx) = "[context: " <> ctx <> "]" - showSource FromGlobalConfig = "[global config]" - showSource (FromParent mn) = "[parent: " <> mn ^. #unModuleName <> "]" - showSource FromDefault = "[default]" - showSource FromPrompt = "[prompt]" showSource (FromCommand cmd) = "[command: " <> cmd <> "]" + showSource source = "[" <> formatVarSource source <> "]" + +-- | Shared human-readable source vocabulary for diagnostics and --explain. +formatVarSource :: VarSource -> Text +formatVarSource FromCLI = "--var" +formatVarSource FromRecipeBinding = "literal recipe binding" +formatVarSource FromApplication = "application" +formatVarSource (FromEnv envKey) = "env " <> envKey +formatVarSource FromLocalConfig = "local config" +formatVarSource (FromNamespaceConfig ns) = "namespace: " <> ns +formatVarSource (FromContextConfig ctx) = "context: " <> ctx +formatVarSource FromGlobalConfig = "global config" +formatVarSource (FromParent mn) = "parent: " <> mn ^. #unModuleName +formatVarSource FromDefault = "default" +formatVarSource FromPrompt = "prompt" +formatVarSource (FromCommand _) = "command" -- | Format variable declarations for default mode output. -- Produces aligned output with @=@ signs and 2-space indent. diff --git a/src/Seihou/Interaction/Prompt.hs b/src/Seihou/Interaction/Prompt.hs --- a/src/Seihou/Interaction/Prompt.hs +++ b/src/Seihou/Interaction/Prompt.hs @@ -10,7 +10,7 @@ import Data.Text qualified as T import Seihou.Core.Expr (evalExpr) import Seihou.Core.Types -import Seihou.Core.Variable (coerceDefault, coerceValue, validateVarValue) +import Seihou.Core.Variable (coerceDefault, coerceValue, validateVarValueFrom) import Seihou.Effect.Console (Console, getLine, putText) import Seihou.Prelude import Prelude hiding (getLine) @@ -109,7 +109,7 @@ then case decl ^. #default_ of Just defVal -> pure $ do val <- coerceDefault (decl ^. #name) (decl ^. #type_) defVal - validateVarValue decl val + validateVarValueFrom FromPrompt decl val Right ResolvedVar {value = val, source = FromPrompt, decl = decl} Nothing | not (decl ^. #required) -> @@ -165,7 +165,7 @@ coerceAndValidate :: VarDecl -> Text -> Either VarError ResolvedVar coerceAndValidate decl raw = do val <- coerceValue (decl ^. #name) (decl ^. #type_) raw - validateVarValue decl val + validateVarValueFrom FromPrompt decl val pure ResolvedVar { value = val, diff --git a/test/Seihou/Composition/RecipeSpec.hs b/test/Seihou/Composition/RecipeSpec.hs --- a/test/Seihou/Composition/RecipeSpec.hs +++ b/test/Seihou/Composition/RecipeSpec.hs @@ -21,6 +21,11 @@ spec :: Spec spec = do describe "expandRecipe" $ do + it "keeps the first camelCase binding across the flattened composition" $ do + let recipe = Recipe "policy" Nothing Nothing [Dependency "one" (Map.singleton "git.githubOwner" "first") Nothing, Dependency "two" (Map.singleton "git.githubOwner" "second") Nothing] [] [] + (_, _, overrides, _, _, _) = expectExpanded recipe + Map.lookup "git.githubOwner" overrides `shouldBe` Just "first" + it "returns correct primary and additional module names" $ do let recipe = Recipe diff --git a/test/Seihou/Composition/ResolveSpec.hs b/test/Seihou/Composition/ResolveSpec.hs --- a/test/Seihou/Composition/ResolveSpec.hs +++ b/test/Seihou/Composition/ResolveSpec.hs @@ -1,9 +1,10 @@ module Seihou.Composition.ResolveSpec (tests) where -import Control.Lens ((^.)) +import Control.Lens ((&), (.~), (^.)) import Data.Generics.Labels () import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text qualified import Seihou.Composition.Instance (ModuleInstance (..), mkInstance, primaryInstance) import Seihou.Composition.Resolve import Seihou.Core.Types @@ -103,6 +104,15 @@ Map.null result `shouldBe` True describe "resolveComposedVariables" $ do + it "validates exported defaults against the consuming declaration" $ do + let base = mkModule "base" [] [mkTextVar "git.githubOwner" (Just (VText "personal")) False] [mkExport "git.githubOwner"] + owner = mkTextVar "git.githubOwner" Nothing True & #validation .~ Just (ValPattern "^topagentnetwork$") + app = mkModule "app" ["base"] [owner] [] + result = resolveComposedVariables (asInstances [(base, "/base"), (app, "/app")]) Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty + case result of + Left [ValidationFailed "git.githubOwner" msg] -> msg `shouldSatisfy` Data.Text.isInfixOf "default" + other -> expectationFailure (show other) + it "resolves a single module with no dependencies" $ do let m = mkModule "base" [] [mkTextVar "project.name" (Just (VText "default")) False] [] modules = asInstances [(m, "/fake/base")] diff --git a/test/Seihou/Core/BlueprintSpec.hs b/test/Seihou/Core/BlueprintSpec.hs --- a/test/Seihou/Core/BlueprintSpec.hs +++ b/test/Seihou/Core/BlueprintSpec.hs @@ -237,6 +237,19 @@ Left err -> expectationFailure ("Expected Right, got: " <> show err) describe "validateBlueprintWith (rule-by-rule)" $ do + it "accepts camelCase base bindings and preserves invalid-name diagnostics" $ + withSystemTempDirectory "seihou-binding-names" $ \tmpDir -> do + let base = tmpDir "base" + createDirectoryIfMissing True base + cwd <- getCurrentDirectory + writeFile (base "module.dhall") ("let S = " <> cwd <> "/../schema/package.dhall in S.Module::{name=\"base\"}") + let bp names = withBlueprintBaseModules [Dependency "base" (Map.fromList [(VarName name, "value") | name <- names]) Nothing] goodBlueprint + validateBlueprintWith [tmpDir] tmpDir (bp ["git.githubOwner", "git.createGithub", "git.githubVisibility"]) `shouldReturn` Right (bp ["git.githubOwner", "git.createGithub", "git.githubVisibility"]) + result <- validateBlueprintWith [tmpDir] tmpDir (bp ["INVALID", "git_owner", ""]) + case result of + Left (ValidationError _ errs) -> length (filter (T.isInfixOf "invalid var binding name") errs) `shouldBe` 3 + other -> expectationFailure (show other) + it "rejects an invalid blueprint name" $ do withSystemTempDirectory "seihou-test" $ \tmpDir -> do let bad = withBlueprintName "Bad_Name" goodBlueprint diff --git a/test/Seihou/Core/RecipeSpec.hs b/test/Seihou/Core/RecipeSpec.hs --- a/test/Seihou/Core/RecipeSpec.hs +++ b/test/Seihou/Core/RecipeSpec.hs @@ -1,5 +1,7 @@ module Seihou.Core.RecipeSpec (tests) where +import Control.Lens ((&), (.~)) +import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T import Seihou.Core.Recipe (validateRecipe) @@ -17,6 +19,10 @@ spec :: Spec spec = do describe "validateRecipe" $ do + it "accepts camelCase bindings without recipe declarations or installed members" $ do + let recipe = interactiveRecipe & #modules .~ [Dependency "unavailable" (Map.fromList [("git.githubOwner", "tan"), ("git.createGithub", "true"), ("git.githubVisibility", "private")]) Nothing] + validateRecipe recipe `shouldBe` Right recipe + it "passes a valid recipe" $ do let recipe = Recipe @@ -114,6 +120,12 @@ case validateRecipe recipe of Left errs -> length errs `shouldSatisfy` (>= 2) Right _ -> expectationFailure "Expected validation failure" + + it "rejects malformed patterns without resolving absent optional inputs or members" $ do + let recipe = interactiveRecipe & #vars .~ [VarDecl "owner" VTText Nothing Nothing False (Just (ValPattern "["))] & #prompts .~ [] + case validateRecipe recipe of + Left errs -> hasError "invalid pattern" errs `shouldBe` True + Right _ -> expectationFailure "Expected descriptor-local pattern failure" it "accepts unanswered required declarations and nested conditions" $ do validateRecipe interactiveRecipe `shouldBe` Right interactiveRecipe diff --git a/test/Seihou/Core/VariableSpec.hs b/test/Seihou/Core/VariableSpec.hs --- a/test/Seihou/Core/VariableSpec.hs +++ b/test/Seihou/Core/VariableSpec.hs @@ -1,6 +1,7 @@ module Seihou.Core.VariableSpec (tests) where -import Control.Lens ((^.)) +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text qualified as T @@ -64,6 +65,57 @@ spec :: Spec spec = do + describe "binding names" $ do + forM_ ["git.githubOwner", "git.createGithub", "git.githubVisibility", "a", "a.Z-9"] $ \name -> + it ("accepts " <> T.unpack name) $ isValidVarBindingName name `shouldBe` True + forM_ ["", "Owner", "9name", "git_owner", "git owner", "git/owner", "aé"] $ \name -> + it ("rejects " <> T.unpack name) $ isValidVarBindingName name `shouldBe` False + describe "whole-value patterns" $ do + let validate pat value = validateVarValue (textVar "owner" False Nothing (Just (ValPattern pat))) (VText value) + rejected (Left (ValidationFailed _ _)) = True + rejected _ = False + forM_ ["^topagentnetwork$", "topagentnetwork", "(topagentnetwork)"] $ \pat -> do + it ("accepts the exact owner with " <> T.unpack pat) $ validate pat "topagentnetwork" `shouldBe` Right () + forM_ ["", "someone-else", "xtopagentnetwork", "topagentnetworkx", "topagentnetwork\n", "x\ntopagentnetwork", "topagentnetwork\nx"] $ \bad -> + it ("rejects " <> show bad <> " with " <> T.unpack pat) $ validate pat bad `shouldSatisfy` rejected + forM_ ["private", "public", "internal"] $ \value -> + it ("accepts choice " <> T.unpack value) $ validate "private|public|internal" value `shouldBe` Right () + forM_ ["private-extra", "xpublic", "internal\n", "Private"] $ \value -> + it ("rejects partial choice " <> show value) $ validate "private|public|internal" value `shouldSatisfy` rejected + it "handles an empty pattern as exactly the empty value" $ do + validate "" "" `shouldBe` Right () + validate "" "x" `shouldSatisfy` rejected + it "supports POSIX classes, repetition and grouping" $ validate "[[:upper:]][[:alnum:]]{1,3}" "A12" `shouldBe` Right () + it "rejects parentheses that the wrapper could otherwise balance" $ validate "a)|b|(" "b" `shouldSatisfy` rejected + it "preserves absence of a well-formed optional input" $ do + let decl = textVar "owner" False Nothing (Just (ValPattern "^topagentnetwork$")) + resolveVariablesWithSaved [decl] Map.empty Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty Map.empty `shouldBe` Right Map.empty + it "reports malformed syntax even for an absent optional input" $ do + let decl = textVar "owner" False Nothing (Just (ValPattern "[")) + validate "[" "x" `shouldSatisfy` rejected + resolveVariables [decl] Map.empty Map.empty "" "" Map.empty Map.empty Map.empty Map.empty Map.empty `shouldSatisfy` either (any (\e -> case e of ValidationFailed _ msg -> "invalid pattern" `T.isInfixOf` msg; _ -> False)) (const False) + describe "constraint source enforcement" $ do + let name = "git.githubOwner" + decl = textVar name False (Just (VText "topagentnetwork")) (Just (ValPattern "^topagentnetwork$")) + resolve source raw = + let values = Map.singleton name raw + layer label = if source == label then values else Map.empty + explicit = if source == "literal recipe binding" then Map.singleton name (raw, FromRecipeBinding) else Map.map (\v -> (v, FromCLI)) (layer "--var") + env = if source == "env SEIHOU_VAR_GIT_GITHUBOWNER" then Map.singleton "SEIHOU_VAR_GIT_GITHUBOWNER" raw else Map.empty + parent = if source == "parent: parent" then Map.singleton name (raw, "parent") else Map.empty + selected = if source == "default" then decl & #default_ .~ Just (VText raw) else decl + in resolveVariablesWithSources [selected] explicit (layer "application") env "test-ns" "test-ctx" (layer "local config") (layer "namespace: test-ns") (layer "context: test-ctx") (layer "global config") parent + forM_ ["--var", "literal recipe binding", "application", "env SEIHOU_VAR_GIT_GITHUBOWNER", "local config", "namespace: test-ns", "context: test-ctx", "global config", "parent: parent", "default"] $ \source -> do + it ("accepts policy from " <> T.unpack source) $ case resolve source "topagentnetwork" of + Left errs -> expectationFailure (show errs) + Right values -> (values Map.! name) ^. #value `shouldBe` VText "topagentnetwork" + it ("rejects policy violation from " <> T.unpack source <> " without falling back") $ case resolve source "personal-secret" of + Left [ValidationFailed key msg] -> do + key `shouldBe` name + msg `shouldSatisfy` T.isInfixOf source + msg `shouldSatisfy` T.isInfixOf "^topagentnetwork$" + msg `shouldSatisfy` (not . T.isInfixOf "personal-secret") + other -> expectationFailure (show other) describe "envVarName" $ do it "converts project.name to SEIHOU_VAR_PROJECT_NAME" $ do envVarName "project.name" `shouldBe` "SEIHOU_VAR_PROJECT_NAME" diff --git a/test/Seihou/Interaction/PromptSpec.hs b/test/Seihou/Interaction/PromptSpec.hs --- a/test/Seihou/Interaction/PromptSpec.hs +++ b/test/Seihou/Interaction/PromptSpec.hs @@ -1,9 +1,11 @@ module Seihou.Interaction.PromptSpec (tests) where import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) import Data.Generics.Labels () import Data.Map.Strict qualified as Map import Data.Text (Text) +import Data.Text qualified as T import Effectful import Seihou.Composition.Instance (primaryInstance) import Seihou.Composition.Resolve (PromptPermission (..), RecipeInputSpec (..), resolveRecipeWithPrompts, resolveWithPromptPermission, resolveWithPrompts) @@ -172,6 +174,59 @@ Right (inputs, _) -> (inputs Map.! "feature") ^. #value `shouldBe` VBool False Left errs -> expectationFailure (show errs) console ^. #outputs `shouldBe` [] + + describe "owner policy" $ do + let owner = mkTextVar "git.githubOwner" Nothing True + policy = owner & #validation .~ Just (ValPattern "^topagentnetwork$") + prompt = mkPrompt "git.githubOwner" "Owner?" + check source (Left [ValidationFailed "git.githubOwner" msg]) = msg `shouldSatisfy` T.isInfixOf source + check _ other = expectationFailure (show other) + resolve recipeDecl memberDecl recorded cli literals global answers confirm = + fst $ + runPureEff $ + runConsolePure answers $ + resolveRecipeWithPrompts + PromptsAllowed + confirm + (RecipeInputSpec [recipeDecl] [prompt] recorded) + [(primaryInstance "consumer", mkModule "consumer" [] [memberDecl] [] [], "/fixture")] + Map.empty + cli + literals + Map.empty + "" + "" + Map.empty + Map.empty + Map.empty + global + forM_ [True, False] $ \recipeOwnsPolicy -> do + let r = if recipeOwnsPolicy then policy else owner + m = if recipeOwnsPolicy then owner else policy + it ("rejects global input with its source; recipe policy=" <> show recipeOwnsPolicy) $ + check "global config" (resolve r m Nothing Map.empty Map.empty (Map.singleton "git.githubOwner" "personal") [] False) + it ("revalidates history with its source; recipe policy=" <> show recipeOwnsPolicy) $ + check "application" (resolve r m (Just (Map.singleton "git.githubOwner" "personal")) Map.empty Map.empty Map.empty [] False) + it ("rejects literals with their source; recipe policy=" <> show recipeOwnsPolicy) $ + check "literal recipe binding" (resolve r m Nothing Map.empty (Map.singleton "git.githubOwner" "personal") Map.empty [] False) + it ("rejects prompt input with its source; recipe policy=" <> show recipeOwnsPolicy) $ + check "prompt" (resolve r m Nothing Map.empty Map.empty Map.empty ["personal", "personal", "personal"] False) + it "accepts a valid retry after a rejected answer" $ do + case resolve policy owner Nothing Map.empty Map.empty Map.empty ["personal", "topagentnetwork"] False of + Right (inputs, _) -> (inputs Map.! "git.githubOwner") ^. #source `shouldBe` FromPrompt + other -> expectationFailure (show other) + it "validates numbered prompt choices" $ do + let (result, _) = runPureEff $ runConsolePure ["1"] $ promptForVar (mkChoicePrompt "git.githubOwner" "Owner?" ["personal", "topagentnetwork"]) policy Map.empty + case result of + Left (ValidationFailed _ msg) -> msg `shouldSatisfy` T.isInfixOf "prompt" + other -> expectationFailure (show other) + it "validates a changed answer during confirm-defaults" $ + check "prompt" (resolve (policy & #default_ .~ Just (VText "topagentnetwork")) owner Nothing Map.empty Map.empty Map.empty ["personal", "personal", "personal"] True) + it "validates an accepted prompt default" $ do + let (result, _) = runPureEff $ runConsolePure [""] $ promptForVar prompt (policy & #default_ .~ Just (VText "personal")) Map.empty + case result of + Left (ValidationFailed _ msg) -> msg `shouldSatisfy` T.isInfixOf "prompt" + other -> expectationFailure (show other) describe "runPrompts" $ do it "fills a required text variable with FromPrompt source" $ do