seihou-core 0.12.1.0 → 0.13.0.0

raw patch · 14 files changed

+300/−91 lines, 14 filesdep +regex-tdfaPVP ok

version bump matches the API change (PVP)

Dependencies added: regex-tdfa

API changes (from Hackage documentation)

Files

• seihou-core.cabal +2/−1
• src/Seihou/Composition/Resolve.hs +27/−13
• src/Seihou/Core/Blueprint.hs +1/−9
• src/Seihou/Core/CommandVar.hs +2/−2
• src/Seihou/Core/Recipe.hs +6/−10
• src/Seihou/Core/Types.hs +1/−0
• src/Seihou/Core/Variable.hs +109/−51
• src/Seihou/Interaction/Prompt.hs +3/−3
• test/Seihou/Composition/RecipeSpec.hs +5/−0
• test/Seihou/Composition/ResolveSpec.hs +11/−1
• test/Seihou/Core/BlueprintSpec.hs +13/−0
• test/Seihou/Core/RecipeSpec.hs +12/−0
• test/Seihou/Core/VariableSpec.hs +53/−1
• test/Seihou/Interaction/PromptSpec.hs +55/−0

@@ -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,

@@ -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

@@ -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

@@ -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,

@@ -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)

@@ -517,6 +517,7 @@ -- | Tracks where a variable's value came from (for provenance / @--explain@). data VarSource   = FromCLI+  | FromRecipeBinding   | FromApplication   | FromEnv Text   | FromLocalConfig

@@ -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.

@@ -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,

@@ -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

@@ -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")]

@@ -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

@@ -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

@@ -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"

@@ -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