From 45b8393e11fb3dd31a48d2502f74fe6d5559bd47 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 27 May 2026 13:09:55 +0000 Subject: [PATCH 1/6] Add w3_validate_ validation hook for generated custom-type decoders When a module defines `w3_validate_ : -> Result String ()` for a custom type, the generated `w3_decode_` now calls it after decoding: `Ok ()` decodes successfully, while `Err msg` logs the message via Lamdera.Wire3.debug and fails the decode. Each w3_validate_ function is verified at compile time: the named type must be a custom type defined in the same module (not a type alias, and not missing), the function must have a type annotation, and its signature must be exactly ` -> Result String ()` using the type's declared variables. Any violation is a compile error. When a module contains validators, the generated wire functions are placed after user definitions so the generated decoders can reference them. Tests: a compiling fixture covering the codegen (plain tvar, number-constrained tvar, and nested usage), plus compile-error fixtures for the undefined-type, type-alias, missing-annotation, wrong-signature, and concrete-tvar cases. https://claude.ai/code/session_01URzKFJwLCrv3r2W28bPiW6 --- extra/Lamdera/Wire3/Core.hs | 177 ++++++++++++++++-- extra/Lamdera/Wire3/Decoder.hs | 93 ++++++++- extra/Lamdera/Wire3/Helpers.hs | 82 ++++++++ test/Test/Wire.hs | 45 +++++ .../src/Test/Wire_Validate.elm | 65 +++++++ .../src/Test/Wire_Validate_Err_Alias.elm | 14 ++ .../src/Test/Wire_Validate_Err_BadSig.elm | 16 ++ .../Test/Wire_Validate_Err_NoAnnotation.elm | 15 ++ .../src/Test/Wire_Validate_Err_NoType.elm | 11 ++ .../Test/Wire_Validate_Err_TvarConcrete.elm | 16 ++ .../src/Test/Wire_Validate_Number.elm | 15 ++ 11 files changed, 535 insertions(+), 14 deletions(-) create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_Alias.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_BadSig.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_NoAnnotation.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_NoType.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarConcrete.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Number.elm diff --git a/extra/Lamdera/Wire3/Core.hs b/extra/Lamdera/Wire3/Core.hs index 5d0ffa62..7e50d015 100644 --- a/extra/Lamdera/Wire3/Core.hs +++ b/extra/Lamdera/Wire3/Core.hs @@ -201,10 +201,27 @@ addWireGenerations_ canonical pkg ifaces modul = existingDecls = foldl (\def decls -> removeDef decls def ) decls_ newDefs + cname = Module.Canonical pkg (Src.getName modul) + + {- When a module defines any w3_validate_* functions, the generated wire + functions must be placed AFTER user definitions so that the generated + decoders can reference those user validators (a VarTopLevel reference only + resolves to definitions appearing earlier in the topologically-sorted + Decls). Otherwise we keep the original behaviour of prepending the generated + functions, which lets user code reference them. -} + moduleHasValidators = + not (null (allValidatorDefs decls_)) + + sortedGenerated = + Lamdera.Wire3.Graph.stronglyConnCompDefs newDefs + extendedDecls = - newDefs - & Lamdera.Wire3.Graph.stronglyConnCompDefs - & Lamdera.Wire3.Graph.addGraphDefsToDecls existingDecls + if moduleHasValidators + then + spliceDeclsAtEnd existingDecls + (Lamdera.Wire3.Graph.addGraphDefsToDecls SaveTheEnvironment sortedGenerated) + else + Lamdera.Wire3.Graph.addGraphDefsToDecls existingDecls sortedGenerated {- This implementation sorted all decls, however sorting only by lvar is not a valid dependency sort for all functions, only for wire functions! @@ -230,10 +247,133 @@ addWireGenerations_ canonical pkg ifaces modul = exports & Export in - Right $ canonical - { _decls = extendedDecls - , _exports = extendedExports - } + case checkValidators cname (Can._unions canonical) (Can._aliases canonical) decls_ of + Left err -> + Left err + + Right () -> + Right $ canonical + { _decls = extendedDecls + , _exports = extendedExports + } + + +{- + +WIRE VALIDATION CHECKS + +For every top-level `w3_validate_` function defined in the module, +verify that is a custom type (not a type alias, and actually defined +here) and that the function's signature is exactly: + + w3_validate_ : -> Result String () + +where are the type's declared type variables, in order. Any violation +produces a compile error. + +-} +checkValidators :: Module.Canonical -> Map.Map Data.Name.Name Union -> Map.Map Data.Name.Name Alias -> Decls -> Either D.Doc () +checkValidators cname unions aliases decls = + allValidatorDefs decls + & mapM_ (\def -> + let typeName = validatorTypeName (defName def) + in + case Map.lookup typeName unions of + Just union -> + checkValidatorSignature cname typeName union def + Nothing -> + case Map.lookup typeName aliases of + Just _ -> Left (validatorAliasError typeName) + Nothing -> Left (validatorMissingTypeError typeName) + ) + + +checkValidatorSignature :: Module.Canonical -> Data.Name.Name -> Union -> Def -> Either D.Doc () +checkValidatorSignature cname typeName union def = + case def of + Def _ _ _ -> + Left (validatorMissingAnnotationError typeName union) + + TypedDef _ _ args _ resultType -> + let + actualType = foldr (\(_, t) acc -> TLambda t acc) resultType args + expectedType = expectedValidatorType cname typeName union + in + if actualType == expectedType + then Right () + else Left (validatorBadSignatureError typeName union) + + +expectedValidatorType :: Module.Canonical -> Data.Name.Name -> Union -> Type +expectedValidatorType cname typeName union = + TLambda + (TType cname typeName (fmap TVar (_u_vars union))) + (TType (Module.Canonical (Name "elm" "core") "Result") "Result" + [ TType (Module.Canonical (Name "elm" "core") "String") "String" [] + , TUnit + ]) + + +validatorSignatureString :: Data.Name.Name -> Union -> String +validatorSignatureString typeName union = + let + typeWithVars = + case _u_vars union of + [] -> Data.Name.toChars typeName + vars -> Data.Name.toChars typeName ++ " " ++ unwords (fmap Data.Name.toChars vars) + in + "w3_validate_" ++ Data.Name.toChars typeName ++ " : " ++ typeWithVars ++ " -> Result String ()" + + +-- NOTE: The leading D.fromChars line in each error is a contiguous (un-wrapped) +-- marker so tests can reliably match on it; D.reflow may insert line breaks. + +validatorMissingTypeError :: Data.Name.Name -> D.Doc +validatorMissingTypeError typeName = + D.stack + [ D.fromChars $ "w3_validate_" ++ Data.Name.toChars typeName ++ ": no matching custom type" + , D.reflow $ + "I found a wire validation function `w3_validate_" ++ Data.Name.toChars typeName + ++ "`, but there is no custom type named `" ++ Data.Name.toChars typeName + ++ "` defined in this module." + , D.reflow $ + "Wire validation functions must be defined in the same module as the custom type they validate. " + ++ "Define `type " ++ Data.Name.toChars typeName ++ " = ...` here, or remove the validation function." + ] + + +validatorAliasError :: Data.Name.Name -> D.Doc +validatorAliasError typeName = + D.stack + [ D.fromChars $ "w3_validate_" ++ Data.Name.toChars typeName ++ ": expected a custom type, found a type alias" + , D.reflow $ + "I found a wire validation function `w3_validate_" ++ Data.Name.toChars typeName + ++ "`, but `" ++ Data.Name.toChars typeName ++ "` is a type alias, not a custom type." + , D.reflow + "Wire validation functions (w3_validate_*) are only supported for custom types (defined with `type`), not for type aliases (`type alias`)." + ] + + +validatorMissingAnnotationError :: Data.Name.Name -> Union -> D.Doc +validatorMissingAnnotationError typeName union = + D.stack + [ D.fromChars $ "w3_validate_" ++ Data.Name.toChars typeName ++ ": missing type annotation" + , D.reflow $ + "The wire validation function `w3_validate_" ++ Data.Name.toChars typeName + ++ "` must have a type annotation. It needs to be annotated exactly like this:" + , D.fromChars $ " " ++ validatorSignatureString typeName union + ] + + +validatorBadSignatureError :: Data.Name.Name -> Union -> D.Doc +validatorBadSignatureError typeName union = + D.stack + [ D.fromChars $ "w3_validate_" ++ Data.Name.toChars typeName ++ ": wrong type signature" + , D.reflow $ + "The wire validation function `w3_validate_" ++ Data.Name.toChars typeName + ++ "` has the wrong type signature. It must be exactly:" + , D.fromChars $ " " ++ validatorSignatureString typeName union + ] addExport :: Def -> Map.Map Data.Name.Name (A.Located Export) -> Map.Map Data.Name.Name (A.Located Export) @@ -361,12 +501,7 @@ decoderUnion isTest_ ifaces pkg modul decls unionName union = -- | numCtors <= 4294967295 = decodeUnsignedInt32 | otherwise = error $ "Unhandled custom type variant size (" ++ show numCtors ++ "), please report this issue for the custom type " ++ Data.Name.toChars unionName - generated = - Def - -- TypedDef - (a (generatedName)) - -- Map.empty - ptvars $ + baseBody = -- debugDecoder (Data.Name.toElmString unionName) (variantIntDecoder |> andThenDecode1 (lambda1 (pvar "w3v") $ @@ -382,6 +517,22 @@ decoderUnion isTest_ ifaces pkg modul decls unionName union = & (\l -> l ++ [CaseBranch pAny_ $ failDecode (Data.Name.toChars generatedName <> " unexpected union tag index")]) ) ) + + {- If the current module defines `w3_validate_`, the decoder calls + it after producing a value. The function's existence and signature are + verified by checkValidators in addWireGenerations_ before this runs. -} + finalBody = + case findValidatorDef decls unionName of + Just _ -> wrapWithValidator ifaces cname unionName baseBody + Nothing -> baseBody + + generated = + Def + -- TypedDef + (a (generatedName)) + -- Map.empty + ptvars + finalBody -- (TAlias -- (Module.Canonical (Name "lamdera" "codecs") "Lamdera.Wire3") -- "Decoder" diff --git a/extra/Lamdera/Wire3/Decoder.hs b/extra/Lamdera/Wire3/Decoder.hs index 408cc2b6..fc1acf53 100644 --- a/extra/Lamdera/Wire3/Decoder.hs +++ b/extra/Lamdera/Wire3/Decoder.hs @@ -466,4 +466,95 @@ decodeRecord ifaces cname fields = decoderForType ifaces cname field ) ) fields - & foldlPairs (|>) \ No newline at end of file + & foldlPairs (|>) + + +{- Wrap a generated custom-type decoder so that, after producing a value, it +calls the user-defined `w3_validate_` function from the current +module. If that returns `Ok ()` the value decodes successfully; if it returns +`Err msg` we log the message via Lamdera.Wire3.debug and fail the decode. + +This produces, in effect: + + + |> Lamdera.Wire3.andThenDecode + (\w3_validate_value -> + case w3_validate_ w3_validate_value of + Ok _ -> + Lamdera.Wire3.succeedDecode w3_validate_value + + Err w3_validate_err -> + let _ = Lamdera.Wire3.debug w3_validate_err + in Lamdera.Wire3.failDecode + ) +-} +wrapWithValidator :: Map.Map Module.Raw I.Interface -> Module.Canonical -> Data.Name.Name -> Expr -> Expr +wrapWithValidator ifaces cname typeName decoderBody = + let + validateRef = a (VarTopLevel cname (validatorNameFor typeName)) + valueVar = "w3_validate_value" + errVar = "w3_validate_err" + resultUnion = lookupResultUnion ifaces + + validationCase = + caseof (call validateRef [lvar valueVar]) + [ CaseBranch + (resultCtorPattern resultUnion "Ok" (a PAnything)) + (succeedDecode (lvar valueVar)) + , CaseBranch + (resultCtorPattern resultUnion "Err" (a (PVar errVar))) + (addLetLogValue (lvar errVar) + (failDecode (Data.Name.toChars (validatorNameFor typeName) <> " returned an Err"))) + ] + in + decoderBody |> andThenDecode1 (lambda1 (pvar valueVar) validationCase) + + +{- The canonical elm/core Result union, used to build `Ok`/`Err` patterns. +Result is always a default import so it's expected to be present in ifaces; we +fall back to a hand-written definition just in case. -} +lookupResultUnion :: Map.Map Module.Raw I.Interface -> Union +lookupResultUnion ifaces = + case Map.lookup "Result" ifaces of + Just iface -> + case Map.lookup "Result" (I._unions iface) of + Just iunion -> I.extractUnion iunion + Nothing -> hardcodedResultUnion + Nothing -> hardcodedResultUnion + + +hardcodedResultUnion :: Union +hardcodedResultUnion = + Union + { _u_vars = ["error", "value"] + , _u_alts = + [ Ctor "Ok" (Index.ZeroBased 0) 1 [TVar "value"] + , Ctor "Err" (Index.ZeroBased 1) 1 [TVar "error"] + ] + , _u_numAlts = 2 + , _u_opts = Normal + } + + +-- Build a pattern like `Ok ` / `Err ` for the given Result union. +resultCtorPattern :: Union -> Data.Name.Name -> Pattern -> Pattern +resultCtorPattern union ctorName argPattern = + case List.find (\(Ctor n _ _ _) -> n == ctorName) (_u_alts union) of + Just (Ctor _ index _ paramTypes) -> + a (PCtor + { _p_home = Module.Canonical (Name "elm" "core") "Result" + , _p_type = "Result" + , _p_union = union + , _p_name = ctorName + , _p_index = index + , _p_args = + imap (\i paramType -> + PatternCtorArg + { _index = Index.ZeroBased i + , _type = paramType + , _arg = argPattern + } + ) paramTypes + }) + Nothing -> + error "Lamdera.Wire3: impossible - elm/core Result union missing Ok/Err constructor" \ No newline at end of file diff --git a/extra/Lamdera/Wire3/Helpers.hs b/extra/Lamdera/Wire3/Helpers.hs index c937649b..2bdd6a8b 100644 --- a/extra/Lamdera/Wire3/Helpers.hs +++ b/extra/Lamdera/Wire3/Helpers.hs @@ -1094,3 +1094,85 @@ identity = ) -- [v] -- ) + + +{- + +WIRE VALIDATION HELPERS + +User code can opt a custom type into post-decode validation by defining a +function `w3_validate_ : -> Result String ()` in +the same module as the type. The generated `w3_decode_` then calls +it; see Lamdera.Wire3.Decoder.wrapWithValidator and Lamdera.Wire3.Core. + +-} + +w3ValidatePrefix :: String +w3ValidatePrefix = "w3_validate_" + + +isValidatorName :: Data.Name.Name -> Bool +isValidatorName name = + List.isPrefixOf w3ValidatePrefix (Data.Name.toChars name) + + +-- "w3_validate_MyType" -> "MyType" +validatorTypeName :: Data.Name.Name -> Data.Name.Name +validatorTypeName name = + Data.Name.fromChars $ drop (length w3ValidatePrefix) (Data.Name.toChars name) + + +-- "MyType" -> "w3_validate_MyType" +validatorNameFor :: Data.Name.Name -> Data.Name.Name +validatorNameFor typeName = + Data.Name.fromChars $ w3ValidatePrefix ++ Data.Name.toChars typeName + + +allValidatorDefs :: Decls -> [Def] +allValidatorDefs decls = + declsToList decls & filter (isValidatorName . defName) + + +findValidatorDef :: Decls -> Data.Name.Name -> Maybe Def +findValidatorDef decls typeName = + findDef (validatorNameFor typeName) decls + + +{- Append `tailDecls` after every definition in `decls`, replacing the terminal +SaveTheEnvironment. Used to place generated wire functions *after* user +definitions when a module contains w3_validate_* functions: the generated +decoders reference those user functions via VarTopLevel, and a VarTopLevel only +resolves to definitions appearing earlier in the topologically-sorted Decls. -} +spliceDeclsAtEnd :: Decls -> Decls -> Decls +spliceDeclsAtEnd decls tailDecls = + case decls of + Declare def rest -> + Declare def (spliceDeclsAtEnd rest tailDecls) + DeclareRec def defs rest -> + DeclareRec def defs (spliceDeclsAtEnd rest tailDecls) + SaveTheEnvironment -> + tailDecls + + +{- Like addLetLog, but logs a dynamic Expr (e.g. an error string bound in a +pattern) rather than a static identifier. Equivalent to writing: + + let _ = Lamdera.Wire3.debug + in +-} +addLetLogValue :: Expr -> Expr -> Expr +addLetLogValue logValue functionBody = + (a (Let + (Def + (a ("_")) + [] + (a (Call + (a (VarForeign mLamdera_Wire "debug" + (Forall + (Map.fromList [("a", ())]) + (TLambda (TType (Module.Canonical (Name "elm" "core") "String") "String" []) (TVar "a"))) + )) + [ logValue ] + ))) + functionBody + )) diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs index d228f048..5537912a 100644 --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -30,6 +30,7 @@ suite = tests $ [ scope "compile all Elm wire expectations" wire , scope "wire codegen has no Debug remnants under --optimize" wireOptimized , scope "function tests" functions + , scope "w3_validate compile errors" wireValidateErrors ] functions :: Test () @@ -121,6 +122,8 @@ wireTestFiles = , "src/Test/Wire_Unsupported.elm" , "src/Test/Wire_Unconstructable.elm" , "src/Test/Wire_Union_ForeignRecordAlias.elm" + , "src/Test/Wire_Validate.elm" + , "src/Test/Wire_Validate_Number.elm" ] @@ -187,3 +190,45 @@ wireOptimized = do remove scaffoldPath scope "scenario-alltypes --optimize no exceptions" $ ok + + +{- Each fixture below defines a `w3_validate_*` function that should be rejected +by the compiler. We compile each one and assert the expected wire-validation +error appears in the output. (These modules are intentionally NOT in +wireTestFiles, since they must fail to compile.) -} +wireValidateErrors :: Test () +wireValidateErrors = do + let project = "./test/scenario-alltypes" + + overrides <- io $ Lamdera.Relative.requireDir "~/lamdera/overrides" + elmHome <- io $ Lamdera.Relative.requireDir "~/elm-home-elmx-test" + + let + compileCapture filename = + catchOutput $ + withEnvVars [("LDEBUG", "1"), ("LTEST", "1"), ("LOVR", overrides), ("ELM_HOME", elmHome)] $ do + -- Bust Elm's caching so the wire generation actually re-runs. + touch $ project filename + Lamdera.Compile.makeDev project [filename] + + tests + [ scope "validator for a type that isn't defined (req 1)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_NoType.elm" + expectTextContains actual "no matching custom type" + + , scope "validator for a type alias (req 5)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_Alias.elm" + expectTextContains actual "found a type alias" + + , scope "validator without a type annotation (req 2)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_NoAnnotation.elm" + expectTextContains actual "missing type annotation" + + , scope "validator with the wrong result type (req 2)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_BadSig.elm" + expectTextContains actual "wrong type signature" + + , scope "validator using a concrete type argument (req 3)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_TvarConcrete.elm" + expectTextContains actual "wrong type signature" + ] diff --git a/test/scenario-alltypes/src/Test/Wire_Validate.elm b/test/scenario-alltypes/src/Test/Wire_Validate.elm new file mode 100644 index 00000000..c11c8e8b --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate.elm @@ -0,0 +1,65 @@ +module Test.Wire_Validate exposing (..) + +{-| Custom types that opt in to post-decode validation via a +`w3_validate_ : -> Result String ()` function defined in +this module. The generated `w3_decode_` should call it: decoding +succeeds iff the validator returns `Ok ()`, otherwise it logs and fails. + +This module must compile, which proves the generated decoders that call the +validators are well-typed (covers requirement 4, plus the valid plain-tvar case +of requirement 3 via `Box a`). The `number`-constrained case lives in +Test.Wire_Validate_Number. +-} + + +type Validated + = ValidatedInt Int + | ValidatedString String + + +w3_validate_Validated : Validated -> Result String () +w3_validate_Validated v = + case v of + ValidatedInt n -> + if n >= 0 then + Ok () + + else + Err "ValidatedInt must be non-negative" + + ValidatedString s -> + if s /= "" then + Ok () + + else + Err "ValidatedString must not be empty" + + +{-| Requirement 3: `type Box a = ...` validated with `Box a -> Result String ()`. +-} +type Box a + = Box a + | EmptyBox + + +w3_validate_Box : Box a -> Result String () +w3_validate_Box _ = + Ok () + + +{-| A type *without* a validator is unaffected: its decoder is generated as +before, with no validation call. +-} +type Unvalidated + = UnvalidatedA + | UnvalidatedB Int + + +{-| Nested usage: `Container`'s generated decoder calls `w3_decode_Validated`, +which itself runs validation. So validation runs wherever the type is decoded, +including as a field of another type. (`Container` has no validator of its own.) +-} +type alias Container = + { item : Validated + , items : List Validated + } diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_Alias.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_Alias.elm new file mode 100644 index 00000000..308401c4 --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_Alias.elm @@ -0,0 +1,14 @@ +module Test.Wire_Validate_Err_Alias exposing (..) + +{-| Requirement 5: a w3_validate_ function exists for a type alias rather than a +custom type. This should be a compile error. +-} + + +type alias Aliased = + Int + + +w3_validate_Aliased : Aliased -> Result String () +w3_validate_Aliased _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_BadSig.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_BadSig.elm new file mode 100644 index 00000000..096dac9d --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_BadSig.elm @@ -0,0 +1,16 @@ +module Test.Wire_Validate_Err_BadSig exposing (..) + +{-| Requirement 2: a w3_validate_ function exists for a real custom type, but its +type signature is not `MyType -> Result String ()` (here it returns Bool). This +should be a compile error. +-} + + +type Badly + = BadlyA + | BadlyB + + +w3_validate_Badly : Badly -> Bool +w3_validate_Badly _ = + True diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoAnnotation.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoAnnotation.elm new file mode 100644 index 00000000..c323ed89 --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoAnnotation.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Err_NoAnnotation exposing (..) + +{-| Requirement 2: a w3_validate_ function exists for a real custom type, but has +no type annotation. We require the annotation so the signature can be verified, +so this should be a compile error. +-} + + +type Annotless + = AnnotlessA + | AnnotlessB + + +w3_validate_Annotless _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoType.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoType.elm new file mode 100644 index 00000000..a4e24afd --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_NoType.elm @@ -0,0 +1,11 @@ +module Test.Wire_Validate_Err_NoType exposing (..) + +{-| Requirement 1: a w3_validate_ function exists but there is no custom type of +that name defined in this module. (No annotation is given, so canonicalization +doesn't fail first on an unknown type reference — the dedicated wire error +should fire instead.) +-} + + +w3_validate_Ghost _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarConcrete.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarConcrete.elm new file mode 100644 index 00000000..4e48351e --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarConcrete.elm @@ -0,0 +1,16 @@ +module Test.Wire_Validate_Err_TvarConcrete exposing (..) + +{-| Requirement 3: `type Holder a = ...` is parameterised by a type variable, so +its validator must be `Holder a -> Result String ()`. Using a concrete type +argument (`Holder Int`) instead should be a compile error. +-} + + +type Holder a + = Holder a + | NoHold + + +w3_validate_Holder : Holder Int -> Result String () +w3_validate_Holder _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Number.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Number.elm new file mode 100644 index 00000000..cd386fae --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Number.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Number exposing (..) + +{-| Requirement 3: `type Numeric number = ...` is parameterised by a constrained +type variable, so its validator must use the same constrained variable: +`Numeric number -> Result String ()`. This module must compile. +-} + + +type Numeric number + = Numeric number + + +w3_validate_Numeric : Numeric number -> Result String () +w3_validate_Numeric _ = + Ok () From e27328866b8d1c1d2a529d7b274fd1c23380600c Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 27 May 2026 23:09:47 +0000 Subject: [PATCH 2/6] Add recursive-type tests for the w3_validate decoder hook Compile-success fixtures verifying the w3_validate hook behaves with recursive custom types (no codegen loops, compiler crashes, or dependency-graph issues): - Wire_Validate_Recursive: a directly self-referential type (Tree). - Wire_Validate_RecursiveRecord: a custom type referencing a record that references it back (Node -> NodeData -> List Node), i.e. mutually recursive generated decoders plus the validator call. - Wire_Validate_RecursiveExtra: recursion through Maybe (Chain), parameterised recursion through List validated with the type variable (Rose a), and mutual recursion between two separately-validated types (Ping/Pong). https://claude.ai/code/session_01URzKFJwLCrv3r2W28bPiW6 --- test/Test/Wire.hs | 3 ++ .../src/Test/Wire_Validate_Recursive.elm | 36 +++++++++++++ .../src/Test/Wire_Validate_RecursiveExtra.elm | 54 +++++++++++++++++++ .../Test/Wire_Validate_RecursiveRecord.elm | 33 ++++++++++++ 4 files changed, 126 insertions(+) create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Recursive.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_RecursiveExtra.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_RecursiveRecord.elm diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs index 5537912a..e7756b55 100644 --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -124,6 +124,9 @@ wireTestFiles = , "src/Test/Wire_Union_ForeignRecordAlias.elm" , "src/Test/Wire_Validate.elm" , "src/Test/Wire_Validate_Number.elm" + , "src/Test/Wire_Validate_Recursive.elm" + , "src/Test/Wire_Validate_RecursiveRecord.elm" + , "src/Test/Wire_Validate_RecursiveExtra.elm" ] diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Recursive.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Recursive.elm new file mode 100644 index 00000000..0582601f --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Recursive.elm @@ -0,0 +1,36 @@ +module Test.Wire_Validate_Recursive exposing (..) + +{-| A custom type that directly references itself, with a validator. + +The generated `w3_decode_Tree` is self-recursive (it decodes sub-Trees by +calling itself) AND it calls `w3_validate_Tree`. This module must compile, which +verifies: + + - codegen terminates (no infinite unfolding of the recursive type) + - the self-recursive decoder is still grouped correctly when wrapped with the + validator call + - the decoder can reference the user `w3_validate_Tree` even though it lives in + a recursive binding group + +Because validation is baked into `w3_decode_Tree`, it runs on every Tree node +decoded (each recursive level), not just the outermost one. +-} + + +type Tree + = Leaf Int + | Branch Tree Tree + + +w3_validate_Tree : Tree -> Result String () +w3_validate_Tree tree = + case tree of + Leaf n -> + if n >= 0 then + Ok () + + else + Err "Leaf value must be non-negative" + + Branch _ _ -> + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveExtra.elm b/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveExtra.elm new file mode 100644 index 00000000..08583621 --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveExtra.elm @@ -0,0 +1,54 @@ +module Test.Wire_Validate_RecursiveExtra exposing (..) + +{-| Additional recursive / awkward configurations, each exercised with a +validator. All must compile with their validators wired in. + + - `Chain`: self-recursion through `Maybe`. + - `Rose a`: parameterised self-recursion through `List`, validated with a + signature that uses the type variable (`Rose a -> Result String ()`). This + checks that the recursive call (which threads the type-variable codec) and + the validator call coexist. + - `Ping` / `Pong`: two mutually-recursive custom types, each with its own + validator. Both generated decoders end up in one recursive binding group and + each must resolve its respective validator. +-} + + +type Chain + = Chain Int (Maybe Chain) + + +w3_validate_Chain : Chain -> Result String () +w3_validate_Chain (Chain n _) = + if n >= 0 then + Ok () + + else + Err "Chain value must be non-negative" + + +type Rose a + = Rose a (List (Rose a)) + + +w3_validate_Rose : Rose a -> Result String () +w3_validate_Rose _ = + Ok () + + +type Ping + = Ping (Maybe Pong) + + +type Pong + = Pong (Maybe Ping) + + +w3_validate_Ping : Ping -> Result String () +w3_validate_Ping _ = + Ok () + + +w3_validate_Pong : Pong -> Result String () +w3_validate_Pong _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveRecord.elm b/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveRecord.elm new file mode 100644 index 00000000..7090c32e --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_RecursiveRecord.elm @@ -0,0 +1,33 @@ +module Test.Wire_Validate_RecursiveRecord exposing (..) + +{-| A custom type that references a record type which in turn references the +custom type: `Node` -> `NodeData` -> `List Node`. + +The generated decoders are mutually recursive (`w3_decode_Node` and +`w3_decode_NodeData` reference each other), and `w3_decode_Node` additionally +calls `w3_validate_Node`. This module must compile, verifying the mutually +recursive binding group is formed correctly while still resolving the reference +to the user `w3_validate_Node`. + +`NodeData` is a plain record alias with no validator of its own, so its decoder +is generated unchanged. +-} + + +type Node + = Node NodeData + + +type alias NodeData = + { value : Int + , children : List Node + } + + +w3_validate_Node : Node -> Result String () +w3_validate_Node (Node data) = + if data.value >= 0 then + Ok () + + else + Err "Node value must be non-negative" From 57ef9ae7e16443cb16846cbfdda1802c3ff98aeb Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 27 May 2026 23:28:54 +0000 Subject: [PATCH 3/6] Add runtime test for w3_validate decode rejection The existing w3_validate tests are all compile-time: they check the generated decoder type-checks and that bad validator definitions are rejected by the compiler. None execute a decoder, so neither the Ok-accept nor the Err-reject path was tested at runtime. This adds an elm-test (run via the project's --compiler=lamdera harness, e.g. `cd test/scenario-alltypes && npx elm-test --compiler=lamdera tests/Wire3ValidateTest.elm`) that encodes Validated values and decodes them back, asserting: - values that pass w3_validate_Validated decode to `Just value` - values that fail it are rejected and decode to `Nothing` Encoding does not run validation, so a validation-failing value can be encoded and then shown to fail on decode. The wire functions are imported from Test.Wire_Validate (cross-module) on purpose. https://claude.ai/code/session_01URzKFJwLCrv3r2W28bPiW6 --- .../tests/Wire3ValidateTest.elm | 66 +++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 test/scenario-alltypes/tests/Wire3ValidateTest.elm diff --git a/test/scenario-alltypes/tests/Wire3ValidateTest.elm b/test/scenario-alltypes/tests/Wire3ValidateTest.elm new file mode 100644 index 00000000..312ff007 --- /dev/null +++ b/test/scenario-alltypes/tests/Wire3ValidateTest.elm @@ -0,0 +1,66 @@ +module Wire3ValidateTest exposing (suite) + +{-| Runtime tests for the w3_validate decoder hook: decoding must SUCCEED when +`w3_validate_*` returns `Ok ()` and must be REJECTED (decode to `Nothing`) when +it returns `Err`. + +Note that encoding never validates — only decoding does — so we can encode a +value that fails validation and confirm that decoding it back fails. + +This imports the type and its compiler-generated wire functions from +Test.Wire_Validate. The reference is intentionally cross-module: a module that +both defines a validator and uses that type's generated wire functions in its +own top-level code would hit the codec ordering rules, so the round-trip helper +lives here instead. + +Run with the Lamdera compiler (the wire functions are compiler-generated): + + cd test/scenario-alltypes && npx elm-test --compiler=lamdera tests/Wire3ValidateTest.elm + +-} + +import Bytes.Decode +import Bytes.Encode +import Expect +import Test exposing (Test, describe, test) +import Test.Wire_Validate exposing (Validated(..), w3_decode_Validated, w3_encode_Validated) + + +{-| Encode then decode. A successful decode is `Just value`; a decode that fails +(including a validation failure) is `Nothing`. +-} +roundtrip : Validated -> Maybe Validated +roundtrip value = + Bytes.Decode.decode + w3_decode_Validated + (Bytes.Encode.encode (w3_encode_Validated value)) + + +suite : Test +suite = + describe "w3_validate gates decoding" + [ describe "values that pass validation decode successfully (Ok ())" + [ test "ValidatedInt with a non-negative value" <| + \_ -> + roundtrip (ValidatedInt 5) + |> Expect.equal (Just (ValidatedInt 5)) + , test "ValidatedInt 0 (boundary)" <| + \_ -> + roundtrip (ValidatedInt 0) + |> Expect.equal (Just (ValidatedInt 0)) + , test "ValidatedString with a non-empty value" <| + \_ -> + roundtrip (ValidatedString "hello") + |> Expect.equal (Just (ValidatedString "hello")) + ] + , describe "values that fail validation are rejected (Err -> Nothing)" + [ test "ValidatedInt with a negative value is rejected" <| + \_ -> + roundtrip (ValidatedInt (-1)) + |> Expect.equal Nothing + , test "ValidatedString with an empty value is rejected" <| + \_ -> + roundtrip (ValidatedString "") + |> Expect.equal Nothing + ] + ] From a74c49577be4e1f935465d54aabbacd552c3f15d Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 28 May 2026 09:54:52 +0000 Subject: [PATCH 4/6] Expand w3_validate test coverage Compile-error fixtures filling in gaps in the existing wireValidateErrors suite: - WrongOkType: Result with Int as the Ok payload (not unit). - TvarRename: type Holder a validated as Holder b -- strict tvar-name match rejects alpha-renamed variables. - TvarSwap: type Pair a b validated as Pair b a -- multi-tvar order matters. - ArgCount: validator declared as a value (no argument). Compile-success fixtures (added to wireTestFiles): - MultiTvar: type Pair a b with a validator using both type variables. - Phantom: type Phantom a (variable declared but unused in constructors). Runtime tests (extending tests/Wire3ValidateTest.elm) covering behaviour the compile tests can't observe: - Recursive Tree: validation runs at every node, so a deeply-nested invalid Leaf causes the whole decode to fail. - Container (a record containing Validated values): validation runs through aggregate fields, both for the direct field and for list entries. https://claude.ai/code/session_01URzKFJwLCrv3r2W28bPiW6 --- test/Test/Wire.hs | 18 +++ .../src/Test/Wire_Validate_Err_ArgCount.elm | 15 ++ .../src/Test/Wire_Validate_Err_TvarRename.elm | 16 +++ .../src/Test/Wire_Validate_Err_TvarSwap.elm | 15 ++ .../Test/Wire_Validate_Err_WrongOkType.elm | 15 ++ .../src/Test/Wire_Validate_MultiTvar.elm | 14 ++ .../src/Test/Wire_Validate_Phantom.elm | 15 ++ .../tests/Wire3ValidateTest.elm | 133 ++++++++++++++---- 8 files changed, 211 insertions(+), 30 deletions(-) create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_ArgCount.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarRename.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarSwap.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_WrongOkType.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_MultiTvar.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Phantom.elm diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs index e7756b55..b5d3b50d 100644 --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -124,6 +124,8 @@ wireTestFiles = , "src/Test/Wire_Union_ForeignRecordAlias.elm" , "src/Test/Wire_Validate.elm" , "src/Test/Wire_Validate_Number.elm" + , "src/Test/Wire_Validate_MultiTvar.elm" + , "src/Test/Wire_Validate_Phantom.elm" , "src/Test/Wire_Validate_Recursive.elm" , "src/Test/Wire_Validate_RecursiveRecord.elm" , "src/Test/Wire_Validate_RecursiveExtra.elm" @@ -234,4 +236,20 @@ wireValidateErrors = do , scope "validator using a concrete type argument (req 3)" $ do actual <- compileCapture "src/Test/Wire_Validate_Err_TvarConcrete.elm" expectTextContains actual "wrong type signature" + + , scope "validator with wrong Result Ok type" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_WrongOkType.elm" + expectTextContains actual "wrong type signature" + + , scope "validator with a renamed (non-matching) type variable" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_TvarRename.elm" + expectTextContains actual "wrong type signature" + + , scope "validator with swapped multi-tvar order" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_TvarSwap.elm" + expectTextContains actual "wrong type signature" + + , scope "validator declared as a value (wrong arg count)" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_ArgCount.elm" + expectTextContains actual "wrong type signature" ] diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_ArgCount.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_ArgCount.elm new file mode 100644 index 00000000..fcecbe7f --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_ArgCount.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Err_ArgCount exposing (..) + +{-| Requirement 2 variant: a validator declared as a value rather than a +one-argument function. The signature does not include the type as an argument +at all, so it should be a compile error. +-} + + +type Z + = Z + + +w3_validate_Z : Result String () +w3_validate_Z = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarRename.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarRename.elm new file mode 100644 index 00000000..5699e12a --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarRename.elm @@ -0,0 +1,16 @@ +module Test.Wire_Validate_Err_TvarRename exposing (..) + +{-| Requirement 3 variant: `type Holder a = ...` is parameterised by `a`, so the +validator must say `Holder a`. Using a different (alpha-renamed) variable like +`Holder b` should be a compile error under strict tvar-name matching. +-} + + +type Holder a + = Holder a + | NoHold + + +w3_validate_Holder : Holder b -> Result String () +w3_validate_Holder _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarSwap.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarSwap.elm new file mode 100644 index 00000000..c9955e0d --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_TvarSwap.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Err_TvarSwap exposing (..) + +{-| Requirement 3 variant: `type Pair a b = ...` has type variables `a` and `b` +in that order. The validator must use them in the same order. Swapping them +(`Pair b a`) should be a compile error. +-} + + +type Pair a b + = Pair a b + + +w3_validate_Pair : Pair b a -> Result String () +w3_validate_Pair _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_WrongOkType.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WrongOkType.elm new file mode 100644 index 00000000..50e5000d --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WrongOkType.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Err_WrongOkType exposing (..) + +{-| Requirement 2 variant: the validator returns a `Result` but with the wrong +"Ok" payload type (`Int` instead of `()`). Should be a compile error. +-} + + +type Pickle + = PickleA + | PickleB + + +w3_validate_Pickle : Pickle -> Result String Int +w3_validate_Pickle _ = + Ok 0 diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_MultiTvar.elm b/test/scenario-alltypes/src/Test/Wire_Validate_MultiTvar.elm new file mode 100644 index 00000000..72a2d90a --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_MultiTvar.elm @@ -0,0 +1,14 @@ +module Test.Wire_Validate_MultiTvar exposing (..) + +{-| Multi-parameter custom type with a validator using its type variables in the +same order they were declared (`Pair a b -> Result String ()`). Must compile. +-} + + +type Pair a b + = Pair a b + + +w3_validate_Pair : Pair a b -> Result String () +w3_validate_Pair _ = + Ok () diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Phantom.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Phantom.elm new file mode 100644 index 00000000..ecb4db44 --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Phantom.elm @@ -0,0 +1,15 @@ +module Test.Wire_Validate_Phantom exposing (..) + +{-| A phantom-type variable: `Phantom` declares `a` but no constructor uses it. +The validator signature still has to use `a` to match the type's declared +variables (`Phantom a -> Result String ()`). Must compile. +-} + + +type Phantom a + = Phantom + + +w3_validate_Phantom : Phantom a -> Result String () +w3_validate_Phantom _ = + Ok () diff --git a/test/scenario-alltypes/tests/Wire3ValidateTest.elm b/test/scenario-alltypes/tests/Wire3ValidateTest.elm index 312ff007..597b2e05 100644 --- a/test/scenario-alltypes/tests/Wire3ValidateTest.elm +++ b/test/scenario-alltypes/tests/Wire3ValidateTest.elm @@ -2,16 +2,13 @@ module Wire3ValidateTest exposing (suite) {-| Runtime tests for the w3_validate decoder hook: decoding must SUCCEED when `w3_validate_*` returns `Ok ()` and must be REJECTED (decode to `Nothing`) when -it returns `Err`. +it returns `Err`. Encoding never validates -- only decoding does -- so we can +encode a value that fails validation and confirm that decoding it back fails. -Note that encoding never validates — only decoding does — so we can encode a -value that fails validation and confirm that decoding it back fails. - -This imports the type and its compiler-generated wire functions from -Test.Wire_Validate. The reference is intentionally cross-module: a module that -both defines a validator and uses that type's generated wire functions in its -own top-level code would hit the codec ordering rules, so the round-trip helper -lives here instead. +Wire functions are imported from the fixture modules (cross-module): a module +that both defines a validator and uses that type's generated wire functions in +its own top-level code would hit the codec ordering rules, so the round-trip +helpers live here instead. Run with the Lamdera compiler (the wire functions are compiler-generated): @@ -23,44 +20,120 @@ import Bytes.Decode import Bytes.Encode import Expect import Test exposing (Test, describe, test) -import Test.Wire_Validate exposing (Validated(..), w3_decode_Validated, w3_encode_Validated) +import Test.Wire_Validate + exposing + ( Container + , Validated(..) + , w3_decode_Container + , w3_decode_Validated + , w3_encode_Container + , w3_encode_Validated + ) +import Test.Wire_Validate_Recursive + exposing + ( Tree(..) + , w3_decode_Tree + , w3_encode_Tree + ) -{-| Encode then decode. A successful decode is `Just value`; a decode that fails -(including a validation failure) is `Nothing`. --} -roundtrip : Validated -> Maybe Validated -roundtrip value = +roundtripValidated : Validated -> Maybe Validated +roundtripValidated value = Bytes.Decode.decode w3_decode_Validated (Bytes.Encode.encode (w3_encode_Validated value)) +roundtripTree : Tree -> Maybe Tree +roundtripTree value = + Bytes.Decode.decode + w3_decode_Tree + (Bytes.Encode.encode (w3_encode_Tree value)) + + +roundtripContainer : Container -> Maybe Container +roundtripContainer value = + Bytes.Decode.decode + w3_decode_Container + (Bytes.Encode.encode (w3_encode_Container value)) + + suite : Test suite = describe "w3_validate gates decoding" - [ describe "values that pass validation decode successfully (Ok ())" - [ test "ValidatedInt with a non-negative value" <| + [ describe "shallow custom type (Validated)" + [ describe "passes validation -> Just" + [ test "ValidatedInt with a non-negative value" <| + \_ -> + roundtripValidated (ValidatedInt 5) + |> Expect.equal (Just (ValidatedInt 5)) + , test "ValidatedInt 0 (boundary)" <| + \_ -> + roundtripValidated (ValidatedInt 0) + |> Expect.equal (Just (ValidatedInt 0)) + , test "ValidatedString with a non-empty value" <| + \_ -> + roundtripValidated (ValidatedString "hello") + |> Expect.equal (Just (ValidatedString "hello")) + ] + , describe "fails validation -> Nothing" + [ test "ValidatedInt with a negative value is rejected" <| + \_ -> + roundtripValidated (ValidatedInt (-1)) + |> Expect.equal Nothing + , test "ValidatedString with an empty value is rejected" <| + \_ -> + roundtripValidated (ValidatedString "") + |> Expect.equal Nothing + ] + ] + , describe "recursive type (Tree) -- validation runs at every node" + [ test "an all-valid tree roundtrips successfully" <| \_ -> - roundtrip (ValidatedInt 5) - |> Expect.equal (Just (ValidatedInt 5)) - , test "ValidatedInt 0 (boundary)" <| + let + tree = + Branch (Leaf 1) (Branch (Leaf 2) (Leaf 3)) + in + roundtripTree tree + |> Expect.equal (Just tree) + , test "a tree with a deeply-nested negative leaf is rejected" <| \_ -> - roundtrip (ValidatedInt 0) - |> Expect.equal (Just (ValidatedInt 0)) - , test "ValidatedString with a non-empty value" <| + -- The outer Branch passes validation, but decoding the + -- inner Trees recurses through w3_decode_Tree (which runs + -- the validator), so the (Leaf (-3)) at the bottom fails and + -- the whole decode returns Nothing. + roundtripTree (Branch (Leaf 1) (Branch (Leaf 2) (Leaf (-3)))) + |> Expect.equal Nothing + , test "a shallow tree with a bad immediate leaf is rejected" <| \_ -> - roundtrip (ValidatedString "hello") - |> Expect.equal (Just (ValidatedString "hello")) + roundtripTree (Branch (Leaf (-1)) (Leaf 3)) + |> Expect.equal Nothing ] - , describe "values that fail validation are rejected (Err -> Nothing)" - [ test "ValidatedInt with a negative value is rejected" <| + , describe "validation runs through aggregate fields (Container)" + [ test "a valid container roundtrips successfully" <| + \_ -> + let + c : Container + c = + { item = ValidatedInt 5 + , items = [ ValidatedInt 1, ValidatedString "ok" ] + } + in + roundtripContainer c + |> Expect.equal (Just c) + , test "a container with an invalid `item` field is rejected" <| \_ -> - roundtrip (ValidatedInt (-1)) + roundtripContainer + { item = ValidatedInt (-1) + , items = [] + } |> Expect.equal Nothing - , test "ValidatedString with an empty value is rejected" <| + , test "a container with an invalid entry in `items` is rejected" <| \_ -> - roundtrip (ValidatedString "") + roundtripContainer + { item = ValidatedInt 5 + , items = [ ValidatedInt 1, ValidatedString "" ] + } |> Expect.equal Nothing ] ] From 4dc2e55dc46916b54e60faee41268c49a41c508d Mon Sep 17 00:00:00 2001 From: Claude Date: Tue, 2 Jun 2026 16:08:27 +0000 Subject: [PATCH 5/6] Detect validator + generated-wire-fn references with a clear compile error When a module defines a w3_validate_* function, the generated wire functions are appended after the user's code so the generated decoders can call the validators. That meant any user top-level code in the same module that also referenced a generated w3_encode_*/w3_decode_* function produced a forward reference, which crashed the type solver with an internal Map.! error. Detect that case in addWireGenerations_ (only on the validator path) and emit a normal compile error naming the offending definition and wire function. Adds a total VarTopLevel collector (topLevelRefsInExpr) that handles every Expr_ constructor, since getLvars is specialised to generated code and errors on shapes like multi-branch if. Tests: two fixtures (encoder and decoder reference) asserting the new error. --- extra/Lamdera/Wire3/Core.hs | 74 ++++++++++++++++++- extra/Lamdera/Wire3/Helpers.hs | 54 ++++++++++++++ test/Test/Wire.hs | 8 ++ .../src/Test/Wire_Validate_Err_WireRef.elm | 27 +++++++ .../Test/Wire_Validate_Err_WireRefDecode.elm | 23 ++++++ 5 files changed, 182 insertions(+), 4 deletions(-) create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRef.elm create mode 100644 test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRefDecode.elm diff --git a/extra/Lamdera/Wire3/Core.hs b/extra/Lamdera/Wire3/Core.hs index 7e50d015..39d423a0 100644 --- a/extra/Lamdera/Wire3/Core.hs +++ b/extra/Lamdera/Wire3/Core.hs @@ -246,16 +246,33 @@ addWireGenerations_ canonical pkg ifaces modul = ) exports & Export + + {- When generated wire functions are appended after user code (the + moduleHasValidators path), the user's own top-level code must not also + reference a generated w3_encode_*/w3_decode_* function in this module: the + reference would resolve to a definition that now appears later, which the + type checker can't see (it would otherwise crash with an internal Map.!). + Detect that and report a clear error. When there are no validators we keep + the original prepend behaviour, where such references are fine. -} + wireRefCheck = + if moduleHasValidators + then checkNoUserWireRefs newDefs existingDecls + else Right () in case checkValidators cname (Can._unions canonical) (Can._aliases canonical) decls_ of Left err -> Left err Right () -> - Right $ canonical - { _decls = extendedDecls - , _exports = extendedExports - } + case wireRefCheck of + Left err -> + Left err + + Right () -> + Right $ canonical + { _decls = extendedDecls + , _exports = extendedExports + } {- @@ -376,6 +393,55 @@ validatorBadSignatureError typeName union = ] +{- + +When a module defines any w3_validate_* function, the generated wire functions +are emitted *after* the user's definitions (so the generated decoders can call +the validators). That ordering means the user's own top-level code cannot also +reference a generated w3_encode_*/w3_decode_* function in the same module -- such +a reference would point at a definition that now appears later in the Decls, +which the type-inference solver can't resolve (it would crash with an internal +Map.! lookup error). We catch that here and report it as a normal compile error. + +`generatedDefs` are the freshly generated wire defs (their names are what we +forbid referencing); `userDecls` is the user's code with the wire stubs removed. + +-} +checkNoUserWireRefs :: [Def] -> Decls -> Either D.Doc () +checkNoUserWireRefs generatedDefs userDecls = + let + generatedNames = fmap defName generatedDefs + + conflicts = + [ (defName userDef, ref) + | userDef <- declsToList userDecls + , ref <- defTopLevelRefs userDef + , ref `elem` generatedNames + ] + in + case conflicts of + [] -> + Right () + + ((userName, genName) : _) -> + Left (validatorWireRefError userName genName) + + +validatorWireRefError :: Data.Name.Name -> Data.Name.Name -> D.Doc +validatorWireRefError userName genName = + D.stack + [ D.fromChars $ Data.Name.toChars userName ++ ": cannot reference generated wire functions in a module that defines a validator" + , D.reflow $ + "`" ++ Data.Name.toChars userName ++ "` references the generated wire function `" + ++ Data.Name.toChars genName ++ "`, but this module also defines one or more `w3_validate_*` functions." + , D.reflow + "When a module defines a wire validator, the generated wire functions (w3_encode_*/w3_decode_*) must be placed after your own definitions so the generated decoders can call your validators. As a result, your top-level code in this module can't also reference those generated functions." + , D.reflow $ + "To fix this, move `" ++ Data.Name.toChars userName ++ "` (or just its reference to `" + ++ Data.Name.toChars genName ++ "`) into a different module, or remove the validator(s) from this module." + ] + + addExport :: Def -> Map.Map Data.Name.Name (A.Located Export) -> Map.Map Data.Name.Name (A.Located Export) addExport def exports = case def of diff --git a/extra/Lamdera/Wire3/Helpers.hs b/extra/Lamdera/Wire3/Helpers.hs index 2bdd6a8b..6cfc12f0 100644 --- a/extra/Lamdera/Wire3/Helpers.hs +++ b/extra/Lamdera/Wire3/Helpers.hs @@ -1176,3 +1176,57 @@ addLetLogValue logValue functionBody = ))) functionBody )) + + +{- A total collector of every VarTopLevel reference in an expression, recursing +through let/case/record/etc. + +Unlike getLvars in Lamdera.Wire3.Graph -- which is specialised to generated wire +expressions and intentionally `error`s on shapes that generated code never emits +(e.g. a multi-branch `if`) and ignores `case` scrutinees -- this handles every +Expr_ constructor, so it is safe to run over arbitrary user code. -} +topLevelRefsInExpr :: Expr -> [Data.Name.Name] +topLevelRefsInExpr (A.At _ expr) = + case expr of + VarLocal _ -> [] + VarTopLevel _ name -> [name] + VarKernel _ _ -> [] + VarForeign _ _ _ -> [] + VarCtor _ _ _ _ _ -> [] + VarDebug _ _ _ -> [] + VarOperator _ _ _ _ -> [] + Chr _ -> [] + Str _ -> [] + Int _ -> [] + Float _ -> [] + List es -> concatMap topLevelRefsInExpr es + Negate e -> topLevelRefsInExpr e + Binop _ _ _ _ e1 e2 -> topLevelRefsInExpr e1 ++ topLevelRefsInExpr e2 + Lambda _ e -> topLevelRefsInExpr e + Call e es -> topLevelRefsInExpr e ++ concatMap topLevelRefsInExpr es + If branches finalElse -> + concatMap (\(c, t) -> topLevelRefsInExpr c ++ topLevelRefsInExpr t) branches + ++ topLevelRefsInExpr finalElse + Let def e -> defTopLevelRefs def ++ topLevelRefsInExpr e + LetRec defs e -> concatMap defTopLevelRefs defs ++ topLevelRefsInExpr e + LetDestruct _ e1 e2 -> topLevelRefsInExpr e1 ++ topLevelRefsInExpr e2 + Case scrutinee branches -> + topLevelRefsInExpr scrutinee + ++ concatMap (\(CaseBranch _ e) -> topLevelRefsInExpr e) branches + Accessor _ -> [] + Access e _ -> topLevelRefsInExpr e + Update _ e fieldUpdates -> + topLevelRefsInExpr e + ++ concatMap (\(FieldUpdate _ ue) -> topLevelRefsInExpr ue) (Map.elems fieldUpdates) + Record fields -> concatMap topLevelRefsInExpr (Map.elems fields) + Unit -> [] + Tuple e1 e2 me3 -> + topLevelRefsInExpr e1 ++ topLevelRefsInExpr e2 ++ maybe [] topLevelRefsInExpr me3 + Shader _ _ -> [] + + +defTopLevelRefs :: Def -> [Data.Name.Name] +defTopLevelRefs def = + case def of + Def _ _ e -> topLevelRefsInExpr e + TypedDef _ _ _ e _ -> topLevelRefsInExpr e diff --git a/test/Test/Wire.hs b/test/Test/Wire.hs index b5d3b50d..36c191f4 100644 --- a/test/Test/Wire.hs +++ b/test/Test/Wire.hs @@ -252,4 +252,12 @@ wireValidateErrors = do , scope "validator declared as a value (wrong arg count)" $ do actual <- compileCapture "src/Test/Wire_Validate_Err_ArgCount.elm" expectTextContains actual "wrong type signature" + + , scope "validator module referencing a generated encoder in user code" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_WireRef.elm" + expectTextContains actual "cannot reference generated wire functions" + + , scope "validator module referencing a generated decoder in user code" $ do + actual <- compileCapture "src/Test/Wire_Validate_Err_WireRefDecode.elm" + expectTextContains actual "cannot reference generated wire functions" ] diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRef.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRef.elm new file mode 100644 index 00000000..4c215a0b --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRef.elm @@ -0,0 +1,27 @@ +module Test.Wire_Validate_Err_WireRef exposing (..) + +{-| A module that defines a validator AND references a generated wire function +(here the encoder) in its own top-level code. + +Because a validator forces the generated wire functions to be placed *after* the +user's code, this top-level reference would previously crash the compiler with +an internal `Map.!` error during type inference. It should now produce a clear +compile error. +-} + + +type MyType + = MyType Int + + +w3_validate_MyType : MyType -> Result String () +w3_validate_MyType (MyType n) = + if n >= 0 then + Ok () + + else + Err "must be non-negative" + + +encodedDefault = + w3_encode_MyType (MyType 0) diff --git a/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRefDecode.elm b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRefDecode.elm new file mode 100644 index 00000000..8bcedb44 --- /dev/null +++ b/test/scenario-alltypes/src/Test/Wire_Validate_Err_WireRefDecode.elm @@ -0,0 +1,23 @@ +module Test.Wire_Validate_Err_WireRefDecode exposing (..) + +{-| Same situation as Wire_Validate_Err_WireRef, but referencing the generated +*decoder* rather than the encoder, to confirm the check is symmetric across both +w3_encode_* and w3_decode_*. Should produce a clear compile error. +-} + + +type MyType + = MyType Int + + +w3_validate_MyType : MyType -> Result String () +w3_validate_MyType (MyType n) = + if n >= 0 then + Ok () + + else + Err "must be non-negative" + + +defaultDecoder = + w3_decode_MyType From f9487f00cfebeb06176306ec52543656ae9e6234 Mon Sep 17 00:00:00 2001 From: Claude Date: Thu, 4 Jun 2026 23:30:38 +0000 Subject: [PATCH 6/6] Add non-validating w3_unsafe_decode_ alongside validating w3_decode_ Validation should only run on attacker-controlled, backend-inbound data, not on trusted data (persistence, evergreen migrations). So every custom type and alias now gets two decoders: * w3_decode_ validating: applies w3_validate_ if present and recurses through the w3_decode_* chain (for the Lamdera runtime to use on backend-inbound data). * w3_unsafe_decode_ non-validating: behaves like w3_decode_ did before validation existed, recursing through the w3_unsafe_decode_* chain. The two chains are threaded through decoder codegen via a DecodeMode parameter. The validating chain is byte-identical to the previous w3_decode output (only the prefix and, for unions, the validator hook differ), so existing behaviour is unchanged. Built-in decoders (decodeList etc.) are mode-agnostic and thread the mode through their element decoder. The trusted in-repo consumers are repointed at the unsafe chain to preserve their pre-validation behaviour: the evergreen migration harness and backend-model persistence reload. Also adds w3_unsafe_decode_* stubs + exports and extends the getForeignSig fallback to the new prefix. The validator-module reference check already covers w3_unsafe_decode_* (names are derived from the generated defs). Tests: Wire3ValidateTest now contrasts unsafe-decode-accepts-invalid vs validating-decode-rejects; the full Test.Wire suite passes with all fixtures compiling under both chains. --- extra/Lamdera/CLI/Backend.hs | 2 +- extra/Lamdera/Evergreen/MigrationHarness.hs | 22 +++---- extra/Lamdera/Wire3/Core.hs | 40 +++++++----- extra/Lamdera/Wire3/Decoder.hs | 58 ++++++++--------- extra/Lamdera/Wire3/Helpers.hs | 27 ++++++++ extra/Lamdera/Wire3/Interfaces.hs | 2 + .../tests/Wire3ValidateTest.elm | 62 +++++++++++++++++++ 7 files changed, 156 insertions(+), 57 deletions(-) diff --git a/extra/Lamdera/CLI/Backend.hs b/extra/Lamdera/CLI/Backend.hs index cd8b2b68..42e597b0 100644 --- a/extra/Lamdera/CLI/Backend.hs +++ b/extra/Lamdera/CLI/Backend.hs @@ -910,7 +910,7 @@ addBackendModelDecl base64 = \ >> nextChunk []\n\ \ )\n\ \ |>Lamdera.Wire3.intListToBytes\n\ - \ |>Lamdera.Wire3.bytesDecode Types.w3_decode_BackendModel\n\ + \ |>Lamdera.Wire3.bytesDecode Types.w3_unsafe_decode_BackendModel\n\ \ |>(\\maybeModel ->\n\ \ case maybeModel of\n\ \ Just m -> m\n\ diff --git a/extra/Lamdera/Evergreen/MigrationHarness.hs b/extra/Lamdera/Evergreen/MigrationHarness.hs index a71184ef..ab0fad1b 100644 --- a/extra/Lamdera/Evergreen/MigrationHarness.hs +++ b/extra/Lamdera/Evergreen/MigrationHarness.hs @@ -133,14 +133,14 @@ decodeAndUpgradeFor migrationSequence nextVersion valueType = do if valueType == "BackendModel" then [text| $nextVersion_ -> - decodeType $valueTypeInt version bytes T$nextVersion_.w3_decode_$valueType + decodeType $valueTypeInt version bytes T$nextVersion_.w3_unsafe_decode_$valueType |> upgradeIsCurrent |> otherwiseError |] else [text| $nextVersion_ -> - decodeType $valueTypeInt version bytes T$nextVersion_.w3_decode_$valueType + decodeType $valueTypeInt version bytes T$nextVersion_.w3_unsafe_decode_$valueType |> upgradeIsCurrent |> otherwiseError |] @@ -308,13 +308,13 @@ migrationForType migrationSequence migrationsForVersion startVersion finalVersio if tipe == "BackendModel" then [text| - decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w3_decode_$tipe + decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w3_unsafe_decode_$tipe |> upgradeSucceeds |> otherwiseError |] else [text| - decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w3_decode_$tipe + decodeType $valueTypeInt $finalVersion_ bytes T$finalVersion_.w3_unsafe_decode_$tipe |> upgradeSucceeds |> otherwiseError |] @@ -323,14 +323,14 @@ migrationForType migrationSequence migrationsForVersion startVersion finalVersio if tipe == "BackendModel" then [text| - decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w3_decode_$tipe + decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w3_unsafe_decode_$tipe $intermediateMigrationsFormatted |> upgradeSucceeds |> otherwiseError |] else [text| - decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w3_decode_$tipe + decodeType $valueTypeInt $startVersion_ bytes T$startVersion_.w3_unsafe_decode_$tipe $intermediateMigrationsFormatted |> upgradeSucceeds |> otherwiseError @@ -397,16 +397,16 @@ intermediateMigration allMigrations tipe from to finalVersion = migrationFn = [text|M$to_.$typenameCamel|] in [text| - |> $thenMigrateForType $valueTypeInt $migrationFn T$from_.w3_encode_$tipe T$to_.w3_decode_$tipe $to_ + |> $thenMigrateForType $valueTypeInt $migrationFn T$from_.w3_encode_$tipe T$to_.w3_unsafe_decode_$tipe $to_ |] WithoutMigrations v -> {- It might seem like this is uneeded, but it's for when there's a migration in our chain, yet the last version has no migrations. I.e.: - decodeType "BackendModel" 1 intList T1.w3_decode_BackendModel - |> thenMigrateModel "BackendModel" M2.backendModel T1.w3_encode_BackendModel T2.w3_decode_BackendModel 2 - |> thenMigrateModel "BackendModel" (always ModelUnchanged) T2.w3_encode_BackendModel T3.w3_decode_BackendModel 3 + decodeType "BackendModel" 1 intList T1.w3_unsafe_decode_BackendModel + |> thenMigrateModel "BackendModel" M2.backendModel T1.w3_encode_BackendModel T2.w3_unsafe_decode_BackendModel 2 + |> thenMigrateModel "BackendModel" (always ModelUnchanged) T2.w3_encode_BackendModel T3.w3_unsafe_decode_BackendModel 3 |> upgradeSucceeds CurrentBackendModel |> otherwiseError @@ -416,7 +416,7 @@ intermediateMigration allMigrations tipe from to finalVersion = migrationFn = "(always " <> kindForType <> "Unchanged)" in [text| - |> $thenMigrateForType $valueTypeInt $migrationFn T$from_.w3_encode_$tipe T$to_.w3_decode_$tipe $to_ + |> $thenMigrateForType $valueTypeInt $migrationFn T$from_.w3_encode_$tipe T$to_.w3_unsafe_decode_$tipe $to_ |] diff --git a/extra/Lamdera/Wire3/Core.hs b/extra/Lamdera/Wire3/Core.hs index 39d423a0..2755eb92 100644 --- a/extra/Lamdera/Wire3/Core.hs +++ b/extra/Lamdera/Wire3/Core.hs @@ -180,7 +180,8 @@ addWireGenerations_ canonical pkg ifaces modul = & Map.toList & concatMap (\(name, union) -> [ (encoderUnion isTest_ ifaces pkg modul decls_ name union) - , (decoderUnion isTest_ ifaces pkg modul decls_ name union) + , (decoderUnion DecodeValidating isTest_ ifaces pkg modul decls_ name union) + , (decoderUnion DecodeUnsafe isTest_ ifaces pkg modul decls_ name union) ] ) @@ -190,7 +191,8 @@ addWireGenerations_ canonical pkg ifaces modul = & filter (\(_, Alias _ tipe) -> not (isLambdaType tipe)) & concatMap (\(name, alias) -> [ (encoderAlias isTest_ ifaces pkg modul decls_ name alias) - , (decoderAlias isTest_ ifaces pkg modul decls_ name alias) + , (decoderAlias DecodeValidating isTest_ ifaces pkg modul decls_ name alias) + , (decoderAlias DecodeUnsafe isTest_ ifaces pkg modul decls_ name alias) ] ) @@ -539,12 +541,12 @@ encoderUnion isTest_ ifaces pkg modul decls unionName union = finalGen -decoderUnion :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Union -> Def -decoderUnion isTest_ ifaces pkg modul decls unionName union = +decoderUnion :: DecodeMode -> Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Union -> Def +decoderUnion mode isTest_ ifaces pkg modul decls unionName union = let !x = runTests isTest_ "decoderUnion" pkg modul decls generatedName generated union (unionAsModule cname unionName union) - generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars unionName + generatedName = Data.Name.fromChars $ decodePrefix mode ++ Data.Name.toChars unionName cname = Module.Canonical pkg (Src.getName modul) tvars = _u_vars union tvarsTypesig = tvars & foldl (\acc name -> Map.insert name () acc ) Map.empty @@ -577,20 +579,26 @@ decoderUnion isTest_ ifaces pkg modul decls unionName union = & imap (\i (Ctor tagName tagIndex numParams paramTypes) -> CaseBranch (pint i) $ ([(succeedDecode (vctor tagName tagIndex paramTypes))] - ++ fmap (\paramType -> andMapDecode1 ((decoderForType ifaces cname paramType))) paramTypes) + ++ fmap (\paramType -> andMapDecode1 ((decoderForType mode ifaces cname paramType))) paramTypes) & foldlPairs (|>) ) & (\l -> l ++ [CaseBranch pAny_ $ failDecode (Data.Name.toChars generatedName <> " unexpected union tag index")]) ) ) - {- If the current module defines `w3_validate_`, the decoder calls - it after producing a value. The function's existence and signature are - verified by checkValidators in addWireGenerations_ before this runs. -} + {- Only the validating chain (w3_decode_*) attaches the validator. If the + current module defines `w3_validate_`, the validating decoder + calls it after producing a value (its existence and signature are verified by + checkValidators in addWireGenerations_ before this runs). The unsafe chain + (w3_unsafe_decode_*) never validates. -} finalBody = - case findValidatorDef decls unionName of - Just _ -> wrapWithValidator ifaces cname unionName baseBody - Nothing -> baseBody + case mode of + DecodeValidating -> + case findValidatorDef decls unionName of + Just _ -> wrapWithValidator ifaces cname unionName baseBody + Nothing -> baseBody + DecodeUnsafe -> + baseBody generated = Def @@ -834,17 +842,17 @@ encoderAlias isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) = finalGen -decoderAlias :: Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Alias -> Def -decoderAlias isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) = +decoderAlias :: DecodeMode -> Bool -> Map.Map Module.Raw I.Interface -> Pkg.Name -> Src.Module -> Decls -> Data.Name.Name -> Alias -> Def +decoderAlias mode isTest_ ifaces pkg modul decls aliasName alias@(Alias tvars tipe) = let !x = runTests isTest_ "decoderAlias" pkg modul decls generatedName generated alias (aliasAsModule cname aliasName alias) - generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars aliasName + generatedName = Data.Name.fromChars $ decodePrefix mode ++ Data.Name.toChars aliasName cname = Module.Canonical pkg (Src.getName modul) ptvars = tvars & fmap (\tvar -> pvar $ Data.Name.fromChars $ "w3_x_c_" ++ Data.Name.toChars tvar ) generated = Def (a (generatedName)) ptvars $ -- debugDecoder (Data.Name.toElmString aliasName) $ - decoderForType ifaces cname tipe + decoderForType mode ifaces cname tipe in generated diff --git a/extra/Lamdera/Wire3/Decoder.hs b/extra/Lamdera/Wire3/Decoder.hs index fc1acf53..8ce6b59a 100644 --- a/extra/Lamdera/Wire3/Decoder.hs +++ b/extra/Lamdera/Wire3/Decoder.hs @@ -37,8 +37,8 @@ callDecoder name tipe = (a (VarForeign mLamdera_Wire name (Forall Map.empty (TAlias mLamdera_Wire "Decoder" [("a", tipe)] (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [tipe])))))) -decoderForType :: Map.Map Module.Raw I.Interface -> Module.Canonical -> Type -> Expr -decoderForType ifaces cname tipe = +decoderForType :: DecodeMode -> Map.Map Module.Raw I.Interface -> Module.Canonical -> Type -> Expr +decoderForType mode ifaces cname tipe = if containsUnsupportedTypes tipe then failDecode "contains unsupported types" else @@ -89,8 +89,8 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TTuple (TVar "a") (TVar "b") Nothing])))))))) - [ decoderForType ifaces cname a_ - , decoderForType ifaces cname b + [ decoderForType mode ifaces cname a_ + , decoderForType mode ifaces cname b ])) TTuple a_ b (Just c) -> @@ -126,9 +126,9 @@ decoderForType ifaces cname tipe = (Filled (TType (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TTuple (TVar "a") (TVar "b") (Just (TVar "c"))]))))))))) - [ decoderForType ifaces cname a_ - , decoderForType ifaces cname b - , decoderForType ifaces cname c + [ decoderForType mode ifaces cname a_ + , decoderForType mode ifaces cname b + , decoderForType mode ifaces cname c ])) TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [ptype] -> @@ -148,7 +148,7 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TType (Module.Canonical (Name "elm" "core") "Maybe") "Maybe" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) + [ decoderForType mode ifaces cname ptype ])) TType (Module.Canonical (Name "elm" "core") "List") "List" [ptype] -> (a (Call @@ -167,7 +167,7 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TType (Module.Canonical (Name "elm" "core") "List") "List" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) + [ decoderForType mode ifaces cname ptype ])) TType (Module.Canonical (Name "elm" "core") "Set") "Set" [ptype] -> (a (Call @@ -186,7 +186,7 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TType (Module.Canonical (Name "elm" "core") "Set") "Set" [TVar "comparable"]]))))))) - [ decoderForType ifaces cname ptype ])) + [ decoderForType mode ifaces cname ptype ])) TType (Module.Canonical (Name "lamdera" "containers") "SeqSet") "SeqSet" [ptype] -> (a (Call @@ -205,7 +205,7 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TType mLamdera_SeqSet "SeqSet" [TVar "k"]]))))))) - [ decoderForType ifaces cname ptype ])) + [ decoderForType mode ifaces cname ptype ])) TType (Module.Canonical (Name "elm" "core") "Array") "Array" [ptype] -> (a (Call @@ -224,7 +224,7 @@ decoderForType ifaces cname tipe = (Module.Canonical (Name "elm" "bytes") "Bytes.Decode") "Decoder" [TType (Module.Canonical (Name "elm" "core") "Array") "Array" [TVar "a"]]))))))) - [ decoderForType ifaces cname ptype ])) + [ decoderForType mode ifaces cname ptype ])) TType (Module.Canonical (Name "elm" "core") "Result") "Result" [err, a_] -> (a (Call @@ -259,8 +259,8 @@ decoderForType ifaces cname tipe = "Result" [TVar "err", TVar "val"] ])))))))) - [ decoderForType ifaces cname err - , decoderForType ifaces cname a_ + [ decoderForType mode ifaces cname err + , decoderForType mode ifaces cname a_ ])) TType (Module.Canonical (Name "elm" "core") "Dict") "Dict" [key, val] -> @@ -298,8 +298,8 @@ decoderForType ifaces cname tipe = "Dict" [TVar "comparable", TVar "value"] ])))))))) - [ decoderForType ifaces cname key - , decoderForType ifaces cname val + [ decoderForType mode ifaces cname key + , decoderForType mode ifaces cname val ])) TType (Module.Canonical (Name "lamdera" "containers") "SeqDict") "SeqDict" [key, val] -> @@ -337,8 +337,8 @@ decoderForType ifaces cname tipe = "SeqDict" [TVar "k", TVar "value"] ])))))))) - [ decoderForType ifaces cname key - , decoderForType ifaces cname val + [ decoderForType mode ifaces cname key + , decoderForType mode ifaces cname val ])) TType (Module.Canonical (Name "elm" "bytes") "Bytes") "Bytes" _ -> @@ -355,7 +355,7 @@ decoderForType ifaces cname tipe = TType moduleName typeName params -> let - generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars typeName + generatedName = Data.Name.fromChars $ decodePrefix mode ++ Data.Name.toChars typeName decoder = if cname == moduleName @@ -368,7 +368,7 @@ decoderForType ifaces cname tipe = else case params of [] -> decoder - _ -> call decoder $ fmap (decoderForType ifaces cname) params + _ -> call decoder $ fmap (decoderForType mode ifaces cname) params TRecord fieldMap maybeExtensible -> -- | TRecord (Map.Map Name FieldType) (Maybe Name) @@ -379,11 +379,11 @@ decoderForType ifaces cname tipe = Nothing -> let fields = fieldMap & fieldsToList & List.sortOn (\(name, field) -> name) in - decodeRecord ifaces cname fields + decodeRecord mode ifaces cname fields TAlias moduleName typeName tvars_ aType -> let - generatedName = Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars typeName + generatedName = Data.Name.fromChars $ decodePrefix mode ++ Data.Name.toChars typeName innerType = case aType of { Holey t -> t; Filled t -> t } decoder = @@ -402,7 +402,7 @@ decoderForType ifaces cname tipe = TVar name -> lvar $ Data.Name.fromChars $ "w3_x_c_" ++ Data.Name.toChars name _ -> - decoderForType ifaces cname tvarType + decoderForType mode ifaces cname tvarType ) tvars_ in if isUnsupportedKernelType tipe @@ -417,7 +417,7 @@ decoderForType ifaces cname tipe = case resolvedRecordFieldMapM fieldMap extensibleName tvars_ of Just resolved -> let extendedRecord = TRecord resolved Nothing & resolveTvar tvars_ - in decoderForType ifaces cname extendedRecord + in decoderForType mode ifaces cname extendedRecord Nothing -> normalDecoder _ -> -- Resolve extensible records through TAlias chains, @@ -425,7 +425,7 @@ decoderForType ifaces cname tipe = case resolveTvar tvars_ tipe of TAlias _ _ _ (Filled (TRecord fieldMap Nothing)) -> let fields = fieldMap & fieldsToList & List.sortOn (\(name, field) -> name) - in decodeRecord ifaces cname fields + in decodeRecord mode ifaces cname fields _ -> normalDecoder Filled tipe -> case tipe of @@ -433,7 +433,7 @@ decoderForType ifaces cname tipe = case resolvedRecordFieldMapM fieldMap extensibleName tvars_ of Just resolved -> let extendedRecord = TRecord resolved Nothing & resolveTvar tvars_ - in decoderForType ifaces cname extendedRecord + in decoderForType mode ifaces cname extendedRecord Nothing -> normalDecoder otherTypes -> normalDecoder @@ -444,8 +444,8 @@ decoderForType ifaces cname tipe = failDecode "lambda" -decodeRecord :: Map.Map Module.Raw I.Interface -> Module.Canonical -> [(Data.Name.Name, Type)] -> Expr -decodeRecord ifaces cname fields = +decodeRecord :: DecodeMode -> Map.Map Module.Raw I.Interface -> Module.Canonical -> [(Data.Name.Name, Type)] -> Expr +decodeRecord mode ifaces cname fields = let pvars :: [Pattern] pvars = @@ -463,7 +463,7 @@ decodeRecord ifaces cname fields = ++ fmap (\(name, field) -> andMapDecode1 ( -- debugDecoder (Utf8.fromChars $ "." <> Data.Name.toChars name) $ - decoderForType ifaces cname field + decoderForType mode ifaces cname field ) ) fields & foldlPairs (|>) diff --git a/extra/Lamdera/Wire3/Helpers.hs b/extra/Lamdera/Wire3/Helpers.hs index 6cfc12f0..64e8af55 100644 --- a/extra/Lamdera/Wire3/Helpers.hs +++ b/extra/Lamdera/Wire3/Helpers.hs @@ -53,6 +53,32 @@ shouldHaveCodecsGenerated name = _ -> True +{- Which decoder chain we are generating. + +Every custom type and alias gets TWO decoders: + + * w3_decode_ (DecodeValidating) -- applies w3_validate_ if present + and recurses through the validating chain. Used by the + Lamdera runtime for attacker-controlled, backend-inbound + data. + + * w3_unsafe_decode_ (DecodeUnsafe) -- never validates and recurses + through the unsafe chain. Behaves like w3_decode_ did + before validation existed. Used for trusted data + (persistence, evergreen migrations, etc). + +The two chains are otherwise identical; the only difference is the prefix used +when referencing nested user-type decoders (and, for unions, whether the +validator hook is attached). -} +data DecodeMode = DecodeValidating | DecodeUnsafe + deriving (Eq, Show) + + +decodePrefix :: DecodeMode -> String +decodePrefix DecodeValidating = "w3_decode_" +decodePrefix DecodeUnsafe = "w3_unsafe_decode_" + + getForeignSig tipe moduleName generatedName ifaces = -- debugHaskell (T.pack $ "❎❎❎❎❎ ALIAS ENCODER foreignTypeSig for " ++ (Data.Name.toChars generatedName)) $ case foreignTypeSig moduleName generatedName ifaces of @@ -71,6 +97,7 @@ getForeignSig tipe moduleName generatedName ifaces = (TLambda (TVar "a") tLamdera_Wire_Encoder)) else if T.isPrefixOf "w3_decode_" (T.pack $ Data.Name.toChars generatedName) + || T.isPrefixOf "w3_unsafe_decode_" (T.pack $ Data.Name.toChars generatedName) then (Forall (Map.fromList [("a", ())]) diff --git a/extra/Lamdera/Wire3/Interfaces.hs b/extra/Lamdera/Wire3/Interfaces.hs index 3ea3d6a4..03e8a942 100644 --- a/extra/Lamdera/Wire3/Interfaces.hs +++ b/extra/Lamdera/Wire3/Interfaces.hs @@ -153,6 +153,7 @@ unionStubs unions = in [ _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_encode_" ++ Data.Name.toChars name , _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars name + , _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_unsafe_decode_" ++ Data.Name.toChars name ] ) @@ -170,6 +171,7 @@ aliasStubs aliases = in [ _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_encode_" ++ Data.Name.toChars name , _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_decode_" ++ Data.Name.toChars name + , _Debug_todo_with_params nParams $ Data.Name.fromChars $ "w3_unsafe_decode_" ++ Data.Name.toChars name ] ) diff --git a/test/scenario-alltypes/tests/Wire3ValidateTest.elm b/test/scenario-alltypes/tests/Wire3ValidateTest.elm index 597b2e05..6ee3770f 100644 --- a/test/scenario-alltypes/tests/Wire3ValidateTest.elm +++ b/test/scenario-alltypes/tests/Wire3ValidateTest.elm @@ -28,12 +28,15 @@ import Test.Wire_Validate , w3_decode_Validated , w3_encode_Container , w3_encode_Validated + , w3_unsafe_decode_Container + , w3_unsafe_decode_Validated ) import Test.Wire_Validate_Recursive exposing ( Tree(..) , w3_decode_Tree , w3_encode_Tree + , w3_unsafe_decode_Tree ) @@ -58,6 +61,30 @@ roundtripContainer value = (Bytes.Encode.encode (w3_encode_Container value)) +{-| Same round-trips, but decoding via the w3_unsafe_decode_* chain, which never +runs the validators. Encoding is shared (there is only one encoder). +-} +roundtripValidatedUnsafe : Validated -> Maybe Validated +roundtripValidatedUnsafe value = + Bytes.Decode.decode + w3_unsafe_decode_Validated + (Bytes.Encode.encode (w3_encode_Validated value)) + + +roundtripTreeUnsafe : Tree -> Maybe Tree +roundtripTreeUnsafe value = + Bytes.Decode.decode + w3_unsafe_decode_Tree + (Bytes.Encode.encode (w3_encode_Tree value)) + + +roundtripContainerUnsafe : Container -> Maybe Container +roundtripContainerUnsafe value = + Bytes.Decode.decode + w3_unsafe_decode_Container + (Bytes.Encode.encode (w3_encode_Container value)) + + suite : Test suite = describe "w3_validate gates decoding" @@ -136,4 +163,39 @@ suite = } |> Expect.equal Nothing ] + , describe "w3_unsafe_decode_* never validates (trusted-data path)" + [ test "an invalid ValidatedInt round-trips via unsafe decode" <| + \_ -> + -- The validating decoder rejects this (see below); the unsafe + -- decoder must accept it unchanged. + roundtripValidatedUnsafe (ValidatedInt (-1)) + |> Expect.equal (Just (ValidatedInt (-1))) + , test "an invalid ValidatedString round-trips via unsafe decode" <| + \_ -> + roundtripValidatedUnsafe (ValidatedString "") + |> Expect.equal (Just (ValidatedString "")) + , test "the validating decoder still rejects the same value" <| + \_ -> + roundtripValidated (ValidatedInt (-1)) + |> Expect.equal Nothing + , test "unsafe decode does not validate nested nodes (deep bad leaf)" <| + \_ -> + let + tree = + Branch (Leaf 1) (Branch (Leaf 2) (Leaf (-3))) + in + roundtripTreeUnsafe tree + |> Expect.equal (Just tree) + , test "unsafe decode does not validate aggregate fields" <| + \_ -> + let + c : Container + c = + { item = ValidatedInt (-1) + , items = [ ValidatedString "" ] + } + in + roundtripContainerUnsafe c + |> Expect.equal (Just c) + ] ]