From 91910cc2e4050cb658c390c091160700212a6436 Mon Sep 17 00:00:00 2001 From: shaobo-he-aws <130499339+shaobo-he-aws@users.noreply.github.com> Date: Thu, 26 Sep 2024 14:19:21 -0700 Subject: [PATCH] Cherry-pick PRs for release 4.1.x (#441) Signed-off-by: Mike Hicks Signed-off-by: Shaobo He Signed-off-by: Craig Disselkoen Signed-off-by: Emina Torlak Co-authored-by: Bhakti <38060792+bhaktishh@users.noreply.github.com> Co-authored-by: Shah Co-authored-by: bhakti shah Co-authored-by: Bhakti Shah Co-authored-by: Bhakti Shah Co-authored-by: Kesha Hietala Co-authored-by: Kesha Hietala Co-authored-by: Michael Hicks Co-authored-by: Craig Disselkoen Co-authored-by: Emina Torlak Co-authored-by: Emina Torlak --- .github/workflows/ci.yml | 13 +- .github/workflows/deploy_docs.yml | 6 +- README.md | 1 + cedar-drt/Cargo.toml | 2 +- cedar-drt/build_lean_lib.sh | 1 + cedar-drt/fuzz/Cargo.toml | 2 +- .../convert-policy-json-to-cedar.rs | 3 +- .../validation-pbt-type-directed.rs | 21 +- cedar-drt/fuzz/fuzz_targets/validation-pbt.rs | 27 +- cedar-drt/fuzz/src/schemas.rs | 159 +----- cedar-lean/.gitignore | 1 - cedar-lean/Cedar.lean | 1 - cedar-lean/Cedar/Partial.lean | 22 - cedar-lean/Cedar/Partial/Authorizer.lean | 48 -- cedar-lean/Cedar/Partial/Entities.lean | 120 ---- cedar-lean/Cedar/Partial/Evaluator.lean | 287 ---------- cedar-lean/Cedar/Partial/Request.lean | 146 ----- cedar-lean/Cedar/Partial/Response.lean | 276 --------- cedar-lean/Cedar/Partial/Value.lean | 244 -------- cedar-lean/Cedar/Spec/Entities.lean | 12 + cedar-lean/Cedar/Spec/Evaluator.lean | 8 + cedar-lean/Cedar/Spec/Expr.lean | 2 + cedar-lean/Cedar/Spec/Value.lean | 1 + cedar-lean/Cedar/Thm.lean | 2 +- cedar-lean/Cedar/Thm/Data/List/Lemmas.lean | 13 + cedar-lean/Cedar/Thm/Partial.lean | 19 - .../Cedar/Thm/Partial/Authorization.lean | 172 ------ .../Authorization/PartialOnConcrete.lean | 234 -------- .../Authorization/PartialResponse.lean | 82 --- cedar-lean/Cedar/Thm/Partial/Evaluation.lean | 17 - .../Thm/Partial/Evaluation/Evaluate.lean | 534 ------------------ .../Thm/Partial/Evaluation/Evaluate/And.lean | 72 --- .../Partial/Evaluation/Evaluate/AndOr.lean | 202 ------- .../Partial/Evaluation/Evaluate/Binary.lean | 168 ------ .../Thm/Partial/Evaluation/Evaluate/Call.lean | 160 ------ .../Partial/Evaluation/Evaluate/GetAttr.lean | 128 ----- .../Partial/Evaluation/Evaluate/HasAttr.lean | 141 ----- .../Thm/Partial/Evaluation/Evaluate/Ite.lean | 193 ------- .../Thm/Partial/Evaluation/Evaluate/Or.lean | 70 --- .../Partial/Evaluation/Evaluate/Record.lean | 368 ------------ .../Thm/Partial/Evaluation/Evaluate/Set.lean | 250 -------- .../Partial/Evaluation/Evaluate/Unary.lean | 140 ----- .../Thm/Partial/Evaluation/Evaluate/Var.lean | 281 --------- .../Partial/Evaluation/EvaluateBinaryApp.lean | 408 ------------- .../Thm/Partial/Evaluation/EvaluateCall.lean | 178 ------ .../Partial/Evaluation/EvaluateGetAttr.lean | 269 --------- .../Partial/Evaluation/EvaluateHasAttr.lean | 188 ------ .../Partial/Evaluation/EvaluateUnaryApp.lean | 113 ---- .../Cedar/Thm/Partial/Evaluation/Props.lean | 77 --- cedar-lean/Cedar/Thm/Partial/Subst.lean | 457 --------------- cedar-lean/Cedar/Thm/Partial/WellFormed.lean | 91 --- cedar-lean/Cedar/Thm/Validation.lean | 8 +- .../Validation/RequestEntityValidation.lean | 283 ++++++++++ .../Thm/Validation/Typechecker/Basic.lean | 46 +- .../Thm/Validation/Typechecker/BinaryApp.lean | 220 +++++++- .../Thm/Validation/Typechecker/HasAttr.lean | 10 +- .../Thm/Validation/Typechecker/Types.lean | 9 +- .../Cedar/Thm/Validation/Validator.lean | 29 +- .../Validation/RequestEntityValidator.lean | 29 +- cedar-lean/Cedar/Validation/Typechecker.lean | 46 +- cedar-lean/Cedar/Validation/Types.lean | 4 + cedar-lean/Cedar/Validation/Validator.lean | 1 + cedar-lean/DiffTest/Main.lean | 32 +- cedar-lean/DiffTest/Parser.lean | 122 +--- cedar-lean/README.md | 11 +- cedar-lean/lake-manifest.json | 15 - cedar-lean/lakefile.lean | 4 +- cedar-policy-generators/Cargo.toml | 2 +- cedar-policy-generators/src/expr.rs | 92 +-- cedar-policy-generators/src/hierarchy.rs | 8 +- cedar-policy-generators/src/schema.rs | 518 ++++------------- 71 files changed, 889 insertions(+), 7030 deletions(-) delete mode 100644 cedar-lean/Cedar/Partial.lean delete mode 100644 cedar-lean/Cedar/Partial/Authorizer.lean delete mode 100644 cedar-lean/Cedar/Partial/Entities.lean delete mode 100644 cedar-lean/Cedar/Partial/Evaluator.lean delete mode 100644 cedar-lean/Cedar/Partial/Request.lean delete mode 100644 cedar-lean/Cedar/Partial/Response.lean delete mode 100644 cedar-lean/Cedar/Partial/Value.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Authorization.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Authorization/PartialOnConcrete.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Authorization/PartialResponse.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/And.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/AndOr.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Binary.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Call.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/GetAttr.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/HasAttr.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Ite.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Or.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Record.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Set.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Unary.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Var.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateBinaryApp.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateCall.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateGetAttr.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateHasAttr.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateUnaryApp.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Evaluation/Props.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/Subst.lean delete mode 100644 cedar-lean/Cedar/Thm/Partial/WellFormed.lean create mode 100644 cedar-lean/Cedar/Thm/Validation/RequestEntityValidation.lean delete mode 100644 cedar-lean/lake-manifest.json diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 82519b9b5..852c9afb9 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -30,11 +30,15 @@ jobs: run: | wget https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh bash elan-init.sh -y - - name: Build + - name: Download dependencies + working-directory: ./cedar-lean + shell: bash + run: source ~/.profile && lake -R -Kenv=dev update + - name: Build proofs working-directory: ./cedar-lean shell: bash run: source ~/.profile && lake build Cedar - - name: Test + - name: Run unit tests working-directory: ./cedar-lean shell: bash run: source ~/.profile && lake exe CedarUnitTests @@ -42,6 +46,11 @@ jobs: working-directory: ./cedar-lean shell: bash run: source ~/.profile && ./test_cli.sh + - name: Build docs + working-directory: ./cedar-lean + shell: bash + run: source ~/.profile && lake -R -Kenv=dev build Cedar:docs + build_and_test_drt: needs: get-branch-name diff --git a/.github/workflows/deploy_docs.yml b/.github/workflows/deploy_docs.yml index ded9fe2ed..8e63d211c 100644 --- a/.github/workflows/deploy_docs.yml +++ b/.github/workflows/deploy_docs.yml @@ -34,14 +34,14 @@ jobs: run: | wget https://raw.githubusercontent.com/leanprover/elan/master/elan-init.sh bash elan-init.sh -y - - name: Download doc-gen4 + - name: Download dependencies working-directory: ./cedar-lean shell: bash - run: source ~/.profile && sed -i '/^meta if get_config? env = some "dev" then/d' lakefile.lean && lake update doc-gen4 + run: source ~/.profile && lake -R -Kenv=dev update - name: Build docs working-directory: ./cedar-lean shell: bash - run: source ~/.profile && lake -Kenv=dev build Cedar:docs + run: source ~/.profile && lake -R -Kenv=dev build Cedar:docs - name: Move documentation to `docs/docs` run: | mkdir docs diff --git a/README.md b/README.md index b7779a079..9d031d0b9 100644 --- a/README.md +++ b/README.md @@ -22,6 +22,7 @@ See the README in each directory for more information. * Install Lean, following the instructions [here](https://leanprover.github.io/lean4/doc/setup.html). * `cd cedar-lean` * `source ../cedar-drt/set_env_vars.sh` (only required if running on AL2) +* `lake update` * `lake build Cedar` ### DRT framework diff --git a/cedar-drt/Cargo.toml b/cedar-drt/Cargo.toml index b6f20e9ab..8ce66ba2c 100644 --- a/cedar-drt/Cargo.toml +++ b/cedar-drt/Cargo.toml @@ -18,7 +18,7 @@ miette = "7.1.0" serde = { version = "1.0", features = ["derive"] } serde_json = "1.0" lazy_static = "1.4" -smol_str = { version = "0.2", features = ["serde"] } +smol_str = { version = "0.3", features = ["serde"] } [features] integration-testing = [] diff --git a/cedar-drt/build_lean_lib.sh b/cedar-drt/build_lean_lib.sh index 97804d286..32f72af27 100755 --- a/cedar-drt/build_lean_lib.sh +++ b/cedar-drt/build_lean_lib.sh @@ -14,4 +14,5 @@ # limitations under the License. # Build command needed for linking Lean lib with Rust code +lake update lake build Cedar:static DiffTest:static Batteries:static \ No newline at end of file diff --git a/cedar-drt/fuzz/Cargo.toml b/cedar-drt/fuzz/Cargo.toml index 120ead007..b3a922e87 100644 --- a/cedar-drt/fuzz/Cargo.toml +++ b/cedar-drt/fuzz/Cargo.toml @@ -21,7 +21,7 @@ cedar-policy-formatter = { path = "../../cedar/cedar-policy-formatter", version cedar-testing = { path = "../../cedar/cedar-testing", version = "4.*" } cedar-policy-generators = { path = "../../cedar-policy-generators", version = "4.*" } miette = "7.1.0" -smol_str = { version = "0.2", features = ["serde"] } +smol_str = { version = "0.3", features = ["serde"] } regex = "1" rayon = { version = "1.5", optional = true } rand = { version = "0.8", features = ["small_rng"] } diff --git a/cedar-drt/fuzz/fuzz_targets/convert-policy-json-to-cedar.rs b/cedar-drt/fuzz/fuzz_targets/convert-policy-json-to-cedar.rs index 458dff0e9..6c4ccdd17 100644 --- a/cedar-drt/fuzz/fuzz_targets/convert-policy-json-to-cedar.rs +++ b/cedar-drt/fuzz/fuzz_targets/convert-policy-json-to-cedar.rs @@ -30,7 +30,8 @@ enum ESTParseError { } fuzz_target!(|est_json_str: String| { - if let Ok(ast_from_est) = serde_json::from_str::(&est_json_str) + if let Ok(ast_from_est) = serde_json::from_str::(&est_json_str) + .and_then(|val| serde_json::from_value::(val)) .map_err(ESTParseError::from) .and_then(|est| { est.try_into_ast_template(Some(PolicyID::from_string("policy0"))) diff --git a/cedar-drt/fuzz/fuzz_targets/validation-pbt-type-directed.rs b/cedar-drt/fuzz/fuzz_targets/validation-pbt-type-directed.rs index 0ba384c81..7bd683156 100644 --- a/cedar-drt/fuzz/fuzz_targets/validation-pbt-type-directed.rs +++ b/cedar-drt/fuzz/fuzz_targets/validation-pbt-type-directed.rs @@ -107,10 +107,12 @@ impl<'a> Arbitrary<'a> for FuzzTargetInput { } /// helper function that just tells us whether a policyset passes validation -fn passes_validation(validator: &Validator, policyset: &ast::PolicySet) -> bool { - validator - .validate(policyset, ValidationMode::default()) - .validation_passed() +fn passes_validation( + validator: &Validator, + policyset: &ast::PolicySet, + mode: ValidationMode, +) -> bool { + validator.validate(policyset, mode).validation_passed() } // The main fuzz target. This is for PBT on the validator @@ -125,7 +127,10 @@ fuzz_target!(|input: FuzzTargetInput| { let mut policyset = ast::PolicySet::new(); let policy: ast::StaticPolicy = input.policy.into(); policyset.add_static(policy.clone()).unwrap(); - if passes_validation(&validator, &policyset) { + let passes_strict = passes_validation(&validator, &policyset, ValidationMode::Strict); + let passes_permissive = + passes_validation(&validator, &policyset, ValidationMode::Permissive); + if passes_permissive { // policy successfully validated, let's make sure we don't get any // dynamic type errors let authorizer = Authorizer::new(); @@ -172,6 +177,12 @@ fuzz_target!(|input: FuzzTargetInput| { "validated policy produced unexpected errors {unexpected_errs:?}!\npolicies:\n{policyset}\nentities:\n{entities}\nschema:\n{schemafile_string}\nrequest:\n{q}\n", ) } + } else { + assert_eq!( + false, + passes_strict, + "policy fails permissive validation but passes strict validation!\npolicies:\n{policyset}\nentities:\n{entities}\nschema:\n{schemafile_string}\n", + ); } } } diff --git a/cedar-drt/fuzz/fuzz_targets/validation-pbt.rs b/cedar-drt/fuzz/fuzz_targets/validation-pbt.rs index 299a15374..7ed352f64 100644 --- a/cedar-drt/fuzz/fuzz_targets/validation-pbt.rs +++ b/cedar-drt/fuzz/fuzz_targets/validation-pbt.rs @@ -306,10 +306,12 @@ impl<'a> Arbitrary<'a> for FuzzTargetInput { } /// helper function that just tells us whether a policyset passes validation -fn passes_validation(validator: &Validator, policyset: &ast::PolicySet) -> bool { - validator - .validate(policyset, ValidationMode::default()) - .validation_passed() +fn passes_validation( + validator: &Validator, + policyset: &ast::PolicySet, + mode: ValidationMode, +) -> bool { + validator.validate(policyset, mode).validation_passed() } // The main fuzz target. This is for PBT on the validator @@ -332,11 +334,15 @@ fuzz_target!(|input: FuzzTargetInput| { let mut policyset = ast::PolicySet::new(); let policy: ast::StaticPolicy = input.policy.into(); policyset.add_static(policy.clone()).unwrap(); - if passes_validation(&validator, &policyset) { + let passes_strict = passes_validation(&validator, &policyset, ValidationMode::Strict); + let passes_permissive = + passes_validation(&validator, &policyset, ValidationMode::Permissive); + if passes_permissive { checkpoint(LOG_FILENAME_VALIDATION_PASS); - maybe_log_schemastats(schemafile.as_ref(), "vyes"); - maybe_log_hierarchystats(&input.hierarchy, "vyes"); - maybe_log_policystats(&policy, "vyes"); + let suffix = if passes_strict { "vyes" } else { "vpermissive" }; + maybe_log_schemastats(schemafile.as_ref(), suffix); + maybe_log_hierarchystats(&input.hierarchy, suffix); + maybe_log_policystats(&policy, suffix); // policy successfully validated, let's make sure we don't get any // dynamic type errors let authorizer = Authorizer::new(); @@ -387,6 +393,11 @@ fuzz_target!(|input: FuzzTargetInput| { maybe_log_schemastats(schemafile.as_ref(), "vno"); maybe_log_hierarchystats(&input.hierarchy, "vno"); maybe_log_policystats(&policy, "vno"); + assert_eq!( + false, + passes_strict, + "policy fails permissive validation but passes strict validation!\npolicies:\n{policyset}\nentities:\n{entities}\nschema:\n{schemafile_string}\n", + ); } } } diff --git a/cedar-drt/fuzz/src/schemas.rs b/cedar-drt/fuzz/src/schemas.rs index 54af1663b..3ca21b24b 100644 --- a/cedar-drt/fuzz/src/schemas.rs +++ b/cedar-drt/fuzz/src/schemas.rs @@ -15,11 +15,7 @@ */ use cedar_policy_core::ast::{Id, InternalName, Name}; -use cedar_policy_validator::json_schema::{ - self, ApplySpec, EntityAttributeType, EntityAttributeTypeInternal, EntityAttributes, - EntityAttributesInternal, EntityType, NamespaceDefinition, RecordAttributeType, RecordType, - Type, TypeVariant, -}; +use cedar_policy_validator::json_schema; use cedar_policy_validator::RawName; use itertools::Itertools; use std::collections::{BTreeMap, BTreeSet, HashMap, HashSet}; @@ -72,13 +68,13 @@ pub fn equivalence_check( frag: &json_schema::Fragment, -) -> impl Iterator, &NamespaceDefinition)> { +) -> impl Iterator, &json_schema::NamespaceDefinition)> { frag.0 .iter() .filter(|(name, nsdef)| name.is_some() || !is_trivial_namespace(nsdef)) } -fn is_trivial_namespace(nsdef: &NamespaceDefinition) -> bool { +fn is_trivial_namespace(nsdef: &json_schema::NamespaceDefinition) -> bool { nsdef.entity_types.is_empty() && nsdef.actions.is_empty() && nsdef.common_types.is_empty() } @@ -201,7 +197,7 @@ impl Equiv for BTreeMap { } } -impl Equiv for EntityType { +impl Equiv for json_schema::EntityType { fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { Equiv::equiv( &lhs.member_of_types.iter().collect::>(), @@ -223,77 +219,7 @@ impl Equiv for cedar_policy_validator::ValidatorEntityType { } } -impl Equiv for EntityAttributes { - fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { - match (lhs, rhs) { - ( - EntityAttributes::RecordAttributes(rca_l), - EntityAttributes::RecordAttributes(rca_r), - ) => Equiv::equiv(&rca_l.0, &rca_r.0) - .map_err(|e| format!("entity attributes not equivalent: {e}")), - ( - EntityAttributes::EntityAttributes(EntityAttributesInternal { - attrs: attrs_l, .. - }), - EntityAttributes::EntityAttributes(EntityAttributesInternal { - attrs: attrs_r, .. - }), - ) => { - if attrs_l.additional_attributes != attrs_r.additional_attributes { - return Err("attributes differ in additional_attributes flag".into()); - } - Equiv::equiv(&attrs_l.attributes, &attrs_r.attributes) - .map_err(|e| format!("entity attributes not equivalent: {e}")) - } - ( - EntityAttributes::RecordAttributes(rca), - EntityAttributes::EntityAttributes(EntityAttributesInternal { attrs, .. }), - ) - | ( - EntityAttributes::EntityAttributes(EntityAttributesInternal { attrs, .. }), - EntityAttributes::RecordAttributes(rca), - ) => match &rca.0 { - Type::CommonTypeRef { .. } => { - Err("common type is not equivalent to explicit record type".into()) - } - Type::Type(TypeVariant::Record(rty)) => { - if rty.additional_attributes != attrs.additional_attributes { - return Err("attributes differ in additional_attributes flag".into()); - } - if rty.attributes.len() != attrs.attributes.len() { - let lhs_keys: HashSet<_> = rty.attributes.keys().collect(); - let rhs_keys: HashSet<_> = attrs.attributes.keys().collect(); - let missing_keys = lhs_keys.symmetric_difference(&rhs_keys).join(", "); - return Err(format!("Missing attributes: {missing_keys}")); - } - for (k, v1) in &rty.attributes { - let v2 = attrs - .attributes - .get(k) - .ok_or_else(|| format!("missing attribute {k}"))?; - if v1.required != v2.required { - return Err(format!("attribute `{k}` differs in required flag")); - } - match &v2.ty { - EntityAttributeTypeInternal::EAMap { .. } => { - return Err(format!("in attribute `{k}`, EAMap is not equivalent to non-EAMap type: {} != {}", &v2.ty, &v1.ty)); - } - EntityAttributeTypeInternal::Type(ty) => { - Equiv::equiv(&v1.ty, ty)?; - } - } - } - Ok(()) - } - ty @ Type::Type(_) => Err(format!( - "expected `RecordOrContextAttributes` to contain a record type, but got {ty:?}" - )), - }, - } - } -} - -impl Equiv for EntityAttributeType { +impl Equiv for json_schema::TypeOfAttribute { fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { if lhs.required != rhs.required { return Err("attributes differ in required flag".into()); @@ -311,35 +237,11 @@ impl Equiv for cedar_policy_validator::types::AttributeType { } } -impl Equiv for EntityAttributeTypeInternal { +impl Equiv for json_schema::Type { fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { match (lhs, rhs) { - (EntityAttributeTypeInternal::Type(ty_l), EntityAttributeTypeInternal::Type(ty_r)) => { - Equiv::equiv(ty_l, ty_r) - } - ( - EntityAttributeTypeInternal::EAMap { - value_type: val_ty_l, - }, - EntityAttributeTypeInternal::EAMap { - value_type: val_ty_r, - }, - ) => Equiv::equiv(val_ty_l, val_ty_r), - (EntityAttributeTypeInternal::Type(_), EntityAttributeTypeInternal::EAMap { .. }) - | (EntityAttributeTypeInternal::EAMap { .. }, EntityAttributeTypeInternal::Type(_)) => { - Err(format!( - "EAMap is not equivalent to non-EAMap type: {lhs} != {rhs}" - )) - } - } - } -} - -impl Equiv for Type { - fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { - match (lhs, rhs) { - (Type::Type(lhs), Type::Type(rhs)) => Equiv::equiv(lhs, rhs), - (Type::CommonTypeRef { type_name: lhs }, Type::CommonTypeRef { type_name: rhs }) => { + (Self::Type(lhs), Self::Type(rhs)) => Equiv::equiv(lhs, rhs), + (Self::CommonTypeRef { type_name: lhs }, Self::CommonTypeRef { type_name: rhs }) => { if lhs == rhs { Ok(()) } else { @@ -348,10 +250,10 @@ impl Equiv for Type { )) } } - (Type::Type(lhs), Type::CommonTypeRef { type_name: rhs }) => Err(format!( + (Self::Type(lhs), Self::CommonTypeRef { type_name: rhs }) => Err(format!( "lhs is ordinary type `{lhs:?}`, rhs is common type `{rhs}`" )), - (Type::CommonTypeRef { type_name: lhs }, Type::Type(rhs)) => Err(format!( + (Self::CommonTypeRef { type_name: lhs }, Self::Type(rhs)) => Err(format!( "lhs is common type `{lhs}`, rhs is ordinary type `{rhs:?}`" )), } @@ -368,7 +270,7 @@ impl Equiv for cedar_policy_validator::types::Type { } } -impl Equiv for TypeVariant { +impl Equiv for json_schema::TypeVariant { fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { match (lhs, rhs) { // Records are equivalent iff @@ -376,11 +278,11 @@ impl Equiv for TypeVariant // B) Each key has a value that is equivalent // C) the `additional_attributes` field is equal ( - TypeVariant::Record(RecordType { + Self::Record(json_schema::RecordType { attributes: lhs_attributes, additional_attributes: lhs_additional_attributes, }), - TypeVariant::Record(RecordType { + Self::Record(json_schema::RecordType { attributes: rhs_attributes, additional_attributes: rhs_additional_attributes, }), @@ -402,18 +304,18 @@ impl Equiv for TypeVariant } // Sets are equivalent if their elements are equivalent ( - TypeVariant::Set { + Self::Set { element: lhs_element, }, - TypeVariant::Set { + Self::Set { element: rhs_element, }, ) => Equiv::equiv(lhs_element.as_ref(), rhs_element.as_ref()), // Base types are equivalent to `EntityOrCommon` variants where the type_name is of the // form `__cedar::` - (TypeVariant::String, TypeVariant::EntityOrCommon { type_name }) - | (TypeVariant::EntityOrCommon { type_name }, TypeVariant::String) => { + (Self::String, Self::EntityOrCommon { type_name }) + | (Self::EntityOrCommon { type_name }, Self::String) => { if is_internal_type(type_name, "String") { Ok(()) } else { @@ -422,8 +324,8 @@ impl Equiv for TypeVariant )) } } - (TypeVariant::Long, TypeVariant::EntityOrCommon { type_name }) - | (TypeVariant::EntityOrCommon { type_name }, TypeVariant::Long) => { + (Self::Long, Self::EntityOrCommon { type_name }) + | (Self::EntityOrCommon { type_name }, Self::Long) => { if is_internal_type(type_name, "Long") { Ok(()) } else { @@ -432,8 +334,8 @@ impl Equiv for TypeVariant )) } } - (TypeVariant::Boolean, TypeVariant::EntityOrCommon { type_name }) - | (TypeVariant::EntityOrCommon { type_name }, TypeVariant::Boolean) => { + (Self::Boolean, Self::EntityOrCommon { type_name }) + | (Self::EntityOrCommon { type_name }, Self::Boolean) => { if is_internal_type(type_name, "Bool") { Ok(()) } else { @@ -442,8 +344,8 @@ impl Equiv for TypeVariant )) } } - (TypeVariant::Extension { name }, TypeVariant::EntityOrCommon { type_name }) - | (TypeVariant::EntityOrCommon { type_name }, TypeVariant::Extension { name }) => { + (Self::Extension { name }, Self::EntityOrCommon { type_name }) + | (Self::EntityOrCommon { type_name }, Self::Extension { name }) => { if is_internal_type(type_name, &name.to_string()) { Ok(()) } else { @@ -453,8 +355,8 @@ impl Equiv for TypeVariant } } - (TypeVariant::Entity { name }, TypeVariant::EntityOrCommon { type_name }) - | (TypeVariant::EntityOrCommon { type_name }, TypeVariant::Entity { name }) => { + (Self::Entity { name }, Self::EntityOrCommon { type_name }) + | (Self::EntityOrCommon { type_name }, Self::Entity { name }) => { if type_name == name { Ok(()) } else { @@ -476,12 +378,11 @@ impl Equiv for TypeVariant } } -impl Equiv for RecordAttributeType { +impl Equiv + for json_schema::AttributesOrContext +{ fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { - if lhs.required != rhs.required { - return Err(format!("attribute `{lhs:?}` is not equivalent to attribute `{rhs:?}` because of difference in .required")); - } - Equiv::equiv(&lhs.ty, &rhs.ty) + Equiv::equiv(&lhs.0, &rhs.0) } } @@ -557,7 +458,7 @@ fn action_type_equivalence Equiv for ApplySpec { +impl Equiv for json_schema::ApplySpec { fn equiv(lhs: &Self, rhs: &Self) -> Result<(), String> { // ApplySpecs are equivalent iff // A) the principal and resource type lists are equal diff --git a/cedar-lean/.gitignore b/cedar-lean/.gitignore index bda47cfab..ffdbaffc1 100644 --- a/cedar-lean/.gitignore +++ b/cedar-lean/.gitignore @@ -1,7 +1,6 @@ .DS_Store /.lake/* *.json -!lake-manifest.json *.olean lake-packages diff --git a/cedar-lean/Cedar.lean b/cedar-lean/Cedar.lean index 58a5e958d..87c1c167c 100644 --- a/cedar-lean/Cedar.lean +++ b/cedar-lean/Cedar.lean @@ -15,7 +15,6 @@ -/ import Cedar.Data -import Cedar.Partial import Cedar.Spec import Cedar.Thm import Cedar.Validation diff --git a/cedar-lean/Cedar/Partial.lean b/cedar-lean/Cedar/Partial.lean deleted file mode 100644 index 496c437e0..000000000 --- a/cedar-lean/Cedar/Partial.lean +++ /dev/null @@ -1,22 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Authorizer -import Cedar.Partial.Entities -import Cedar.Partial.Evaluator -import Cedar.Partial.Request -import Cedar.Partial.Response -import Cedar.Partial.Value diff --git a/cedar-lean/Cedar/Partial/Authorizer.lean b/cedar-lean/Cedar/Partial/Authorizer.lean deleted file mode 100644 index b6adbbab0..000000000 --- a/cedar-lean/Cedar/Partial/Authorizer.lean +++ /dev/null @@ -1,48 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Partial.Response -import Cedar.Partial.Value - -/-! This file defines the Cedar partial authorizer. -/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Policy Policies) - -def knownSatisfied (policy : Policy) (req : Partial.Request) (entities : Partial.Entities) : Bool := - Partial.evaluate policy.toExpr req entities = .ok (.value true) - -def knownUnsatisfied (policy : Policy) (req : Partial.Request) (entities : Partial.Entities) : Bool := - Partial.evaluate policy.toExpr req entities = .ok (.value false) - -def knownErroring (policy : Policy) (req : Partial.Request) (entities : Partial.Entities) : Bool := - match (Partial.evaluate policy.toExpr req entities) with - | .ok _ => false - | .error _ => true - -def isAuthorized (req : Partial.Request) (entities : Partial.Entities) (policies : Policies) : Partial.Response := - { - residuals := policies.filterMap λ policy => match Partial.evaluate policy.toExpr req entities with - | .ok (.value (.prim (.bool false))) => none - | .ok pv => some (.residual policy.id policy.effect pv) - | .error e => some (.error policy.id e) - entities, - } - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Partial/Entities.lean b/cedar-lean/Cedar/Partial/Entities.lean deleted file mode 100644 index f570ec365..000000000 --- a/cedar-lean/Cedar/Partial/Entities.lean +++ /dev/null @@ -1,120 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Spec.Entities -import Cedar.Partial.Value - -/-! -This file defines Cedar partial-entities structures. --/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Attr EntityUID Result) - -/-- -Represents the information about one entity. - -Currently, this allows attrs to be known-to-exist-but-unknown-value, -but does not allow attrs to be unknown-whether-they-exist-entirely. -(the result of `e has attr` is never a residual for an `e` that is known to exist.) - -Currently, this does not allow any unknowns about ancestor information. -All ancestor information must be fully concrete. --/ -structure EntityData where - attrs : Map Attr Partial.Value - ancestors : Set EntityUID - -/-- -Represents the information about all entities. - -Currently, this does not allow it to be unknown whether an entity exists. -Either it exists (and we have a `Partial.EntityData`) or it does not. --/ -structure Entities where - es : Map EntityUID Partial.EntityData - -def Entities.ancestors (es : Partial.Entities) (uid : EntityUID) : Result (Set EntityUID) := do - let d ← es.es.findOrErr uid .entityDoesNotExist - .ok d.ancestors - -def Entities.ancestorsOrEmpty (es : Partial.Entities) (uid : EntityUID) : Set EntityUID := - match es.es.find? uid with - | some d => d.ancestors - | none => Set.empty - -def Entities.attrs (es : Partial.Entities) (uid : EntityUID) : Result (Map Attr Partial.Value) := do - let d ← es.es.findOrErr uid .entityDoesNotExist - .ok d.attrs - -def Entities.attrsOrEmpty (es : Partial.Entities) (uid : EntityUID) : Map Attr Partial.Value := - match es.es.find? uid with - | some d => d.attrs - | none => Map.empty - -deriving instance Inhabited for EntityData - -end Cedar.Partial - -namespace Cedar.Spec - -def EntityData.asPartialEntityData : Spec.EntityData → Partial.EntityData - | { attrs, ancestors } => { - attrs := attrs.mapOnValues Partial.Value.value, - ancestors, - } - -instance : Coe Spec.EntityData Partial.EntityData where - coe := Spec.EntityData.asPartialEntityData - -def Entities.asPartialEntities (es : Spec.Entities) : Partial.Entities := - { es := es.mapOnValues Spec.EntityData.asPartialEntityData } - -instance : Coe Spec.Entities Partial.Entities where - coe := Spec.Entities.asPartialEntities - -end Cedar.Spec - -namespace Cedar.Partial - -open Cedar.Data - -/-- - Given a map of unknown-name to value, substitute all unknowns with the - corresponding values, producing a new `Partial.EntityData`. - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.EntityData` will still contain some unknowns. --/ -def EntityData.subst (subsmap : Subsmap) : Partial.EntityData → Partial.EntityData - | { attrs, ancestors } => { - attrs := attrs.mapOnValues (Partial.Value.subst subsmap), - ancestors, - } - -/-- - Given a map of unknown-name to value, substitute all unknowns with the - corresponding values, producing a new `Partial.Entities`. - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.Entities` will still contain some unknowns. --/ -def Entities.subst (subsmap : Subsmap) : Partial.Entities → Partial.Entities - | { es } => { - es := es.mapOnValues (Partial.EntityData.subst subsmap) - } - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Partial/Evaluator.lean b/cedar-lean/Cedar/Partial/Evaluator.lean deleted file mode 100644 index ded856429..000000000 --- a/cedar-lean/Cedar/Partial/Evaluator.lean +++ /dev/null @@ -1,287 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Entities -import Cedar.Partial.Request -import Cedar.Partial.Value -import Cedar.Spec.Evaluator -import Cedar.Spec.ExtFun -import Cedar.Spec.Value - -/-! This file defines the semantics of Cedar partial evaluation. -/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Attr BinaryOp EntityUID Expr ExtFun Result UnaryOp Var intOrErr) -open Cedar.Spec.Error - -/-- - Partial-evaluate `op₁ pv₁`. No analogue in Spec.Evaluator; this logic (that - sits between `Partial.evaluate` and `Spec.apply₁`) is not needed in the - equivalent Spec.Evaluator position --/ -def evaluateUnaryApp (op₁ : UnaryOp) : Partial.Value → Result Partial.Value - | .value v₁ => do - let val ← Spec.apply₁ op₁ v₁ - .ok (.value val) - | pv => .ok (.residual (.unaryApp op₁ pv)) - -/-- Analogous to Spec.inₑ but for partial entities -/ -def inₑ (uid₁ uid₂ : EntityUID) (es : Partial.Entities) : Bool := - uid₁ == uid₂ || (es.ancestorsOrEmpty uid₁).contains uid₂ - -/-- Analogous to Spec.inₛ but for partial entities -/ -def inₛ (uid : EntityUID) (vs : Set Spec.Value) (es : Partial.Entities) : Result Spec.Value := do - let uids ← vs.mapOrErr Spec.Value.asEntityUID .typeError - .ok (uids.any (Partial.inₑ uid · es)) - -/-- Analogous to Spec.apply₂ but for partial entities -/ -def apply₂ (op₂ : BinaryOp) (v₁ v₂ : Spec.Value) (es : Partial.Entities) : Result Partial.Value := - match op₂, v₁, v₂ with - | .eq, _, _ => .ok (.value (v₁ == v₂)) - | .less, .prim (.int i), .prim (.int j) => .ok (.value ((i < j): Bool)) - | .lessEq, .prim (.int i), .prim (.int j) => .ok (.value ((i ≤ j): Bool)) - | .add, .prim (.int i), .prim (.int j) => do .ok (.value (← intOrErr (i.add? j))) - | .sub, .prim (.int i), .prim (.int j) => do .ok (.value (← intOrErr (i.sub? j))) - | .mul, .prim (.int i), .prim (.int j) => do .ok (.value (← intOrErr (i.mul? j))) - | .contains, .set vs₁, _ => .ok (.value (vs₁.contains v₂)) - | .containsAll, .set vs₁, .set vs₂ => .ok (.value (vs₂.subset vs₁)) - | .containsAny, .set vs₁, .set vs₂ => .ok (.value (vs₁.intersects vs₂)) - | .mem, .prim (.entityUID uid₁), .prim (.entityUID uid₂) => .ok (.value (Partial.inₑ uid₁ uid₂ es)) - | .mem, .prim (.entityUID uid₁), .set (vs) => do .ok (.value (← Partial.inₛ uid₁ vs es)) - | _, _, _ => .error .typeError - -/-- - Partial-evaluate `op₂ pv₁ pv₂`. No analogue in Spec.Evaluator; this logic - (that sits between `Partial.evaluate` and `Partial.apply₂`) is not needed in - the equivalent Spec.Evaluator position --/ -def evaluateBinaryApp (op₂ : BinaryOp) (pv₁ pv₂ : Partial.Value) (es : Partial.Entities) : Result Partial.Value := - match (pv₁, pv₂) with - | (.value v₁, .value v₂) => Partial.apply₂ op₂ v₁ v₂ es - | (pv₁, pv₂) => .ok (.residual (.binaryApp op₂ pv₁ pv₂)) - -/-- Analogous to Spec.attrsOf but for lookup functions that return partial values -/ -def attrsOf (v : Spec.Value) (lookup : EntityUID → Result (Map Attr Partial.Value)) : Result (Map Attr Partial.Value) := - match v with - | .record r => .ok (r.mapOnValues Partial.Value.value) - | .prim (.entityUID uid) => lookup uid - | _ => .error typeError - -/-- Analogous to Spec.hasAttr but for partial entities -/ -def hasAttr (v : Spec.Value) (a : Attr) (es : Partial.Entities) : Result Spec.Value := do - let r ← Partial.attrsOf v (λ uid => .ok (es.attrsOrEmpty uid)) - .ok (r.contains a) - -/-- - Partial-evaluate `pv has a`. No analogue in Spec.Evaluator; this logic (that - sits between `Partial.evaluate` and `Partial.hasAttr`) is not needed in the - equivalent Spec.Evaluator position --/ -def evaluateHasAttr (pv : Partial.Value) (a : Attr) (es : Partial.Entities) : Result Partial.Value := do - match pv with - | .value v₁ => do - let val ← Partial.hasAttr v₁ a es - .ok (.value val) - | .residual r => .ok (.residual (.hasAttr (.residual r) a)) -- could be more precise; see cedar-spec#395 - -/-- Analogous to Spec.getAttr but for partial entities -/ -def getAttr (v : Spec.Value) (a : Attr) (es : Partial.Entities) : Result Partial.Value := do - let r ← Partial.attrsOf v es.attrs - r.findOrErr a attrDoesNotExist - -/-- - Partial-evaluate `pv[a]`. No analogue in Spec.Evaluator; this logic (that sits - between `Partial.evaluate` and `Partial.getAttr`) is not needed in the equivalent - Spec.Evaluator position --/ -def evaluateGetAttr (pv : Partial.Value) (a : Attr) (es : Partial.Entities) : Result Partial.Value := do - match pv with - | .value v₁ => Partial.getAttr v₁ a es - | .residual r => .ok (.residual (.getAttr (.residual r) a)) -- could be more precise; see cedar-spec#395 - -/-- Analogous to Spec.bindAttr but for partial values -/ -def bindAttr (a : Attr) (res : Result Partial.Value) : Result (Attr × Partial.Value) := do - let v ← res - .ok (a, v) - -/-- Partial-evaluate a Var. No analogue in Spec.Evaluator; Spec.evaluate handles the `.var` case inline -/ -def evaluateVar (v : Var) (req : Partial.Request) : Result Partial.Value := - match v with - | .principal => .ok req.principal - | .action => .ok req.action - | .resource => .ok req.resource - | .context => match req.context.mapMOnValues λ v => match v with | .value v => some v | .residual _ => none with - | some m => .ok (.value m) - | none => .ok (.residual (.record req.context.kvs)) - -/-- Call an extension function with partial values as arguments -/ -def evaluateCall (xfn : ExtFun) (args : List Partial.Value) : Result Partial.Value := - match args.mapM (λ pval => match pval with | .value v => some v | .residual _ => none) with - | some vs => do - let val ← Spec.call xfn vs - .ok (.value val) - | none => .ok (.residual (.call xfn args)) - -/-- Analogous to Spec.evaluate but performs partial evaluation given partial request/entities -/ -def evaluate (x : Expr) (req : Partial.Request) (es : Partial.Entities) : Result Partial.Value := - match x with - | .lit l => .ok (.value l) - | .var v => evaluateVar v req - | .ite x₁ x₂ x₃ => do - let pval ← Partial.evaluate x₁ req es - match pval with - | .value v => do - let b ← v.asBool - if b then Partial.evaluate x₂ req es else Partial.evaluate x₃ req es - | .residual r => .ok (.residual (.ite (.residual r) (x₂.substToPartialValue req) (x₃.substToPartialValue req))) - | .and x₁ x₂ => do - let pval ← Partial.evaluate x₁ req es - match pval with - | .value v => do - let b ← v.asBool - if !b then .ok (.value b) else do - let pval ← Partial.evaluate x₂ req es - match pval with - | .value v => do - let b ← v.asBool - .ok (.value b) - | .residual r => .ok (.residual r) - | .residual r => .ok (.residual (.and (.residual r) (x₂.substToPartialValue req))) - | .or x₁ x₂ => do - let pval ← Partial.evaluate x₁ req es - match pval with - | .value v => do - let b ← v.asBool - if b then .ok (.value b) else do - let pval ← Partial.evaluate x₂ req es - match pval with - | .value v => do - let b ← v.asBool - .ok (.value b) - | .residual r => .ok (.residual r) - | .residual r => .ok (.residual (.or (.residual r) (x₂.substToPartialValue req))) - | .unaryApp op₁ x₁ => do - let pval ← Partial.evaluate x₁ req es - evaluateUnaryApp op₁ pval - | .binaryApp op₂ x₁ x₂ => do - let pval₁ ← Partial.evaluate x₁ req es - let pval₂ ← Partial.evaluate x₂ req es - evaluateBinaryApp op₂ pval₁ pval₂ es - | .hasAttr x₁ a => do - let pval₁ ← Partial.evaluate x₁ req es - evaluateHasAttr pval₁ a es - | .getAttr x₁ a => do - let pval₁ ← Partial.evaluate x₁ req es - evaluateGetAttr pval₁ a es - | .set xs => do - let pvs ← xs.mapM₁ (λ ⟨x₁, _⟩ => Partial.evaluate x₁ req es) - match pvs.mapM (λ pval => match pval with | .value v => some v | .residual _ => none) with - | some vs => .ok (.value (Set.make vs)) - | none => .ok (.residual (.set pvs)) - | .record axs => do - let apvs ← axs.mapM₂ (λ ⟨(a₁, x₁), _⟩ => Partial.bindAttr a₁ (Partial.evaluate x₁ req es)) - match apvs.mapM (λ (a, pval) => match pval with | .value v => some (a, v) | .residual _ => none) with - | some avs => .ok (.value (Map.make avs)) - | none => .ok (.residual (.record apvs)) - | .call xfn xs => do - let pvs ← xs.mapM₁ (λ ⟨x₁, _⟩ => Partial.evaluate x₁ req es) - evaluateCall xfn pvs - -mutual - -/-- - Evaluate a `Partial.Value`, possibly reducing it. For instance, `3 + 5` will - evaluate to `8`. This can be relevant if a substitution was recently made on - the `Partial.Value`. --/ -def evaluateValue (pv : Partial.Value) (es : Partial.Entities) : Result Partial.Value := - match pv with - | .value v => .ok (.value v) - | .residual r => evaluateResidual r es - -/-- - Evaluate a `ResidualExpr`, possibly reducing it. For instance, `3 + 5` will - evaluate to `8`. This can be relevant if a substitution was recently made on - the `ResidualExpr`. --/ -def evaluateResidual (x : Partial.ResidualExpr) (es : Partial.Entities) : Result Partial.Value := - match x with - | .unknown u => .ok u - | .ite pv₁ pv₂ pv₃ => do - let pv₁' ← Partial.evaluateValue pv₁ es - match pv₁' with - | .value v₁' => do - let b ← v₁'.asBool - if b then Partial.evaluateValue pv₂ es else Partial.evaluateValue pv₃ es - | .residual r₁' => .ok (.residual (.ite (.residual r₁') pv₂ pv₃)) - | .and pv₁ pv₂ => do - let pv₁' ← Partial.evaluateValue pv₁ es - match pv₁' with - | .value v₁' => do - let b ← v₁'.asBool - if !b then .ok (.value b) else do - let pv₂' ← Partial.evaluateValue pv₂ es - match pv₂' with - | .value v₂' => do - let b ← v₂'.asBool - .ok (.value b) - | .residual r₂' => .ok (.residual r₂') - | .residual r₁' => .ok (.residual (.and (.residual r₁') pv₂)) - | .or pv₁ pv₂ => do - let pv₁' ← Partial.evaluateValue pv₁ es - match pv₁' with - | .value v₁' => do - let b ← v₁'.asBool - if b then .ok (.value b) else do - let pv₂' ← Partial.evaluateValue pv₂ es - match pv₂' with - | .value v₂' => do - let b ← v₂'.asBool - .ok (.value b) - | .residual r₂' => .ok (.residual r₂') - | .residual r₁' => .ok (.residual (.or (.residual r₁') pv₂)) - | .unaryApp op₁ pv₁ => do - let pv₁' ← Partial.evaluateValue pv₁ es - evaluateUnaryApp op₁ pv₁' - | .binaryApp op₂ pv₁ pv₂ => do - let pv₁' ← Partial.evaluateValue pv₁ es - let pv₂' ← Partial.evaluateValue pv₂ es - evaluateBinaryApp op₂ pv₁' pv₂' es - | .hasAttr pv₁ a => do - let pv₁' ← Partial.evaluateValue pv₁ es - evaluateHasAttr pv₁' a es - | .getAttr pv₁ a => do - let pv₁' ← Partial.evaluateValue pv₁ es - evaluateGetAttr pv₁' a es - | .set pvs => do - let pvs' ← pvs.mapM₁ (λ ⟨pv, _⟩ => Partial.evaluateValue pv es) - match pvs'.mapM (λ pv => match pv with | .value v => some v | .residual _ => none) with - | some vs => .ok (.value (Set.make vs)) - | none => .ok (.residual (.set pvs')) - | .record apvs => do - let apvs' ← apvs.mapM₂ (λ ⟨(a, pv), _⟩ => Partial.bindAttr a (Partial.evaluateValue pv es)) - match apvs'.mapM (λ (a, pv) => match pv with | .value v => some (a, v) | .residual _ => none) with - | some avs => .ok (.value (Map.make avs)) - | none => .ok (.residual (.record apvs')) - | .call xfn pvs => do - let pvs' ← pvs.mapM₁ (λ ⟨pv, _⟩ => Partial.evaluateValue pv es) - evaluateCall xfn pvs' - -end - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Partial/Request.lean b/cedar-lean/Cedar/Partial/Request.lean deleted file mode 100644 index cc02850b6..000000000 --- a/cedar-lean/Cedar/Partial/Request.lean +++ /dev/null @@ -1,146 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Value -import Cedar.Spec.Expr -import Cedar.Spec.Request -import Cedar.Spec.Value - -/-! -This file defines Cedar partial requests. --/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Attr EntityUID) - -inductive UidOrUnknown where - | known (uid : EntityUID) - | unknown (u : Unknown) - -deriving instance Repr, DecidableEq, Inhabited for UidOrUnknown - -instance : Coe UidOrUnknown Partial.Value where - coe - | .known uid => .value uid - | .unknown u => u - -structure Request where - principal : UidOrUnknown - action : UidOrUnknown - resource : UidOrUnknown - context : Map Attr Partial.Value -- allows individual context attributes to have unknown values, but does not allow it to be unknown whether a context attribute exists at all - -deriving instance Inhabited for Request - -end Cedar.Partial - -namespace Cedar.Spec - -def Request.asPartialRequest (req : Spec.Request) : Partial.Request := - { - principal := .known req.principal, - action := .known req.action, - resource := .known req.resource, - context := req.context.mapOnValues Partial.Value.value, - } - -instance : Coe Spec.Request Partial.Request where - coe := Spec.Request.asPartialRequest - -end Cedar.Spec - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (EntityUID) - -/-- - Given a `Subsmap`, substitute the unknown in `UidOrUnknown` if possible. If - the `UidOrUnknown` is already known, or it's an unknown that doesn't have a - mapping in `subsmap`, return it unchanged. - - Returns `none` if the substitution is invalid -- e.g., if trying to substitute - a non-`EntityUID` into `UidOrUnknown`. --/ -def UidOrUnknown.subst (subsmap : Subsmap) : UidOrUnknown → Option UidOrUnknown - | .known uid => some (.known uid) - | .unknown unk => match subsmap.m.find? unk with - | some (.value (.prim (.entityUID uid))) => some (.known uid) - | some (.residual (.unknown unk')) => some (.unknown unk') -- substituting an unknown with another unknown, we'll allow it - | none => some (.unknown unk) -- no substitution available, return `unk` unchanged - | _ => none -- substitution is not for a literal UID or literal unknown. Not valid, return none - -/-- - Given a map of unknown-name to value, substitute all unknowns with the - corresponding values, producing a new `Partial.Request`. - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.Request` will still contain some unknowns. - - Returns `none` if the substitution is invalid -- e.g., if trying to substitute - a non-`EntityUID` into `UidOrUnknown`. --/ -def Request.subst (subsmap : Subsmap) : Partial.Request → Option Partial.Request - | { principal, action, resource, context } => do - let principal ← principal.subst subsmap - let action ← action.subst subsmap - let resource ← resource.subst subsmap - let context := context.mapOnValues (Partial.Value.subst subsmap) - some { principal, action, resource, context } - -end Cedar.Partial - -namespace Cedar.Spec - -/-- - Convert an `Expr` to a `Partial.Value` by substituting all of the `.var`s - that appear (either for an unknown or value, as provided in `req`). - - This function does not attempt to constant-fold or reduce after the - substitution (so, e.g., substituting context={ foo: 3 } in `context.foo + 5` - will give `{ foo: 3 }.foo + 5`). - To reduce, use `Partial.evaluateValue`. --/ --- Defined in this file because it needs `Partial.Request` -def Expr.substToPartialValue (req : Partial.Request) : Expr → Partial.Value - | .lit p => .value p - | .var .principal => req.principal - | .var .action => req.action - | .var .resource => req.resource - | .var .context => .residual (.record req.context.kvs) - | .ite x₁ x₂ x₃ => - .residual (.ite (x₁.substToPartialValue req) (x₂.substToPartialValue req) (x₃.substToPartialValue req)) - | .and x₁ x₂ => - .residual (.and (x₁.substToPartialValue req) (x₂.substToPartialValue req)) - | .or x₁ x₂ => - .residual (.or (x₁.substToPartialValue req) (x₂.substToPartialValue req)) - | .unaryApp op x₁ => - .residual (.unaryApp op (x₁.substToPartialValue req)) - | .binaryApp op x₁ x₂ => - .residual (.binaryApp op (x₁.substToPartialValue req) (x₂.substToPartialValue req)) - | .getAttr x₁ attr => - .residual (.getAttr (x₁.substToPartialValue req) attr) - | .hasAttr x₁ attr => - .residual (.hasAttr (x₁.substToPartialValue req) attr) - | .set xs => - .residual (.set (xs.map₁ λ ⟨x, _⟩ => x.substToPartialValue req)) - | .record attrs => - .residual (.record (attrs.attach₂.map λ ⟨(k, v), _⟩ => (k, (v.substToPartialValue req)))) - | .call xfn args => - .residual (.call xfn (args.map₁ λ ⟨x, _⟩ => x.substToPartialValue req)) - -end Cedar.Spec diff --git a/cedar-lean/Cedar/Partial/Response.lean b/cedar-lean/Cedar/Partial/Response.lean deleted file mode 100644 index babb186d1..000000000 --- a/cedar-lean/Cedar/Partial/Response.lean +++ /dev/null @@ -1,276 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Lean.Data.Json.FromToJson -import Cedar.Data.Set -import Cedar.Partial.Evaluator -import Cedar.Partial.Value -import Cedar.Spec.Policy - -/-! -This file defines Cedar partial responses. --/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Partial (Subsmap) -open Cedar.Spec (Effect Error PolicyID) - -/-- The result of partial-evaluating a policy -/ -inductive Residual where - /-- - Some `Partial.Value`, which may be constant `true` (definitely satisfied), - constant `false` (definitely not satisfied), or a nontrivial expression - -/ - | residual (id : PolicyID) (effect : Effect) (condition : Partial.Value) - /-- definitely results in this error, for any substitution of the unknowns -/ - | error (id : PolicyID) (error : Error) - -deriving instance Repr, DecidableEq, Inhabited for Residual - -def Residual.id : Residual → PolicyID - | .residual id _ _ => id - | .error id _ => id - -def Residual.effect : Residual → Option Effect - | .residual _ effect _ => effect - | .error _ _ => none - -/-- - if this policy must be satisfied (for any substitution of the unknowns), and - has the specified effect, return the PolicyID --/ -def Residual.mustBeSatisfied (eff : Effect) : Residual → Option PolicyID - | .residual id eff' (.value true) => if eff = eff' then some id else none - | _ => none - -/-- - if this policy may be satisfied (for some substitution of the unknowns), and - has the specified effect, return the PolicyID --/ -def Residual.mayBeSatisfied (eff : Effect) : Residual → Option PolicyID - | .residual _ _ (.value false) => none - | .residual id eff' _ => if eff = eff' then some id else none - | _ => none - -/-- Response to a partial authorization request -/ -structure Response where - /-- - All residuals for policies that are, or may be, satisfied. - Does not include policies that are definitely not satisfied (residual `false`). - Does include policies that are definitely satisfied (residual `true`). - -/ - residuals : List Residual - /-- - The `Partial.Entities` that was used to compute this `Partial.Response` - -/ - entities : Partial.Entities - -/-- - Get the IDs of all policies which must be satisfied (for all possible - substitutions of the unknowns) and have the given `Effect` --/ -def Response.mustBeSatisfied (resp : Partial.Response) (eff : Effect) : Set PolicyID := - Set.make (resp.residuals.filterMap (Residual.mustBeSatisfied eff)) - -/-- - Get the IDs of all policies which are, or may be, satisfied (for some - possible substitution of the unknowns) and have the given `Effect` --/ -def Response.mayBeSatisfied (resp : Partial.Response) (eff : Effect) : Set PolicyID := - Set.make (resp.residuals.filterMap (Residual.mayBeSatisfied eff)) - -/-- - All `permit` policies which are definitely satisfied (for all possible - substitutions of the unknowns) --/ -def Response.knownPermits (resp : Partial.Response) : Set PolicyID := - resp.mustBeSatisfied .permit - -/-- - All `forbid` policies which are definitely satisfied (for all possible - substitutions of the unknowns) --/ -def Response.knownForbids (resp : Partial.Response) : Set PolicyID := - resp.mustBeSatisfied .forbid - -/-- - All `permit` policies which are, or may be, satisfied --/ -def Response.permits (resp : Partial.Response) : Set PolicyID := - resp.mayBeSatisfied .permit - -/-- - All `forbid` policies which are, or may be, satisfied --/ -def Response.forbids (resp : Partial.Response) : Set PolicyID := - resp.mayBeSatisfied .forbid - -/-- - All policies which definitely produce errors (for all possible substitutions - of the unknowns) --/ -def Response.errorPolicies (resp : Partial.Response) : Set PolicyID := - Set.make (resp.residuals.filterMap λ residual => match residual with - | .error id _ => some id - | _ => none - ) - -inductive Decision where - /-- definitely Allow, for any substitution of the unknowns -/ - | allow - /-- definitely Deny, for any substitution of the unknowns -/ - | deny - /-- Allow and Deny are both possible, depending on substitution of the unknowns -/ - | unknown - -deriving instance Repr, DecidableEq for Decision - -instance : ToString Decision where - toString d := match d with - | .allow => "allow" - | .deny => "deny" - | .unknown => "unknown" - -/-- - Return a `Partial.Decision` representing the authz decision, if it is known - (for instance, if there is a forbid known to be satisfied, or no permits that - are even possibly satisfied), or otherwise `Partial.Decision.unknown` --/ -def Response.decision (resp : Partial.Response) : Partial.Decision := - if ¬ resp.knownForbids.isEmpty then - -- there is a known forbid, we'll always get explicit deny - .deny - else if resp.permits.isEmpty then - -- there are no permits that are even possibly satisfied - .deny - else if resp.forbids.isEmpty && ¬ resp.knownPermits.isEmpty then - -- there are no forbids that are even possibly satisfied, and at least one - -- permit that is definitely satisfied - .allow - else - -- all other cases we cannot know the decision yet. - -- This includes at least two distinct cases: - -- - there's at least one forbid that may be satisfied, and at least one - -- permit that may be (or is) satisfied - -- - there are no forbids that are even possibly satisfied, and at least - -- one permit that may be satisfied, but none known to be satisfied - .unknown - -/-- - All policies which could possibly be determining, given some substitution of - the unknowns --/ -def Response.overapproximateDeterminingPolicies (resp : Partial.Response) : Set PolicyID := - match resp.decision with - | .deny => - -- when the decision is Deny, forbids (if any) are determining. - -- Any forbid that may be satisfied may be determining. - resp.forbids - | .allow => - -- when the decision is Allow, permits (if any) are determining. - -- Any permit that may be satisfied may be determining. - resp.permits - | .unknown => - -- when the decision is Unknown, any permits or forbids could be - -- determining. - resp.permits ∪ resp.forbids - -/-- - All policies that must be determining (for all possible substitutions of the - unknowns) --/ -def Response.underapproximateDeterminingPolicies (resp : Partial.Response) : Set PolicyID := - match resp.decision with - | .deny => - -- when the decision is Deny, forbids (if any) are determining. - -- The only forbids we _know_ will be determining are those that must be - -- satisfied. - resp.knownForbids - | .allow => - -- when the decision is Allow, permits (if any) are determining. - -- The only permits we _know_ will be determining are those that must be - -- satisfied. - resp.knownPermits - | .unknown => - -- when the decision is Unknown, nothing is guaranteed to be determining. - Set.empty - -/-- - Re-evaluate with the given substitution for unknowns, giving a new - `Residual`, or `none` if the residual is now `false`. - - Assumes that `entities` have already been substituted. --/ -def Residual.reEvaluateWithSubst (subsmap : Subsmap) (entities : Partial.Entities) : Residual → Option Residual - | .error id e => some (.error id e) - | .residual id effect cond => - match Partial.evaluateValue (cond.subst subsmap) entities with - | .ok (.value false) => none - | .ok (.value v) => some (.residual id effect v) - | .ok cond' => some (.residual id effect cond') - | .error e => some (.error id e) - -/-- - Re-evaluate with the given substitution for unknowns, giving a new - `Partial.Response`. - - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.Response` will still contain some (nontrivial) residuals. - - Respects the invariant documented on `Partial.Response.residuals` that: - - `.residuals` will not include policies that are definitely not satisfied - (residual `false`). - - `.residuals` will include policies that are definitely satisfied (residual - `true`). --/ -def Response.reEvaluateWithSubst (subsmap : Subsmap) : Partial.Response → Partial.Response - | { residuals, entities } => - let entities' := entities.subst subsmap - { - residuals := residuals.filterMap (Residual.reEvaluateWithSubst subsmap entities') - entities := entities' - } - -private structure JSONResponse where - knownPermits : List String - knownForbids : List String - mayBeSatisifedPermits : List String - mayBeSatisifedForbids : List String - decision : String - determiningUnderApprox : List String - determiningOverApprox : List String - deriving Lean.ToJson - -instance : Coe Response JSONResponse where - coe r := { - knownPermits := r.knownPermits.toList - knownForbids := r.knownForbids.toList - mayBeSatisifedPermits := (r.mayBeSatisfied .permit).toList - mayBeSatisifedForbids := (r.mayBeSatisfied .forbid).toList - decision := toString r.decision - determiningOverApprox := r.overapproximateDeterminingPolicies.toList - determiningUnderApprox := r.underapproximateDeterminingPolicies.toList - : JSONResponse - } - -instance : Lean.ToJson Response where - toJson r := - let json_r : JSONResponse := r - Lean.toJson json_r - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Partial/Value.lean b/cedar-lean/Cedar/Partial/Value.lean deleted file mode 100644 index da291934e..000000000 --- a/cedar-lean/Cedar/Partial/Value.lean +++ /dev/null @@ -1,244 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Spec.Expr -import Cedar.Spec.Value - -/-! - This file defines Cedar partial values and substitutions. --/ - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Attr BinaryOp ExtFun UnaryOp) - --- Unknowns are currently represented by a string name -abbrev Unknown := String - -mutual - -/-- - `Partial.Value` represents the result of partial-evaluating an expression. - If you flatten `Partial.ResidualExpr` into this definition, it's very close to - `Expr`, but can contain `Unknown`s, and also cannot contain `.var` (those - will be substituted either by values or unknowns). --/ -inductive Value where - | value (v : Spec.Value) - | residual (r : ResidualExpr) -deriving Repr, Inhabited - -/-- - Represents a residual expression (other than a concrete value). - Very similar to `Expr` but with an `.unknown` case, without the `.lit` - case, and without the `.var` case (during evaluation, all vars will be - substituted either by values or unknowns). --/ -inductive ResidualExpr where - | unknown (u : Unknown) - | ite (cond : Partial.Value) (thenValue : Partial.Value) (elseValue : Partial.Value) - | and (lhs : Partial.Value) (rhs : Partial.Value) - | or (lhs : Partial.Value) (rhs : Partial.Value) - | unaryApp (op : UnaryOp) (pv : Partial.Value) - | binaryApp (op : BinaryOp) (pv₁ : Partial.Value) (pv₂ : Partial.Value) - | getAttr (pv : Partial.Value) (attr : Attr) - | hasAttr (pv : Partial.Value) (attr : Attr) - | set (pvs : List Partial.Value) - | record (map : List (Attr × Partial.Value)) - | call (xfn : ExtFun) (pvs : List Partial.Value) -deriving Repr, Inhabited - -end - -instance : Coe Spec.Value Partial.Value where - coe := Partial.Value.value - -instance : Coe Unknown ResidualExpr where - coe := ResidualExpr.unknown - -instance : Coe Unknown Partial.Value where - coe u := .residual (.unknown u) - -end Cedar.Partial - -namespace Cedar.Spec - -/-- - Convert an `Expr` to `Partial.Value`, if possible (i.e., if the - `Expr` does not contain any `.var`). - - This function does not attempt to constant-fold or reduce (so, e.g., - converting the expression `3 + 5` will give the partial value `3 + 5`). - To reduce, use `Partial.evaluateValue`. - - Also, consider using `Expr.substToPartialValue` instead. --/ -def Expr.asPartialValue : Expr → Option Partial.Value - | .lit p => some (.value p) - | .var _ => none - | .ite x₁ x₂ x₃ => do - some (.residual (.ite (← x₁.asPartialValue) (← x₂.asPartialValue) (← x₃.asPartialValue))) - | .and x₁ x₂ => do - some (.residual (.and (← x₁.asPartialValue) (← x₂.asPartialValue))) - | .or x₁ x₂ => do - some (.residual (.or (← x₁.asPartialValue) (← x₂.asPartialValue))) - | .unaryApp op x₁ => do - some (.residual (.unaryApp op (← x₁.asPartialValue))) - | .binaryApp op x₁ x₂ => do - some (.residual (.binaryApp op (← x₁.asPartialValue) (← x₂.asPartialValue))) - | .getAttr x₁ attr => do - some (.residual (.getAttr (← x₁.asPartialValue) attr)) - | .hasAttr x₁ attr => do - some (.residual (.hasAttr (← x₁.asPartialValue) attr)) - | .set xs => do - some (.residual (.set (← xs.mapM₁ λ ⟨x, _⟩ => x.asPartialValue))) - | .record attrs => do - some (.residual (.record (← attrs.attach₂.mapM λ ⟨(k, v), _⟩ => do some (k, (← v.asPartialValue))))) - | .call xfn args => do - some (.residual (.call xfn (← args.mapM₁ λ ⟨x, _⟩ => x.asPartialValue))) - -end Cedar.Spec - -namespace Cedar.Partial - -open Cedar.Data -open Cedar.Spec (Attr BinaryOp ExtFun Prim UnaryOp Var) - -mutual - -def decPartialValue (x y : Partial.Value) : Decidable (x = y) := by - cases x <;> cases y <;> - try { apply isFalse ; intro h ; injection h } - case value.value x₁ y₁ => - exact match decEq x₁ y₁ with - | isTrue h => isTrue (by rw [h]) - | isFalse _ => isFalse (by intro h; injection h; contradiction) - case residual.residual x₁ y₁ => - exact match decResidualExpr x₁ y₁ with - | isTrue h => isTrue (by rw [h]) - | isFalse _ => isFalse (by intro h; injection h; contradiction) - -def decResidualExpr (x y : Partial.ResidualExpr) : Decidable (x = y) := by - cases x <;> cases y <;> - try { apply isFalse ; intro h ; injection h } - case unknown.unknown x₁ y₁ => - exact match decEq x₁ y₁ with - | isTrue h => isTrue (by rw [h]) - | isFalse _ => isFalse (by intro h; injection h; contradiction) - case ite.ite x₁ x₂ x₃ y₁ y₂ y₃ => - exact match decPartialValue x₁ y₁, decPartialValue x₂ y₂, decPartialValue x₃ y₃ with - | isTrue h₁, isTrue h₂, isTrue h₃ => isTrue (by rw [h₁, h₂, h₃]) - | isFalse _, _, _ | _, isFalse _, _ | _, _, isFalse _ => isFalse (by intro h; injection h; contradiction) - case and.and x₁ x₂ y₁ y₂ | or.or x₁ x₂ y₁ y₂ => - exact match decPartialValue x₁ y₁, decPartialValue x₂ y₂ with - | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) - | isFalse _, _ | _, isFalse _ => isFalse (by intro h; injection h; contradiction) - case unaryApp.unaryApp o x₁ o' y₁ => - exact match decEq o o', decPartialValue x₁ y₁ with - | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) - | isFalse _, _ | _, isFalse _ => isFalse (by intro h; injection h; contradiction) - case binaryApp.binaryApp o x₁ x₂ o' y₁ y₂ => - exact match decEq o o', decPartialValue x₁ y₁, decPartialValue x₂ y₂ with - | isTrue h₁, isTrue h₂, isTrue h₃ => isTrue (by rw [h₁, h₂, h₃]) - | isFalse _, _, _ | _, isFalse _, _ | _, _, isFalse _ => isFalse (by intro h; injection h; contradiction) - case getAttr.getAttr x₁ a y₁ a' | hasAttr.hasAttr x₁ a y₁ a' => - exact match decPartialValue x₁ y₁, decEq a a' with - | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) - | isFalse _, _ | _, isFalse _ => isFalse (by intro h; injection h; contradiction) - case set.set xs ys => - exact match decPartialValueList xs ys with - | isTrue h₁ => isTrue (by rw [h₁]) - | isFalse _ => isFalse (by intro h; injection h; contradiction) - case record.record axs ays => - exact match decProdAttrPartialValueList axs ays with - | isTrue h₁ => isTrue (by rw [h₁]) - | isFalse _ => isFalse (by intro h; injection h; contradiction) - case call.call f xs f' ys => - exact match decEq f f', decPartialValueList xs ys with - | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) - | isFalse _, _ | _, isFalse _ => isFalse (by intro h; injection h; contradiction) - -def decProdAttrPartialValueList (axs ays : List (Attr × Partial.Value)) : Decidable (axs = ays) := - match axs, ays with - | [], [] => isTrue rfl - | _::_, [] | [], _::_ => isFalse (by intro; contradiction) - | (a, x)::axs, (a', y)::ays => - match decEq a a', decPartialValue x y, decProdAttrPartialValueList axs ays with - | isTrue h₁, isTrue h₂, isTrue h₃ => isTrue (by rw [h₁, h₂, h₃]) - | isFalse _, _, _ | _, isFalse _, _ | _, _, isFalse _ => - isFalse (by simp; intros; first | contradiction | assumption) - -def decPartialValueList (xs ys : List Partial.Value) : Decidable (xs = ys) := - match xs, ys with - | [], [] => isTrue rfl - | _::_, [] | [], _::_ => isFalse (by intro; contradiction) - | x::xs, y::ys => - match decPartialValue x y, decPartialValueList xs ys with - | isTrue h₁, isTrue h₂ => isTrue (by rw [h₁, h₂]) - | isFalse _, _ | _, isFalse _ => isFalse (by intro h; injection h; contradiction) -end - -instance : DecidableEq Partial.Value := decPartialValue -instance : DecidableEq Partial.ResidualExpr := decResidualExpr - -/-- - Defines a mapping from unknowns to the `Partial.Value`s to replace them with - during a substitution. --/ -structure Subsmap where - m : Map Unknown Partial.Value - -mutual - -/-- - Given a map of unknown-name to value, substitute all unknowns with the - corresponding values, producing a new `Partial.Value`. - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.Value` will still contain some unknowns. --/ -def Value.subst (subsmap : Subsmap) : Partial.Value → Partial.Value - | .value v => .value v -- doesn't contain unknowns, nothing to substitute - | .residual r => r.subst subsmap - -/-- - Given a map of unknown-name to value, substitute all unknowns with the - corresponding values, producing a `Partial.Value`. - It's fine for some unknowns to not be in `subsmap`, in which case the returned - `Partial.Value` will still contain some unknowns. - - This function does not attempt to constant-fold or reduce after the substitution - (so, e.g., substituting u=5 in `3 + u` will give `3 + 5`). - To reduce, use `Partial.evaluateValue`. --/ -def ResidualExpr.subst (subsmap : Subsmap) : ResidualExpr → Partial.Value - | .unknown u => match subsmap.m.find? u with - | some pv => pv - | none => .residual (.unknown u) -- no substitution available - | .ite pv₁ pv₂ pv₃ => .residual (.ite (pv₁.subst subsmap) (pv₂.subst subsmap) (pv₃.subst subsmap)) - | .and pv₁ pv₂ => .residual (.and (pv₁.subst subsmap) (pv₂.subst subsmap)) - | .or pv₁ pv₂ => .residual (.or (pv₁.subst subsmap) (pv₂.subst subsmap)) - | .unaryApp op pv₁ => .residual (.unaryApp op (pv₁.subst subsmap)) - | .binaryApp op pv₁ pv₂ => .residual (.binaryApp op (pv₁.subst subsmap) (pv₂.subst subsmap)) - | .getAttr pv₁ attr => .residual (.getAttr (pv₁.subst subsmap) attr) - | .hasAttr pv₁ attr => .residual (.hasAttr (pv₁.subst subsmap) attr) - | .set pvs => .residual (.set (pvs.map₁ λ ⟨x, _⟩ => x.subst subsmap)) - | .record pairs => .residual (.record (pairs.attach₂.map λ ⟨(k, v), _⟩ => (k, v.subst subsmap))) - | .call xfn pvs => .residual (.call xfn (pvs.map₁ λ ⟨x, _⟩ => x.subst subsmap)) - -end - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Spec/Entities.lean b/cedar-lean/Cedar/Spec/Entities.lean index 1e0ff7a77..026bf28b6 100644 --- a/cedar-lean/Cedar/Spec/Entities.lean +++ b/cedar-lean/Cedar/Spec/Entities.lean @@ -26,9 +26,12 @@ open Cedar.Data ----- Definitions ----- +abbrev Tag := String + structure EntityData where attrs : Map Attr Value ancestors : Set EntityUID + tags : Map Tag Value abbrev Entities := Map EntityUID EntityData @@ -50,6 +53,15 @@ def Entities.attrsOrEmpty (es : Entities) (uid : EntityUID) : Map Attr Value := | some d => d.attrs | none => Map.empty +def Entities.tags (es : Entities) (uid : EntityUID) : Result (Map Tag Value) := do + let d ← es.findOrErr uid .entityDoesNotExist + .ok d.tags + +def Entities.tagsOrEmpty (es : Entities) (uid : EntityUID) : Map Tag Value := + match es.find? uid with + | some d => d.tags + | none => Map.empty + ----- Derivations ----- deriving instance Repr, DecidableEq, Inhabited for EntityData diff --git a/cedar-lean/Cedar/Spec/Evaluator.lean b/cedar-lean/Cedar/Spec/Evaluator.lean index eb6badf7e..07d08239a 100644 --- a/cedar-lean/Cedar/Spec/Evaluator.lean +++ b/cedar-lean/Cedar/Spec/Evaluator.lean @@ -44,6 +44,12 @@ def inₛ (uid : EntityUID) (vs : Set Value) (es : Entities) : Result Value := d let uids ← vs.mapOrErr Value.asEntityUID .typeError .ok (uids.any (inₑ uid · es)) +def hasTag (uid : EntityUID) (tag : String) (es : Entities) : Result Value := + .ok ((es.tagsOrEmpty uid).contains tag) + +def getTag (uid : EntityUID) (tag : String) (es : Entities) : Result Value := do + (← es.tags uid).findOrErr tag .tagDoesNotExist + def apply₂ (op₂ : BinaryOp) (v₁ v₂ : Value) (es : Entities) : Result Value := match op₂, v₁, v₂ with | .eq, _, _ => .ok (v₁ == v₂) @@ -57,6 +63,8 @@ def apply₂ (op₂ : BinaryOp) (v₁ v₂ : Value) (es : Entities) : Result Val | .containsAny, .set vs₁, .set vs₂ => .ok (vs₁.intersects vs₂) | .mem, .prim (.entityUID uid₁), .prim (.entityUID uid₂) => .ok (inₑ uid₁ uid₂ es) | .mem, .prim (.entityUID uid₁), .set (vs) => inₛ uid₁ vs es + | .hasTag, .prim (.entityUID uid₁), .prim (.string tag) => hasTag uid₁ tag es + | .getTag, .prim (.entityUID uid₁), .prim (.string tag) => getTag uid₁ tag es | _, _, _ => .error .typeError def attrsOf (v : Value) (lookup : EntityUID → Result (Map Attr Value)) : Result (Map Attr Value) := diff --git a/cedar-lean/Cedar/Spec/Expr.lean b/cedar-lean/Cedar/Spec/Expr.lean index 62a9a161e..e3d944dde 100644 --- a/cedar-lean/Cedar/Spec/Expr.lean +++ b/cedar-lean/Cedar/Spec/Expr.lean @@ -42,6 +42,8 @@ inductive UnaryOp where inductive BinaryOp where | eq | mem -- represents Cedar's in operator + | hasTag + | getTag | less | lessEq | add diff --git a/cedar-lean/Cedar/Spec/Value.lean b/cedar-lean/Cedar/Spec/Value.lean index b4207f436..a8822d7fd 100644 --- a/cedar-lean/Cedar/Spec/Value.lean +++ b/cedar-lean/Cedar/Spec/Value.lean @@ -28,6 +28,7 @@ open Cedar.Data inductive Error where | entityDoesNotExist | attrDoesNotExist + | tagDoesNotExist | typeError | arithBoundsError | extensionError diff --git a/cedar-lean/Cedar/Thm.lean b/cedar-lean/Cedar/Thm.lean index 6a298decf..b5eb19c61 100644 --- a/cedar-lean/Cedar/Thm.lean +++ b/cedar-lean/Cedar/Thm.lean @@ -15,6 +15,6 @@ -/ import Cedar.Thm.Authorization -import Cedar.Thm.Partial import Cedar.Thm.Slicing import Cedar.Thm.Typechecking +import Cedar.Thm.Validation diff --git a/cedar-lean/Cedar/Thm/Data/List/Lemmas.lean b/cedar-lean/Cedar/Thm/Data/List/Lemmas.lean index 89e85ba91..57e536ba0 100644 --- a/cedar-lean/Cedar/Thm/Data/List/Lemmas.lean +++ b/cedar-lean/Cedar/Thm/Data/List/Lemmas.lean @@ -1266,4 +1266,17 @@ theorem length_removeAll_le {α : Type u_1} [BEq α] (xs ys : List α) : have _ := List.length_filter_le (fun x => !elem x ys) xs omega +/- #### Mem -/ + +theorem mem_pmap_subtype + {p : α → Prop} + (as : List α) + (h : ∀ a, a ∈ as → p a) + (a : α) + (ha : p a) : + ⟨a, ha⟩ ∈ (List.pmap Subtype.mk as h) ↔ + a ∈ as +:= by + induction as <;> simp [*] + end List diff --git a/cedar-lean/Cedar/Thm/Partial.lean b/cedar-lean/Cedar/Thm/Partial.lean deleted file mode 100644 index a30935bee..000000000 --- a/cedar-lean/Cedar/Thm/Partial.lean +++ /dev/null @@ -1,19 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Thm.Partial.Authorization -import Cedar.Thm.Partial.Evaluation -import Cedar.Thm.Partial.Subst diff --git a/cedar-lean/Cedar/Thm/Partial/Authorization.lean b/cedar-lean/Cedar/Thm/Partial/Authorization.lean deleted file mode 100644 index 91986684d..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Authorization.lean +++ /dev/null @@ -1,172 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Authorizer -import Cedar.Partial.Response -import Cedar.Spec.Authorizer -import Cedar.Spec.Response -import Cedar.Thm.Authorization.Authorizer -import Cedar.Thm.Partial.Authorization.PartialOnConcrete -import Cedar.Thm.Partial.Authorization.PartialResponse - -/-! This file contains toplevel theorems about Cedar's partial authorizer. -/ - -namespace Cedar.Thm.Partial.Authorization - -open Cedar.Data -open Cedar.Spec (Policies PolicyID) - -/-- - Partial-authorizing with concrete inputs gives the same concrete decision as - concrete-authorizing with those inputs. --/ -theorem partial_authz_decision_eqv_authz_decision_on_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {presp : Partial.Response} {resp : Spec.Response} - (wf : req.context.WellFormed) : - Spec.isAuthorized req entities policies = resp → - Partial.isAuthorized req entities policies = presp → - (resp.decision = .allow ∧ presp.decision = .allow) ∨ (resp.decision = .deny ∧ presp.decision = .deny) -:= by - intro h₁ h₂ - subst h₁ h₂ - simp only [Spec.isAuthorized, Partial.Response.decision, Bool.and_eq_true, Bool.not_eq_true', - Bool.not_eq_true, Bool.decide_eq_false, ite_eq_left_iff, Bool.not_eq_false] - simp only [PartialOnConcrete.knownForbids_eq_forbids wf] - simp only [PartialOnConcrete.forbids_eq_satisfied_forbids wf] - cases h₁ : (Spec.satisfiedPolicies .forbid policies req entities).isEmpty - <;> simp only [false_and, true_and, and_self, or_true, false_implies, forall_const, reduceIte] - case true => - simp only [PartialOnConcrete.permits_eq_satisfied_permits wf] - simp only [PartialOnConcrete.knownPermits_eq_permits wf] - cases h₂ : (Spec.satisfiedPolicies .permit policies req entities).isEmpty - case false => simp [h₂, PartialOnConcrete.permits_eq_satisfied_permits wf] - case true => simp [h₁, h₂, PartialOnConcrete.permits_eq_satisfied_permits wf] - -/-- - Corollary to the above: partial-authorizing with concrete inputs gives a - concrete decision. --/ -theorem partial_authz_on_concrete_gives_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).decision ≠ .unknown -:= by - intro h₁ - have h₂ := partial_authz_decision_eqv_authz_decision_on_concrete (policies := policies) (req := req) (entities := entities) (presp := Partial.isAuthorized req entities policies) (resp := Spec.isAuthorized req entities policies) wf - simp only [forall_const] at h₂ - cases h₃ : (Spec.isAuthorized req entities policies).decision - <;> simp only [h₃, true_and, false_and, or_false, false_or] at h₂ - <;> simp only [h₂] at h₁ - -/-- - On concrete inputs, partial authorization's `overapproximateDeterminingPolicies` - are identical to concrete authorization's `determiningPolicies` --/ -theorem overapproximate_determining_eqv_determining_on_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {presp : Partial.Response} {resp : Spec.Response} - (wf : req.context.WellFormed) : - Spec.isAuthorized req entities policies = resp → - Partial.isAuthorized req entities policies = presp → - presp.overapproximateDeterminingPolicies = resp.determiningPolicies -:= by - intro h₁ h₂ - subst h₁ h₂ - rw [← Set.eq_means_eqv Partial.Response.overapproximateDeterminingPolicies_wf determiningPolicies_wf] - simp only [List.Equiv, List.subset_def] - simp only [Partial.Response.overapproximateDeterminingPolicies, Spec.isAuthorized] - simp only [Partial.Response.decision] - simp only [PartialOnConcrete.knownForbids_eq_forbids wf] - simp only [PartialOnConcrete.knownPermits_eq_permits wf] - simp only [PartialOnConcrete.forbids_eq_satisfied_forbids wf] - simp only [PartialOnConcrete.permits_eq_satisfied_permits wf] - constructor <;> intro pid h₁ - <;> rw [Set.in_list_iff_in_set] at * - <;> cases h₂ : (Spec.satisfiedPolicies .forbid policies req entities).isEmpty - <;> simp only [not_true_eq_false, ↓reduceIte, Bool.not_eq_true, Bool.decide_eq_false, - Bool.true_and, Bool.false_and, Bool.not_eq_true'] - <;> simp only [h₂] at h₁ - case left.false | right.false => simpa using h₁ - case left.true | right.true => - cases h₃ : (Spec.satisfiedPolicies .permit policies req entities).isEmpty - <;> simpa [h₃] using h₁ - -/-- - On concrete inputs, partial authorization's `underapproximateDeterminingPolicies` - are identical to concrete authorization's `determiningPolicies` --/ -theorem underapproximate_determining_eqv_determining_on_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {presp : Partial.Response} {resp : Spec.Response} - (wf : req.context.WellFormed) : - Spec.isAuthorized req entities policies = resp → - Partial.isAuthorized req entities policies = presp → - presp.underapproximateDeterminingPolicies = resp.determiningPolicies -:= by - intro h₁ h₂ - subst h₁ h₂ - rw [← Set.eq_means_eqv Partial.Response.underapproximateDeterminingPolicies_wf determiningPolicies_wf] - simp only [List.Equiv, List.subset_def] - simp only [Partial.Response.underapproximateDeterminingPolicies, Spec.isAuthorized] - simp only [Partial.Response.decision] - simp only [PartialOnConcrete.knownForbids_eq_forbids wf] - simp only [PartialOnConcrete.knownPermits_eq_permits wf] - simp only [PartialOnConcrete.forbids_eq_satisfied_forbids wf] - simp only [PartialOnConcrete.permits_eq_satisfied_permits wf] - constructor <;> intro pid h₁ - <;> rw [Set.in_list_iff_in_set] at * - <;> cases h₂ : (Spec.satisfiedPolicies .forbid policies req entities).isEmpty - <;> simp only [not_true_eq_false, ↓reduceIte, Bool.not_eq_true, Bool.decide_eq_false, - Bool.true_and, Bool.false_and, Bool.not_eq_true'] - <;> simp only [h₂] at h₁ - case left.false | right.false => simpa using h₁ - case left.true | right.true => - cases h₃ : (Spec.satisfiedPolicies .permit policies req entities).isEmpty - <;> simpa [h₃] using h₁ - -/-- - On concrete inputs, partial authorization's `errorPolicies` are the same - policies as concrete authorization's `erroringPolicies` --/ -theorem partial_authz_errorPolicies_eqv_erroringPolicies_on_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {presp : Partial.Response} {resp : Spec.Response} - (wf : req.context.WellFormed) : - Spec.isAuthorized req entities policies = resp → - Partial.isAuthorized req entities policies = presp → - presp.errorPolicies = resp.erroringPolicies -:= by - intro h₁ h₂ - subst h₁ h₂ - simp only [Spec.isAuthorized, Bool.and_eq_true, Bool.not_eq_true'] - cases (Spec.satisfiedPolicies .forbid policies req entities).isEmpty <;> - cases (Spec.satisfiedPolicies .permit policies req entities).isEmpty <;> - simp only [and_true, and_false, ite_true, ite_false] <;> - exact PartialOnConcrete.errorPolicies_eq_errorPolicies wf - -/-- - Partial-authorizing with concrete inputs gives the same concrete outputs as - concrete-authorizing with those inputs. --/ -theorem partial_authz_eqv_authz_on_concrete {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {presp : Partial.Response} {resp : Spec.Response} - (wf : req.context.WellFormed) : -- interestingly, this theorem only requires that the context is a WellFormed map, not that the entities are well-formed or that the context values are well-formed - Spec.isAuthorized req entities policies = resp → - Partial.isAuthorized req entities policies = presp → - (resp.decision = .allow ∧ presp.decision = .allow ∨ resp.decision = .deny ∧ presp.decision = .deny) ∧ - presp.overapproximateDeterminingPolicies = resp.determiningPolicies ∧ - presp.underapproximateDeterminingPolicies = resp.determiningPolicies ∧ - presp.errorPolicies = resp.erroringPolicies -:= by - intro h₁ h₂ - and_intros - · exact partial_authz_decision_eqv_authz_decision_on_concrete wf h₁ h₂ - · exact overapproximate_determining_eqv_determining_on_concrete wf h₁ h₂ - · exact underapproximate_determining_eqv_determining_on_concrete wf h₁ h₂ - · exact partial_authz_errorPolicies_eqv_erroringPolicies_on_concrete wf h₁ h₂ - -end Cedar.Thm.Partial.Authorization diff --git a/cedar-lean/Cedar/Thm/Partial/Authorization/PartialOnConcrete.lean b/cedar-lean/Cedar/Thm/Partial/Authorization/PartialOnConcrete.lean deleted file mode 100644 index 12728a342..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Authorization/PartialOnConcrete.lean +++ /dev/null @@ -1,234 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Spec.Authorizer -import Cedar.Spec.Entities -import Cedar.Spec.Request -import Cedar.Partial.Authorizer -import Cedar.Partial.Response -import Cedar.Thm.Authorization.Evaluator -import Cedar.Thm.Partial.Evaluation -import Cedar.Thm.Partial.WellFormed - -/-! - This file contains lemmas about the behavior of partial authorization on - concrete inputs. - - The toplevel theorems (proved using these lemmas) are in - Thm/Partial/Authorization.lean, not this file. --/ - -namespace Cedar.Thm.Partial.Authorization.PartialOnConcrete - -open Cedar.Data -open Cedar.Partial (Residual) -open Cedar.Spec (Effect Policies PolicyID) - -/-- - on concrete inputs, `Partial.Response.mayBeSatisfied` is equal to - `Spec.satisfiedPolicies` --/ -theorem mayBeSatisfied_eq_satisfiedPolicies {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {eff : Effect} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).mayBeSatisfied eff = Spec.satisfiedPolicies eff policies req entities -:= by - unfold Partial.Response.mayBeSatisfied Spec.satisfiedPolicies Spec.satisfiedWithEffect Spec.satisfied Partial.isAuthorized - simp only [List.filterMap_filterMap, Bool.and_eq_true, beq_iff_eq, decide_eq_true_eq] - simp only [Partial.Evaluation.Evaluate.on_concrete_eqv_concrete_eval _ req entities wf, Except.map] - simp only [Set.make_make_eqv, List.Equiv, List.subset_def] - simp only [List.mem_filterMap, Option.bind_eq_some, ite_some_none_eq_some, forall_exists_index, and_imp] - constructor <;> intro pid policy h₁ - case left => - intro r h₂ h₃ - exists policy - apply And.intro h₁ - split at h₂ <;> simp only [Option.some.injEq] at h₂ - <;> subst h₂ - <;> simp only [Residual.mayBeSatisfied] at h₃ - <;> split at h₃ <;> simp only [Option.some.injEq] at h₃ - <;> rename_i h₂ h₄ - <;> subst eff pid - <;> split at h₂ <;> simp only [Except.ok.injEq, Partial.Value.value.injEq] at h₂ - subst h₂ - rename_i v h₂ h₃ - simp only [h₂, Except.ok.injEq, true_and, and_true] - simp only [Partial.Value.value.injEq, imp_false] at h₃ - have h₄ := policy_produces_bool_or_error policy req entities - simp only [h₂, Bool.false_eq_true] at h₄ - split at h₄ <;> rename_i h₅ <;> simp only [Except.ok.injEq, imp_self, implies_true] at h₅ - <;> try contradiction - subst h₅ ; simp only [Spec.Value.prim.injEq, Spec.Prim.bool.injEq] - simp only [Spec.Value.prim.injEq, Spec.Prim.bool.injEq] at h₃ - simp only [h₃] - case right => - intro h₂ h₃ h₄ - subst h₂ h₄ - exists policy - apply And.intro h₁ - simp only [h₃, Residual.mayBeSatisfied, Option.some.injEq, exists_eq_left', reduceIte] - -/-- - corollary of the above --/ -theorem permits_eq_satisfied_permits {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).permits = Spec.satisfiedPolicies .permit policies req entities -:= by - unfold Partial.Response.permits - simp [mayBeSatisfied_eq_satisfiedPolicies (eff := .permit) wf] - -/-- - corollary of the above --/ -theorem forbids_eq_satisfied_forbids {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).forbids = Spec.satisfiedPolicies .forbid policies req entities -:= by - unfold Partial.Response.forbids - simp [mayBeSatisfied_eq_satisfiedPolicies (eff := .forbid) wf] - -/-- - on concrete inputs, the `cond` of all residuals is literal `true` --/ -theorem all_residuals_are_true_residuals {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {id : PolicyID} {eff : Effect} {cond : Partial.Value} - (wf : req.context.WellFormed) : - (Residual.residual id eff cond) ∈ (Partial.isAuthorized req entities policies).residuals → - cond = .value true -:= by - unfold Partial.isAuthorized - simp only [Partial.Evaluation.Evaluate.on_concrete_eqv_concrete_eval _ req entities wf, Except.map, - List.mem_filterMap, forall_exists_index, and_imp] - intro policy _ - have h₂ := policy_produces_bool_or_error (p := policy) (request := req) (entities := entities) - split at h₂ <;> simp only at h₂ - · rename_i b h₃ - simp only [h₃] - split <;> simp only [Option.some.injEq, Residual.residual.injEq, and_imp, false_implies] - · rename_i pv h₄ h₅ - intro h₁ h₆ h₇ ; subst h₁ h₆ h₇ - simp only [Except.ok.injEq, Partial.Value.value.injEq] at h₅ - subst h₅ - match b with - | true => rfl - | false => simp only [forall_const] at h₄ - · rename_i e h₃ ; simp only [h₃, Option.some.injEq, false_implies] - -/-- - on concrete inputs, `mustBeSatisfied` and `mayBeSatisfied` are the same --/ -theorem mustBeSatisfied_eq_mayBeSatisfied {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} {eff : Effect} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).mustBeSatisfied eff = - (Partial.isAuthorized req entities policies).mayBeSatisfied eff -:= by - simp only [Partial.Response.mustBeSatisfied, Partial.Response.mayBeSatisfied] - rw [Set.make_make_eqv] - unfold List.Equiv - simp only [Residual.mustBeSatisfied, Residual.mayBeSatisfied, List.subset_def, - List.mem_filterMap, forall_exists_index, and_imp] - constructor <;> intro pid r h₁ h₂ - case left => - exists r - apply And.intro h₁ - split at h₂ <;> simp only [ite_some_none_eq_some] at h₂ - case h_1 r pid' eff' => - replace ⟨h₂, h₂'⟩ := h₂ - subst pid' eff' - simp only [reduceIte] - case right => - exists r - apply And.intro h₁ - split at h₂ <;> simp only [ite_some_none_eq_some] at h₂ - case h_2 r pid' eff' cond h₃ => - replace ⟨h₂, h₂'⟩ := h₂ - subst pid' eff' - split <;> simp only [ite_some_none_eq_some] <;> rename_i h₄ - · simp only [Residual.residual.injEq] at h₄ - exact And.intro h₄.right.left h₄.left.symm - · apply h₄ pid eff ; clear h₄ - have h₂ := all_residuals_are_true_residuals wf h₁ - subst h₂ - rfl - -/-- - corollary of the above --/ -theorem knownPermits_eq_permits {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).knownPermits = (Partial.isAuthorized req entities policies).permits -:= by - unfold Partial.Response.knownPermits Partial.Response.permits - apply mustBeSatisfied_eq_mayBeSatisfied (eff := .permit) wf - -/-- - corollary of the above --/ -theorem knownForbids_eq_forbids {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).knownForbids = (Partial.isAuthorized req entities policies).forbids -:= by - unfold Partial.Response.knownForbids Partial.Response.forbids - apply mustBeSatisfied_eq_mayBeSatisfied (eff := .forbid) wf - -/-- - on concrete inputs, `Partial.Response.errorPolicies` and `Spec.errorPolicies` are equal --/ -theorem errorPolicies_eq_errorPolicies {policies : Policies} {req : Spec.Request} {entities : Spec.Entities} - (wf : req.context.WellFormed) : - (Partial.isAuthorized req entities policies).errorPolicies = - Spec.errorPolicies policies req entities -:= by - unfold Spec.errorPolicies Partial.Response.errorPolicies - rw [Set.make_make_eqv] - simp only [List.Equiv, List.map_filterMap, List.subset_def, List.mem_filterMap, - Option.map_eq_some', forall_exists_index, and_imp] - constructor - case left => - intro pid r h₁ h₂ - cases r <;> simp only [Option.some.injEq] at h₂ - case error pid' e => - subst pid' - simp only [Partial.isAuthorized, Spec.errored, Spec.hasError, - List.mem_filterMap, ite_some_none_eq_some] at * - replace ⟨policy, h₁, h₂⟩ := h₁ - exists policy - apply And.intro h₁ - simp only [Partial.Evaluation.Evaluate.on_concrete_eqv_concrete_eval _ req entities wf] at h₂ - split <;> split at h₂ - <;> simp only [Option.some.injEq, Residual.error.injEq] at h₂ - <;> try simp only [h₂, and_true, and_self] - case h_1.h_3 h₃ _ e h₄ => simp only [h₃, Except.map] at h₄ - case right => - intro pid policy h₁ h₂ - unfold Spec.errored Spec.hasError at h₂ - simp only [ite_some_none_eq_some] at h₂ - replace ⟨h₂, h₂'⟩ := h₂ - subst pid - split at h₂ <;> simp only at h₂ - case h_2 e h₃ => - exists (.error policy.id e) - simp only [and_true] - unfold Partial.isAuthorized - simp only [Partial.Evaluation.Evaluate.on_concrete_eqv_concrete_eval _ req entities wf, - List.mem_filterMap] - exists policy - apply And.intro h₁ - split <;> simp only [Option.some.injEq, Residual.error.injEq, true_and] - <;> rename_i h₄ - <;> simp only [Except.map, h₃, Except.error.injEq] at h₄ - exact h₄.symm - -end Cedar.Thm.Partial.Authorization.PartialOnConcrete diff --git a/cedar-lean/Cedar/Thm/Partial/Authorization/PartialResponse.lean b/cedar-lean/Cedar/Thm/Partial/Authorization/PartialResponse.lean deleted file mode 100644 index b136ff375..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Authorization/PartialResponse.lean +++ /dev/null @@ -1,82 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Response -import Cedar.Thm.Data.Set - -namespace Cedar.Thm.Partial.Response - -open Cedar.Data -open Cedar.Spec (Effect PolicyID) -open Cedar.Partial (Residual) - -theorem mayBeSatisfied_wf {resp : Partial.Response} {eff : Effect} : - (resp.mayBeSatisfied eff).WellFormed -:= by - unfold Set.WellFormed Partial.Response.mayBeSatisfied Set.toList - simp only [Set.make_make_eqv] - apply List.Equiv.symm - exact Set.elts_make_equiv - -theorem mustBeSatisfied_wf {resp : Partial.Response} {eff : Effect} : - (resp.mustBeSatisfied eff).WellFormed -:= by - unfold Set.WellFormed Partial.Response.mustBeSatisfied Set.toList - simp only [Set.make_make_eqv] - apply List.Equiv.symm - exact Set.elts_make_equiv - -theorem permits_wf {resp : Partial.Response} : - resp.permits.WellFormed -:= by - unfold Partial.Response.permits - apply mayBeSatisfied_wf (eff := .permit) - -theorem knownPermits_wf {resp : Partial.Response} : - resp.knownPermits.WellFormed -:= by - unfold Partial.Response.knownPermits - apply mustBeSatisfied_wf (eff := .permit) - -theorem forbids_wf {resp : Partial.Response} : - resp.forbids.WellFormed -:= by - unfold Partial.Response.forbids - apply mayBeSatisfied_wf (eff := .forbid) - -theorem knownForbids_wf {resp : Partial.Response} : - resp.knownForbids.WellFormed -:= by - unfold Partial.Response.knownForbids - apply mustBeSatisfied_wf (eff := .forbid) - -theorem overapproximateDeterminingPolicies_wf {resp : Partial.Response} : - resp.overapproximateDeterminingPolicies.WellFormed -:= by - unfold Partial.Response.overapproximateDeterminingPolicies - cases resp.decision <;> simp only - case allow => exact permits_wf - case deny => exact forbids_wf - case unknown => exact Set.union_wf resp.permits resp.forbids - -theorem underapproximateDeterminingPolicies_wf {resp : Partial.Response} : - resp.underapproximateDeterminingPolicies.WellFormed -:= by - unfold Partial.Response.underapproximateDeterminingPolicies - cases resp.decision <;> simp only - case allow => exact knownPermits_wf - case deny => exact knownForbids_wf - case unknown => exact Set.empty_wf diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation.lean deleted file mode 100644 index 4f66f64ee..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation.lean +++ /dev/null @@ -1,17 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Thm.Partial.Evaluation.Evaluate diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate.lean deleted file mode 100644 index 2bab92c2b..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate.lean +++ /dev/null @@ -1,534 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Partial.Value -import Cedar.Spec.Evaluator -import Cedar.Thm.Partial.Evaluation.Evaluate.And -import Cedar.Thm.Partial.Evaluation.Evaluate.AndOr -import Cedar.Thm.Partial.Evaluation.Evaluate.Binary -import Cedar.Thm.Partial.Evaluation.Evaluate.Call -import Cedar.Thm.Partial.Evaluation.Evaluate.GetAttr -import Cedar.Thm.Partial.Evaluation.Evaluate.HasAttr -import Cedar.Thm.Partial.Evaluation.Evaluate.Ite -import Cedar.Thm.Partial.Evaluation.Evaluate.Or -import Cedar.Thm.Partial.Evaluation.Evaluate.Record -import Cedar.Thm.Partial.Evaluation.Evaluate.Set -import Cedar.Thm.Partial.Evaluation.Evaluate.Unary -import Cedar.Thm.Partial.Evaluation.Evaluate.Var -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Data.Control - -/-! This file contains theorems about the `Partial.evaluate` function specifically. -/ - -namespace Cedar.Thm.Partial.Evaluation.Evaluate - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Error Expr Prim Result) - -/-- - Partial evaluation with concrete inputs gives the same output as - concrete evaluation with those inputs --/ -theorem on_concrete_eqv_concrete_eval' (expr : Expr) (request : Spec.Request) (entities : Spec.Entities) - (wf : request.context.WellFormed) : - PartialEvalEquivConcreteEval expr request entities -:= by - unfold PartialEvalEquivConcreteEval - cases expr - case lit p => simp [Partial.evaluate, Spec.evaluate, Except.map] - case var v => - have h := Var.on_concrete_eqv_concrete_eval v request entities wf - unfold PartialEvalEquivConcreteEval at h ; exact h - case and x₁ x₂ | or x₁ x₂ => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - have ih₂ := on_concrete_eqv_concrete_eval' x₂ request entities wf - have := AndOr.on_concrete_eqv_concrete_eval ih₁ ih₂ - first | exact this.left | exact this.right - case ite x₁ x₂ x₃ => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - have ih₂ := on_concrete_eqv_concrete_eval' x₂ request entities wf - have ih₃ := on_concrete_eqv_concrete_eval' x₃ request entities wf - exact Ite.on_concrete_eqv_concrete_eval ih₁ ih₂ ih₃ - case unaryApp op x₁ => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - exact Unary.on_concrete_eqv_concrete_eval ih₁ - case binaryApp op x₁ x₂ => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - have ih₂ := on_concrete_eqv_concrete_eval' x₂ request entities wf - exact Binary.on_concrete_eqv_concrete_eval ih₁ ih₂ - case getAttr x₁ attr => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - exact GetAttr.on_concrete_eqv_concrete_eval ih₁ - case hasAttr x₁ attr => - have ih₁ := on_concrete_eqv_concrete_eval' x₁ request entities wf - exact HasAttr.on_concrete_eqv_concrete_eval ih₁ - case set xs => - have ih : ∀ x ∈ xs, PartialEvalEquivConcreteEval x request entities := by - intro x h₁ - have := List.sizeOf_lt_of_mem h₁ - apply on_concrete_eqv_concrete_eval' x request entities wf - exact Set.on_concrete_eqv_concrete_eval ih - case record attrs => - have ih : ∀ kv ∈ attrs, PartialEvalEquivConcreteEval kv.snd request entities := by - intro kv h₁ - have := List.sizeOf_lt_of_mem h₁ - apply on_concrete_eqv_concrete_eval' kv.snd request entities wf - exact Record.on_concrete_eqv_concrete_eval ih - case call xfn args => - have ih : ∀ arg ∈ args, PartialEvalEquivConcreteEval arg request entities := by - intro arg h₁ - have := List.sizeOf_lt_of_mem h₁ - apply on_concrete_eqv_concrete_eval' arg request entities wf - exact Call.on_concrete_eqv_concrete_eval ih -termination_by expr -decreasing_by - all_goals simp_wf - all_goals try omega - case _ => -- record - have h₂ : sizeOf kv.snd < sizeOf kv := by simp only [sizeOf, Prod._sizeOf_1] ; omega - apply Nat.lt_trans h₂ - omega - -/-- - Corollary, written with `PartialEvalEquivConcreteEval` spelled out, which is - easier for consumers --/ -theorem on_concrete_eqv_concrete_eval (expr : Expr) (request : Spec.Request) (entities : Spec.Entities) - (wf : request.context.WellFormed) : - Partial.evaluate expr request entities = (Spec.evaluate expr request entities).map Partial.Value.value -:= by - have h := on_concrete_eqv_concrete_eval' expr request entities wf - unfold PartialEvalEquivConcreteEval at h - exact h - -/-- - `Prop` that a given `Result Partial.Value` is either a concrete value or an - error, not a residual --/ -def isValueOrError : Result Partial.Value → Prop - | .ok (.value _) => true - | .ok (.residual _) => false - | .error _ => true - -/-- - Corollary to the above: partial evaluation with concrete inputs gives a - concrete value (or an error) --/ -theorem on_concrete_gives_concrete (expr : Expr) (request : Spec.Request) (entities : Spec.Entities) - (wf : request.context.WellFormed) : - isValueOrError (Partial.evaluate expr request entities) -:= by - rw [on_concrete_eqv_concrete_eval expr request entities wf] - simp only [Except.map, isValueOrError] - split - <;> rename_i h - <;> split at h - <;> simp only [Except.ok.injEq, Except.error.injEq, Partial.Value.value.injEq] at h - · trivial - · subst h ; simp only [Partial.Value.value.injEq, imp_false, forall_eq'] at * - -/-- - Partial evaluation always returns well-formed results --/ -theorem partial_eval_wf {expr : Expr} {request : Partial.Request} {entities : Partial.Entities} - (wf_r : request.WellFormed) - (wf_e : entities.WellFormed) : - EvaluatesToWellFormed expr request entities -:= by - cases expr - case lit p => - unfold EvaluatesToWellFormed - unfold Partial.evaluate - intro pval - intro h₁ ; simp at h₁ ; subst h₁ - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - case var v => exact Var.partial_eval_wf wf_r - case and x₁ x₂ | or x₁ x₂ => - intro pval - have := AndOr.partial_eval_wf x₁ x₂ request entities - first | exact this.left pval | exact this.right pval - case unaryApp op x₁ => exact Unary.partial_eval_wf - case binaryApp op x₁ x₂ => - have ih₁ := partial_eval_wf wf_r wf_e (expr := x₁) (request := request) (entities := entities) - have ih₂ := partial_eval_wf wf_r wf_e (expr := x₂) (request := request) (entities := entities) - exact Binary.partial_eval_wf ih₁ ih₂ - case hasAttr x₁ attr => exact HasAttr.partial_eval_wf - case getAttr x₁ attr => - have ih₁ := partial_eval_wf wf_r wf_e (expr := x₁) (request := request) (entities := entities) - exact GetAttr.partial_eval_wf ih₁ wf_e - case ite x₁ x₂ x₃ => - have ih₂ := partial_eval_wf wf_r wf_e (expr := x₂) (request := request) (entities := entities) - have ih₃ := partial_eval_wf wf_r wf_e (expr := x₃) (request := request) (entities := entities) - exact Ite.partial_eval_wf ih₂ ih₃ - case set xs => - have ih : ∀ x ∈ xs, EvaluatesToWellFormed x request entities := by - intro x h₁ - have := List.sizeOf_lt_of_mem h₁ - apply partial_eval_wf wf_r wf_e - exact Set.partial_eval_wf ih - case record attrs => - have ih : ∀ kv ∈ attrs, EvaluatesToWellFormed kv.snd request entities := by - intro kv h₁ - have := List.sizeOf_lt_of_mem h₁ - apply partial_eval_wf wf_r wf_e - exact Record.partial_eval_wf ih - case call xfn xs => - have ih : ∀ x ∈ xs, EvaluatesToWellFormed x request entities := by - intro x h₁ - have := List.sizeOf_lt_of_mem h₁ - apply partial_eval_wf wf_r wf_e - exact Call.partial_eval_wf ih -termination_by expr -decreasing_by - all_goals simp_wf - all_goals try omega - case _ => -- record - conv at this => lhs ; unfold sizeOf Prod._sizeOf_inst Prod._sizeOf_1 - simp at this - omega - -/-- - If partial evaluation returns a concrete value, then it returns the same value - after any substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {expr : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {v : Spec.Value} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - Partial.evaluate expr req entities = .ok (.value v) → - Partial.evaluate expr req' (entities.subst subsmap) = .ok (.value v) -:= by - cases expr - case lit p => - unfold Partial.evaluate - simp only [Except.ok.injEq, Partial.Value.value.injEq, Bool.not_eq_true'] - intro _ h₁ ; subst h₁ - rfl - case var var => - have h₁ := Var.subst_preserves_evaluation_to_value var req req' entities subsmap wf_r - unfold SubstPreservesEvaluationToConcrete at h₁ - intro h_req - exact h₁ wf_s h_req v - case and x₁ x₂ => - intro h_req h₁ - have h₂ := And.evals_to_concrete_then_operands_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at h₂ - rcases h₂ with h₂ | ⟨⟨v₁, hx₁⟩, ⟨v₂, hx₂⟩⟩ - · have ih := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req h₂ - unfold Partial.evaluate Spec.Value.asBool - unfold Partial.evaluate Spec.Value.asBool at h₁ - simp only [Bool.not_eq_true', Except.bind_ok, reduceIte, Except.ok.injEq, - Partial.Value.value.injEq] at * - simp only [ih] - simp only [h₂] at h₁ - exact h₁ - · have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - have ih₂ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₂ - apply (AndOr.subst_preserves_evaluation_to_value _ _).left h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₂' hx₂' - simp only [hx₂', Except.ok.injEq, Partial.Value.value.injEq] at hx₂ - subst v₂' - exact ih₂ - case or x₁ x₂ => - intro h_req h₁ - have h₂ := Or.evals_to_concrete_then_operands_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at h₂ - rcases h₂ with h₂ | ⟨⟨v₁, hx₁⟩, ⟨v₂, hx₂⟩⟩ - · have ih := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req h₂ - unfold Partial.evaluate Spec.Value.asBool - unfold Partial.evaluate Spec.Value.asBool at h₁ - simp only [Bool.not_eq_true', Except.bind_ok, reduceIte, Except.ok.injEq, - Partial.Value.value.injEq] at * - simp only [ih] - simp only [h₂] at h₁ - exact h₁ - · have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - have ih₂ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₂ - apply (AndOr.subst_preserves_evaluation_to_value _ _).right h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₂' hx₂' - simp only [hx₂', Except.ok.injEq, Partial.Value.value.injEq] at hx₂ - subst v₂' - exact ih₂ - case binaryApp op x₁ x₂ => - intro h_req h₁ - have h₂ := Binary.evals_to_concrete_then_operands_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at h₂ - have ⟨⟨v₁, hx₁⟩, ⟨v₂, hx₂⟩⟩ := h₂ ; clear h₂ - have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - have ih₂ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₂ - apply Binary.subst_preserves_evaluation_to_value _ _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₂' hx₂' - simp only [hx₂', Except.ok.injEq, Partial.Value.value.injEq] at hx₂ - subst v₂' - exact ih₂ - case unaryApp op x₁ => - intro h_req h₁ - have h₂ := Unary.evals_to_concrete_then_operand_evals_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at h₂ - have ⟨v₁, hx₁⟩ := h₂ ; clear h₂ - have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - apply Unary.subst_preserves_evaluation_to_value _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - case ite x₁ x₂ x₃ => - intro h_req h₁ - have h₂ := Ite.evals_to_concrete_then_operands_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at h₂ - rcases h₂ with ⟨hx₁, ⟨v₂, hx₂⟩⟩ | ⟨hx₁, ⟨v₃, hx₃⟩⟩ - · have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - have ih₂ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₂ - apply Ite.subst_preserves_evaluation_to_value _ _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - · unfold SubstPreservesEvaluationToConcrete - left - apply And.intro hx₁ - intro _ v₂' hx₂' - simp only [hx₂', Except.ok.injEq, Partial.Value.value.injEq] at hx₂ - subst v₂' - exact ih₂ - · have ih₁ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁ - have ih₃ := subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₃ - apply Ite.subst_preserves_evaluation_to_value _ _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - simp only [hx₁', Except.ok.injEq, Partial.Value.value.injEq] at hx₁ - subst v₁' - exact ih₁ - · unfold SubstPreservesEvaluationToConcrete - right - apply And.intro hx₁ - intro _ v₃' hx₃' - simp only [hx₃', Except.ok.injEq, Partial.Value.value.injEq] at hx₃ - subst v₃' - exact ih₃ - case getAttr x₁ attr => - intro h_req h₁ - apply GetAttr.subst_preserves_evaluation_to_value wf_e wf_s _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁' - case hasAttr x₁ attr => - intro h_req h₁ - apply HasAttr.subst_preserves_evaluation_to_value wf_e _ h_req v h₁ - · unfold SubstPreservesEvaluationToConcrete - intro _ v₁' hx₁' - exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx₁' - case set xs => - intro h_req h₁ - have hx := Set.evals_to_concrete_then_elts_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at hx - have ih : ∀ x ∈ xs, SubstPreservesEvaluationToConcrete x req req' entities subsmap := by - unfold SubstPreservesEvaluationToConcrete - intro x h₂ _ v' hx' - replace ⟨v, hx⟩ := hx x h₂ - simp only [hx, Except.ok.injEq, Partial.Value.value.injEq] at hx' - subst v' - have := List.sizeOf_lt_of_mem h₂ - exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx - exact Set.subst_preserves_evaluation_to_value ih h_req v h₁ - case record attrs => - intro h_req h₁ - have hx := Record.evals_to_concrete_then_vals_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at hx - have ih: ∀ kv ∈ attrs, SubstPreservesEvaluationToConcrete kv.snd req req' entities subsmap := by - unfold SubstPreservesEvaluationToConcrete - intro (k, x) h₂ _ v' hx' - replace ⟨v, hx⟩ := hx (k, x) h₂ - simp only [hx, Except.ok.injEq, Partial.Value.value.injEq] at hx' - subst v' - have := Map.sizeOf_lt_of_value h₂ - exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx - exact Record.subst_preserves_evaluation_to_value ih h_req v h₁ - case call xfn xs => - intro h_req h₁ - have hx := Call.evals_to_concrete_then_args_eval_to_concrete (by - unfold EvaluatesToConcrete - exists v - ) - unfold EvaluatesToConcrete at hx - have ih : ∀ x ∈ xs, SubstPreservesEvaluationToConcrete x req req' entities subsmap := by - unfold SubstPreservesEvaluationToConcrete - intro x h₂ _ v' hx' - replace ⟨v, hx⟩ := hx x h₂ - simp only [hx, Except.ok.injEq, Partial.Value.value.injEq] at hx' - subst v' - have := List.sizeOf_lt_of_mem h₂ - exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req hx - exact Call.subst_preserves_evaluation_to_value ih h_req v h₁ -termination_by expr - -/-- - If partial evaluation returns an error, then it also returns an error (not - necessarily the same error) after any substitution of unknowns --/ -theorem subst_preserves_errors {expr : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {e : Error} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - Partial.evaluate expr req entities = .error e → - ∃ e', Partial.evaluate expr req' (entities.subst subsmap) = .error e' -:= by - cases expr <;> intro h_req h₁ - case lit => simp only [Partial.evaluate] at h₁ - case var v => - have h := Var.subst_preserves_errors h_req h₁ - exists e - case and x₁ x₂ => - apply (AndOr.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ _).left h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case or x₁ x₂ => - apply (AndOr.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ _).right h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case ite x₁ x₂ x₃ => - apply Ite.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ _ _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case binaryApp op x₁ x₂ => - apply Binary.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case unaryApp op x₁ => - apply Unary.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case getAttr x₁ attr => - apply GetAttr.subst_preserves_errors wf_e wf_s (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case hasAttr x₁ attr => - apply HasAttr.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro _ e' - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case set xs => - apply Set.subst_preserves_errors _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro x hx _ e' - have := List.sizeOf_lt_of_mem hx - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case record attrs => - apply Record.subst_preserves_errors _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro x hx _ e' - have := Map.sizeOf_lt_of_value hx - exact subst_preserves_errors wf_r wf_e wf_s h_req - } - case call xfn xs => - apply Call.subst_preserves_errors (by intro x _ v ; exact subst_preserves_evaluation_to_value wf_r wf_e wf_s h_req) _ h_req e h₁ - all_goals { - unfold SubstPreservesEvaluationToError - intro x hx _ e' - have := List.sizeOf_lt_of_mem hx - exact subst_preserves_errors wf_r wf_e wf_s h_req - } -termination_by expr - -/-- - Corollary (contrapositive) of the above: - If partial evaluation returns ok after any substitution of unknowns, - then it must return ok before that substitution --/ -theorem subst_preserves_errors_mt {expr : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - (Partial.evaluate expr req' (entities.subst subsmap)).isOk → - (Partial.evaluate expr req entities).isOk -:= by - unfold Except.isOk Except.toBool - intro h₁ h₂ - by_contra h₃ - split at h₃ <;> simp at h₃ - case _ e h₄ => - have ⟨e', h₅⟩ := subst_preserves_errors wf_r wf_e wf_s h₁ h₄ - simp [h₅] at h₂ diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/And.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/And.lean deleted file mode 100644 index cd36f2403..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/And.lean +++ /dev/null @@ -1,72 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.Props - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.And - -open Cedar.Data -open Cedar.Spec (Expr) - -/-- - If partial-evaluating an `Expr.and` produces `ok` with a concrete - value, then so would partial-evaluating either of the operands, unless the - `and` short-circuits --/ -theorem evals_to_concrete_then_operands_eval_to_concrete {x₁ x₂ : Expr} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.and x₁ x₂) request entities → - Partial.evaluate x₁ request entities = .ok (.value false) ∨ - (EvaluatesToConcrete x₁ request entities ∧ EvaluatesToConcrete x₂ request entities) -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> cases hx₂ : Partial.evaluate x₂ request entities - <;> simp only [hx₁, Spec.Value.asBool, Bool.not_eq_true', hx₂, Except.bind_ok, Except.bind_err] at h₁ - case ok.ok pval₁ pval₂ => - cases pval₁ - case residual r₁ => - simp only [Except.ok.injEq, exists_const, false_and, or_self] - simp only [Except.ok.injEq] at h₁ - case value v₁ => - cases pval₂ - case value v₂ => simp only [Except.ok.injEq, Partial.Value.value.injEq, exists_eq', and_self, or_true] - case residual r₂ => - exact match v₁ with - | .prim p => by - cases p <;> simp only [Except.bind_ok, Except.bind_err] at h₁ - case bool b => cases b <;> simp at * - | .set _ | .record _ => by simp at h₁ - | .ext x => by cases x <;> simp at h₁ - case ok.error pval e => - cases pval <;> simp only [Except.ok.injEq] at h₁ - case value v => - cases v - case prim p => - cases p <;> simp only [Except.bind_ok, Except.bind_err] at h₁ - case bool b => - cases b - <;> simp only [reduceIte, Except.ok.injEq, Partial.Value.value.injEq] at h₁ - <;> simp [h₁] - case set | record => simp at h₁ - case ext x => cases x <;> simp at h₁ - -end Cedar.Thm.Partial.Evaluation.Evaluate.And diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/AndOr.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/AndOr.lean deleted file mode 100644 index e2c16373b..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/AndOr.lean +++ /dev/null @@ -1,202 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.AndOr - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr Prim Result) - -/- ## Lemmas shared by `Expr.and` and `Expr.or` -/ - -/-- - Inductive argument that, for an `Expr.and` or `Expr.or` with concrete - request/entities, partial evaluation and concrete evaluation give the same - output --/ -theorem on_concrete_eqv_concrete_eval {x₁ x₂ : Expr} {request : Spec.Request} {entities : Spec.Entities} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval x₂ request entities → - PartialEvalEquivConcreteEval (Expr.and x₁ x₂) request entities ∧ - PartialEvalEquivConcreteEval (Expr.or x₁ x₂) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ ih₂ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁, ih₂] - simp only [Except.map, pure, Except.pure, Result.as, Coe.coe] - constructor - all_goals { - cases h₁ : Spec.evaluate x₁ request entities <;> simp only [Bool.not_eq_true', Except.bind_err, Except.bind_ok] - case ok v₁ => - simp only [Spec.Value.asBool] - cases v₁ <;> try simp only [Except.bind_err] - case prim p => - cases p <;> simp only [Except.bind_ok, Except.bind_err] - case bool b => - cases b <;> simp only [ite_true, ite_false] - split <;> simp only [Except.bind_ok, Except.bind_err] - case h_1 e h₂ => simp only [h₂, Except.bind_err] - case h_2 v h₂ => - simp only [h₂] - cases v <;> try simp only [Except.bind_err] - case prim p => cases p <;> simp - } - -/-- - If partial-evaluating an `Expr.and` or `Expr.or` produces `ok` - with some value, that value is well-formed. --/ -theorem partial_eval_wf (x₁ x₂ : Expr) (request : Partial.Request) (entities : Partial.Entities) : - EvaluatesToWellFormed (Expr.and x₁ x₂) request entities ∧ - EvaluatesToWellFormed (Expr.or x₁ x₂) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - constructor - all_goals { - cases hx₁ : Partial.evaluate x₁ request entities - case error => simp - case ok pval₁ => - cases pval₁ - case residual r₁ => simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - case value v₁ => - cases v₁ <;> simp [Spec.Value.asBool] - case prim p₁ => - cases p₁ <;> simp - case bool b₁ => - cases b₁ <;> simp - all_goals try { - -- this dispatches the `false` case for `and`, and the `true` case for `or` - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - } - intro pval - cases hx₂ : Partial.evaluate x₂ request entities <;> simp [hx₂] - case ok pval₂ => - cases pval₂ <;> simp - case residual r₂ => intro h₁ ; subst h₁ ; simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - case value v₂ => - cases v₂ <;> try simp - case prim p₂ => - cases p₂ <;> simp - case bool b₂ => intro h₁ ; subst h₁ ; simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - } - -/-- - Inductive argument that if partial-evaluation of an `Expr.and` or - `Expr.or` returns a concrete value, then it returns the same value - after any substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ x₂ : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) - (ih₂ : SubstPreservesEvaluationToConcrete x₂ req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.and x₁ x₂) req req' entities subsmap ∧ - SubstPreservesEvaluationToConcrete (Expr.or x₁ x₂) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete at * - unfold Partial.evaluate Spec.Value.asBool - constructor - all_goals { - intro h_req v - specialize ih₁ h_req - specialize ih₂ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> cases hx₂ : Partial.evaluate x₂ req entities - <;> simp only [hx₁, hx₂, false_implies, forall_const, Except.ok.injEq, Bool.not_eq_true', - Except.bind_ok, Except.bind_err] at * - case ok.ok pval₁ pval₂ => - cases pval₁ - case residual r₁ => simp only [Except.ok.injEq, false_implies] - case value v₁ => - cases pval₂ - case value v₂ => simp only [ih₁ v₁, ih₂ v₂, Except.bind_ok, imp_self] - case residual r₂ => - simp only [ih₁ v₁, Except.bind_ok] - cases v₁ - case prim p₁ => - cases p₁ <;> simp only [Except.bind_ok, Except.bind_err, imp_self] - case bool b₁ => cases b₁ <;> simp - case set | record => simp - case ext x => cases x <;> simp - case ok.error pval₁ e₂ => - cases pval₁ - case residual r₁ => simp only [false_implies, forall_const, Except.ok.injEq] - case value v₁ => - simp only [Partial.Value.value.injEq, forall_eq'] at * - cases v₁ - case prim p₁ => - cases p₁ <;> simp only [Except.bind_ok, Except.bind_err, false_implies] - case bool b₁ => - cases b₁ - <;> simp only [reduceIte, Except.ok.injEq, Partial.Value.value.injEq, false_implies] - <;> intro h₁ <;> subst v - simp only [ih₁, Except.bind_ok, reduceIte] - case set | record => simp - case ext x => cases x <;> simp - } - -/-- - Inductive argument that if partial-evaluation of an `Expr.and` or - `Expr.or` returns an error, then it also returns an error (not - necessarily the same error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ x₂ : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) - (ih₂ : SubstPreservesEvaluationToError x₂ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.and x₁ x₂) req req' entities subsmap ∧ - SubstPreservesEvaluationToError (Expr.or x₁ x₂) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - constructor - all_goals { - intro h_req ; specialize ih₁ h_req ; specialize ih₂ h_req - exact match hx₁ : Partial.evaluate x₁ req entities with - | .error e₁ => by - replace ⟨e₁', ih₁⟩ := ih₁ e₁ hx₁ - simp only [ih₁, Bool.not_eq_true', Except.bind_err, Except.error.injEq, exists_eq', implies_true] - | .ok (.residual r₁) => by - simp only [Bool.not_eq_true', Except.bind_ok, false_implies, implies_true] - | .ok (.value v₁) => by - simp only [h_spetv x₁ h_req v₁ hx₁, Except.bind_ok] - cases v₁ <;> simp [hx₁, Spec.Value.asBool] - case prim p₁ => - cases p₁ <;> simp at * - case bool b₁ => - cases b₁ <;> simp at * - all_goals { - exact match hx₂ : Partial.evaluate x₂ req entities with - | .error e₂ => by - replace ⟨e₂', ih₂⟩ := ih₂ e₂ hx₂ - simp only [ih₂, Except.bind_err, Except.error.injEq, exists_eq', implies_true] - | .ok (.residual r₂) => by simp only [Except.bind_ok, false_implies, implies_true] - | .ok (.value v₂) => by - simp only [h_spetv x₂ h_req v₂ hx₂, Except.bind_ok] - intro e _ ; exists e - } - } - -end Cedar.Thm.Partial.Evaluation.Evaluate.AndOr diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Binary.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Binary.lean deleted file mode 100644 index a86364a6a..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Binary.lean +++ /dev/null @@ -1,168 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.EvaluateBinaryApp -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Binary - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (BinaryOp EntityUID Expr intOrErr Prim Result) - -/-- - Inductive argument that, for an `Expr.binaryApp` with concrete - request/entities, partial evaluation and concrete evaluation give the same - output --/ -theorem on_concrete_eqv_concrete_eval {x₁ x₂ : Expr} {request : Spec.Request} {entities : Spec.Entities} {op : BinaryOp} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval x₂ request entities → - PartialEvalEquivConcreteEval (Expr.binaryApp op x₁ x₂) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ ih₂ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁, ih₂, Except.map] - cases h₁ : Spec.evaluate x₁ request entities <;> simp only [h₁, Except.bind_err, Except.bind_ok] - case ok v₁ => - cases h₂ : Spec.evaluate x₂ request entities <;> simp only [h₂, Except.bind_err, Except.bind_ok] - case ok v₂ => simp only [EvaluateBinaryApp.on_concrete_eqv_concrete, Except.map] - -/-- - Inductive argument that if evaluating an `Expr.binaryApp` on - well-formed arguments produces `ok` with some value, that is a well-formed - value as well --/ -theorem partial_eval_wf {x₁ x₂ : Expr} {op : BinaryOp} {request : Partial.Request} {entities : Partial.Entities} - (ih₁ : EvaluatesToWellFormed x₁ request entities) - (ih₂ : EvaluatesToWellFormed x₂ request entities) : - EvaluatesToWellFormed (Expr.binaryApp op x₁ x₂) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - intro pval - cases hx₁ : Partial.evaluate x₁ request entities - <;> cases hx₂ : Partial.evaluate x₂ request entities - <;> simp [hx₁, hx₂] - case ok.ok pval₁ pval₂ => - exact EvaluateBinaryApp.evaluateBinaryApp_wf (ih₁ pval₁ hx₁) (ih₂ pval₂ hx₂) pval - -/-- - If partial-evaluating an `Expr.binaryApp` produces `ok` with a concrete - value, then so would partial-evaluating either of the operands --/ -theorem evals_to_concrete_then_operands_eval_to_concrete {x₁ x₂ : Expr} {op : BinaryOp} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.binaryApp op x₁ x₂) request entities → - (EvaluatesToConcrete x₁ request entities ∧ EvaluatesToConcrete x₂ request entities) -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> cases hx₂ : Partial.evaluate x₂ request entities - <;> simp only [hx₁, hx₂, Except.bind_ok, Except.bind_err] at h₁ - case ok.ok pval₁ pval₂ => - have ⟨⟨v₁, hv₁⟩, ⟨v₂, hv₂⟩⟩ := EvaluateBinaryApp.returns_concrete_then_operands_eval_to_concrete h₁ - subst pval₁ pval₂ - exact And.intro (by exists v₁) (by exists v₂) - -/-- - Inductive argument that if partial-evaluation of an `Expr.binaryApp` - returns a concrete value, then it returns the same value after any - substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ x₂ : Expr} {op : BinaryOp} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) - (ih₂ : SubstPreservesEvaluationToConcrete x₂ req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.binaryApp op x₁ x₂) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete at * - unfold Partial.evaluate - intro h_req v - specialize ih₁ h_req - specialize ih₂ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> cases hx₂ : Partial.evaluate x₂ req entities - <;> simp only [hx₁, hx₂, Except.ok.injEq, false_implies, forall_const, - Except.bind_err, Except.bind_ok] at * - case ok.ok pval₁ pval₂ => - cases pval₁ <;> cases pval₂ - <;> simp only [Partial.Value.value.injEq, forall_eq', false_implies, forall_const] at * - case value.value v₁ v₂ => - simp only [ih₁, ih₂, Except.bind_ok] - exact EvaluateBinaryApp.subst_preserves_evaluation_to_value - all_goals simp only [Partial.evaluateBinaryApp, Except.ok.injEq, false_implies] - -/-- - Inductive argument that if partial-evaluation of an `Expr.binaryApp` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ x₂ : Expr} {op : BinaryOp} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) - (ih₂ : SubstPreservesEvaluationToError x₂ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.binaryApp op x₁ x₂) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - intro h_req ; specialize ih₁ h_req ; specialize ih₂ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> cases hx₂ : Partial.evaluate x₂ req entities - <;> simp only [hx₁, hx₂, false_implies, implies_true, Except.error.injEq] at ih₁ ih₂ - case error.error e₁ e₂ | error.ok e₁ pval₂ => - replace ⟨e₁', ih₁⟩ := ih₁ e₁ rfl - simp [ih₁] - case ok.error pval₁ e₂ => - replace ⟨e₂', ih₂⟩ := ih₂ e₂ rfl - simp [ih₂] - cases Partial.evaluate x₁ req' (entities.subst subsmap) - case error e₁' => exists e₁' - case ok => exists e₂' - case ok.ok pval₁ pval₂ => - simp only [Except.bind_ok] - intro e h₁ - have ⟨e', h₂⟩ := EvaluateBinaryApp.subst_preserves_errors subsmap h₁ - cases hx₁' : Partial.evaluate x₁ req' (entities.subst subsmap) - case error e₁' => exists e₁' - case ok pval₁' => - cases hx₂' : Partial.evaluate x₂ req' (entities.subst subsmap) - case error e₂' => exists e₂' - case ok pval₂' => - simp only [Except.bind_ok] - cases pval₁ <;> cases pval₂ - case value.value v₁ v₂ => - simp only [h_spetv x₁ h_req v₁ hx₁, Except.ok.injEq] at hx₁' ; subst pval₁' - simp only [h_spetv x₂ h_req v₂ hx₂, Except.ok.injEq] at hx₂' ; subst pval₂' - exists e' - case value.residual v₁ r₂ => exists e - case residual.value r₁ v₂ => exists e' - case residual.residual r₁ r₂ => exists e - -end Cedar.Thm.Partial.Evaluation.Evaluate.Binary diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Call.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Call.lean deleted file mode 100644 index 890a5403c..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Call.lean +++ /dev/null @@ -1,160 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.List -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.EvaluateCall -import Cedar.Thm.Partial.Evaluation.Evaluate.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Call - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Error Expr Ext ExtFun Prim Result) - -/-- - Inductive argument that, for an `Expr.call` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {xs : List Expr} {request : Spec.Request} {entities : Spec.Entities} {xfn : ExtFun} : - (∀ x ∈ xs, PartialEvalEquivConcreteEval x request entities) → - PartialEvalEquivConcreteEval (Expr.call xfn xs) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] - rw [List.mapM₁_eq_mapM (Spec.evaluate · request entities)] - rw [Set.mapM_partial_eval_eqv_concrete_eval ih₁] - cases xs.mapM (Spec.evaluate · request entities) <;> simp only [Except.bind_ok, Except.bind_err] - case error e => simp only [Except.map, Except.bind_err] - case ok vs => exact EvaluateCall.on_concrete_eqv_concrete - -/-- - Inductive argument that if partial-evaluating an `Expr.Call` returns - `ok` with some value, that value is well-formed --/ -theorem partial_eval_wf {xs : List Expr} {request : Partial.Request} {entities : Partial.Entities} {xfn : ExtFun} - (ih : ∀ x ∈ xs, EvaluatesToWellFormed x request entities) : - EvaluatesToWellFormed (Expr.call xfn xs) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] - cases hx : xs.mapM (Partial.evaluate · request entities) <;> simp [hx] - case ok pvals => - replace hx := List.mapM_ok_implies_all_from_ok hx - apply EvaluateCall.evaluateCall_wf _ - intro pval h₂ - replace ⟨x, h₃, hx⟩ := hx pval h₂ - exact ih x h₃ pval hx - -/-- - If partial-evaluating an `Expr.call` produces `ok` with a concrete - value, then so would partial-evaluating any of the arguments --/ -theorem evals_to_concrete_then_args_eval_to_concrete {xs : List Expr} {request : Partial.Request} {entities : Partial.Entities} {xfn : ExtFun} : - EvaluatesToConcrete (Expr.call xfn xs) request entities → - ∀ x ∈ xs, EvaluatesToConcrete x request entities -:= by - unfold EvaluatesToConcrete - intro h₁ x h₂ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] at h₁ - cases h₃ : xs.mapM (Partial.evaluate · request entities) - <;> simp only [h₃, Except.bind_ok, Except.bind_err] at h₁ - case ok pvals => - replace ⟨pval, h₃, h₄⟩ := List.mapM_ok_implies_all_ok h₃ x h₂ - replace ⟨v, h₁⟩ := EvaluateCall.returns_concrete_then_args_concrete h₁ pval h₃ - subst pval - exists v - -/-- - Inductive argument that if partial-evaluation of an `Expr.call` returns - a concrete value, then it returns the same value after any substitution of - unknowns --/ -theorem subst_preserves_evaluation_to_value {args : List Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} {xfn : ExtFun} - (ih : ∀ arg ∈ args, SubstPreservesEvaluationToConcrete arg req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.call xfn args) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete - unfold Partial.evaluate Partial.evaluateCall - intro h_req v - rw [List.mapM₁_eq_mapM (Partial.evaluate · req entities)] - cases h₁ : args.mapM (Partial.evaluate · req entities) - <;> simp only [Except.bind_ok, Except.bind_err, Bool.not_eq_true', false_implies] - case ok pvals => - split - · rename_i vs h₂ - -- vs are the concrete values produced by evaluating the args pre-subst - rw [List.mapM₁_eq_mapM (Partial.evaluate · req' (entities.subst subsmap))] - rw [Set.mapM_subst_preserves_evaluation_to_values ih h_req pvals h₁ (by unfold IsAllConcrete ; exists vs)] - cases h₃ : Spec.call xfn vs - <;> simp only [Except.bind_err, Except.bind_ok, false_implies, Except.ok.injEq, Partial.Value.value.injEq] - case ok v' => - intro h ; subst v' - simp only [h₂, h₃, Except.bind_ok] - · rename_i h₂ - replace ⟨pval, h₂, h₃⟩ := List.mapM_none_iff_exists_none.mp h₂ - cases pval <;> simp only at h₃ - case residual r => simp only [Except.ok.injEq, false_implies] - -/-- - Inductive argument that if partial-evaluation of an `Expr.call` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {xs : List Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} {xfn : ExtFun} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih : ∀ x ∈ xs, SubstPreservesEvaluationToError x req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.call xfn xs) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - simp only [Partial.evaluate, Partial.evaluateCall] - intro h_req e - rw [List.mapM₁_eq_mapM (Partial.evaluate · req entities)] - rw [List.mapM₁_eq_mapM (Partial.evaluate · req' (entities.subst subsmap))] - cases hxs : xs.mapM (Partial.evaluate · req entities) - case error e' => - simp only [Except.bind_err, Except.error.injEq, List.mapM_map] - intro _ ; subst e' - replace ⟨x, hx, hxs⟩ := List.mapM_error_implies_exists_error hxs - replace ⟨e', ih⟩ := ih x hx h_req e hxs - have ⟨e'', h₁⟩ := List.element_error_implies_mapM_error hx (f := λ x => Partial.evaluate x req' (entities.subst subsmap)) ih - simp only [h₁, Except.bind_err, Except.error.injEq, exists_eq'] - case ok pvals => - simp only [Except.bind_ok] - intro h₁ - split at h₁ <;> rename_i h₁' - · rename_i vs - rw [do_error] at h₁ - have h₂ := Set.mapM_subst_preserves_evaluation_to_values (by intro x _ ; exact h_spetv x) h_req pvals hxs (by unfold IsAllConcrete ; exists vs) - simp only [h₂, h₁', h₁, Except.bind_ok, Except.bind_err, Except.error.injEq, exists_eq'] - · simp only at h₁ - -end Cedar.Thm.Partial.Evaluation.Evaluate.Call diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/GetAttr.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/GetAttr.lean deleted file mode 100644 index 6feb382d5..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/GetAttr.lean +++ /dev/null @@ -1,128 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.LT -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.EvaluateGetAttr -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.GetAttr - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr EntityUID Error Expr Result) - -/-- - Inductive argument that, for an `Expr.getAttr` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {x₁ : Expr} {request : Spec.Request} {entities : Spec.Entities} {attr : Attr} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval (Expr.getAttr x₁ attr) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁] - cases Spec.evaluate x₁ request entities <;> simp only [Except.bind_err, Except.bind_ok] - case error e => simp only [Except.map, Except.bind_err] - case ok v₁ => exact EvaluateGetAttr.on_concrete_eqv_concrete - -/-- - Inductive argument that if partial-evaluating an `Expr.getAttr` on - a well-formed value and well-formed entities returns `ok` with some value, - that is a well-formed value as well --/ -theorem partial_eval_wf {x₁ : Expr} {attr : Attr} {entities : Partial.Entities} {request : Partial.Request} - (ih₁ : EvaluatesToWellFormed x₁ request entities) - (wf_e : entities.WellFormed) : - EvaluatesToWellFormed (Expr.getAttr x₁ attr) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - cases hx₁ : Partial.evaluate x₁ request entities <;> simp [hx₁] - case ok pval₁ => exact EvaluateGetAttr.evaluateGetAttr_wf (ih₁ pval₁ hx₁) wf_e - -/-- - Inductive argument that if partial-evaluation of an `Expr.getAttr` - returns a concrete value, then it returns the same value after any - substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ : Expr} {attr : Attr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.getAttr x₁ attr) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete at * - unfold Partial.evaluate - intro h_req v - specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, false_implies, forall_const, Except.bind_ok, Except.bind_err, Except.ok.injEq] at * - case ok pval₁ => - cases pval₁ - case residual r₁ => simp only [Partial.evaluateGetAttr, Except.ok.injEq, false_implies] - case value v₁ => - simp only [Partial.Value.value.injEq, forall_eq'] at * - simp only [ih₁, Except.bind_ok] - exact EvaluateGetAttr.subst_preserves_evaluation_to_value wf_e wf_s - -/-- - Inductive argument that if partial-evaluation of an `Expr.getAttr` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ : Expr} {attr : Attr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.getAttr x₁ attr) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - intro h_req ; specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, false_implies, implies_true, Except.error.injEq] at ih₁ - case error e₁ => - replace ⟨e₁', ih₁⟩ := ih₁ e₁ rfl - simp [ih₁] - case ok pval₁ => - simp only [Except.bind_ok] - intro e₁ h₁ - cases hx₁' : Partial.evaluate x₁ req' (entities.subst subsmap) - case error e₁' => exists e₁' - case ok pval₁' => - simp only [Except.bind_ok] - cases pval₁ - case residual r₁ => exists e₁ - case value v₁ => - simp only [h_spetv x₁ h_req v₁ hx₁, Except.ok.injEq] at hx₁' ; subst pval₁' - exact EvaluateGetAttr.subst_preserves_errors subsmap wf_e wf_s h₁ - - -end Cedar.Thm.Partial.Evaluation.Evaluate.GetAttr diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/HasAttr.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/HasAttr.lean deleted file mode 100644 index 34c3108fe..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/HasAttr.lean +++ /dev/null @@ -1,141 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.EvaluateHasAttr -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.HasAttr - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr Error Expr Prim Result) - -/-- - Inductive argument that, for an `Expr.hasAttr` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {x₁ : Expr} {request : Spec.Request} {entities : Spec.Entities} {attr : Attr} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval (Expr.hasAttr x₁ attr) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁] - cases Spec.evaluate x₁ request entities <;> simp only [Except.bind_err, Except.bind_ok] - case error e => simp only [Except.map, Except.bind_err] - case ok v₁ => exact EvaluateHasAttr.on_concrete_eqv_concrete - -/-- - if partial-evaluating an `Expr.hasAttr` returns `ok` with some value, - that is a well-formed value --/ -theorem partial_eval_wf {x₁ : Expr} {attr : Attr} {entities : Partial.Entities} {request : Partial.Request} : - EvaluatesToWellFormed (Expr.hasAttr x₁ attr) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - cases hx₁ : Partial.evaluate x₁ request entities <;> simp [hx₁] - case ok pval₁ => - exact EvaluateHasAttr.evaluateHasAttr_wf - -/-- - If partial-evaluating an `Expr.hasAttr` produces `ok` with a concrete - value, then so would partial-evaluating its operand --/ -theorem evals_to_concrete_then_operand_evals_to_concrete {x₁ : Expr} {attr : Attr} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.hasAttr x₁ attr) request entities → - EvaluatesToConcrete x₁ request entities -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> simp only [hx₁, Except.bind_ok, Except.bind_err] at h₁ - case ok pval₁ => - have ⟨v₁, hv₁⟩ := EvaluateHasAttr.returns_concrete_then_operand_evals_to_concrete h₁ - subst pval₁ - exists v₁ - -/-- - Inductive argument that if partial-evaluation of an `Expr.hasAttr` - returns a concrete value, then it returns the same value after any - substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ : Expr} {attr : Attr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (wf : entities.WellFormed) - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.hasAttr x₁ attr) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete at * - unfold Partial.evaluate - intro h_req v - specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, false_implies, forall_const, Except.bind_err, Except.bind_ok, Except.ok.injEq] at * - case ok pval₁ => - cases pval₁ - case residual r₁ => simp only [Partial.evaluateHasAttr, Except.ok.injEq, false_implies] - case value v₁ => - simp only [Partial.Value.value.injEq, forall_eq'] at * - simp only [ih₁, Except.bind_ok] - exact EvaluateHasAttr.subst_preserves_evaluation_to_value wf - -/-- - Inductive argument that if partial-evaluation of an `Expr.hasAttr` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ : Expr} {attr : Attr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.hasAttr x₁ attr) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - intro h_req ; specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, false_implies, implies_true, Except.error.injEq] at ih₁ - case error e₁ => - replace ⟨e₁', ih₁⟩ := ih₁ e₁ rfl - simp [ih₁] - case ok pval₁ => - simp only [Except.bind_ok] - intro e₁ h₁ - cases hx₁' : Partial.evaluate x₁ req' (entities.subst subsmap) - case error e₁' => exists e₁' - case ok pval₁' => - simp only [Except.bind_ok] - cases pval₁ - case residual r₁ => exists e₁ - case value v₁ => - simp only [h_spetv x₁ h_req v₁ hx₁, Except.ok.injEq] at hx₁' ; subst pval₁' - exact EvaluateHasAttr.subst_preserves_errors subsmap h₁ - - -end Cedar.Thm.Partial.Evaluation.Evaluate.HasAttr diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Ite.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Ite.lean deleted file mode 100644 index 0eaea160f..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Ite.lean +++ /dev/null @@ -1,193 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Ite - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr Result) - -/-- - Inductive argument that, for an `Expr.ite` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {x₁ x₂ x₃ : Expr} {request : Spec.Request} {entities : Spec.Entities} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval x₂ request entities → - PartialEvalEquivConcreteEval x₃ request entities → - PartialEvalEquivConcreteEval (Expr.ite x₁ x₂ x₃) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ ih₂ ih₃ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁, ih₂, ih₃] - simp only [Except.map, Result.as, Coe.coe] - cases Spec.evaluate x₁ request entities <;> simp only [Except.bind_err, Except.bind_ok] - case ok v₁ => - simp only [Spec.Value.asBool] - cases v₁ <;> try simp only [Except.bind_err] - case prim p => - cases p <;> simp only [Except.bind_ok, Except.bind_err] - case bool b => cases b <;> simp - -/-- - Inductive argument that if partial-evaluating an `Expr.ite` expression - produces `ok` with some value, that value is well-formed as well --/ -theorem partial_eval_wf {x₁ x₂ x₃ : Expr} {request : Partial.Request} {entities : Partial.Entities} - (ih₂ : EvaluatesToWellFormed x₂ request entities) - (ih₃ : EvaluatesToWellFormed x₃ request entities) : - EvaluatesToWellFormed (Expr.ite x₁ x₂ x₃) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - cases hx₁ : Partial.evaluate x₁ request entities <;> simp [hx₁] - case ok pval₁ => - cases pval₁ <;> simp only [Except.ok.injEq, forall_eq'] - case residual r₁ => simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - case value v₁ => - cases v₁ <;> simp only [Spec.Value.asBool, Except.bind_err, false_implies, implies_true] - case prim p₁ => - cases p₁ <;> simp only [Except.bind_ok, Except.bind_err, false_implies, implies_true] - case bool b₁ => - cases b₁ <;> simp only [Bool.false_eq_true, reduceIte] - case true => - cases hx₂ : Partial.evaluate x₂ request entities <;> simp [hx₂] - case ok pval => exact ih₂ pval hx₂ - case false => - cases hx₃ : Partial.evaluate x₃ request entities <;> simp [hx₃] - case ok pval => exact ih₃ pval hx₃ - -/-- - If partial-evaluating an `Expr.ite` produces `ok` with a concrete - value, then partial-evaluating the guard produces either concrete `true` or - `false`, and partial-evaluating whichever operand isn't short-circuited out - produces `ok` with a concrete value --/ -theorem evals_to_concrete_then_operands_eval_to_concrete {x₁ x₂ x₃ : Expr} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.ite x₁ x₂ x₃) request entities → - (Partial.evaluate x₁ request entities = .ok (.value true) ∧ EvaluatesToConcrete x₂ request entities) ∨ - (Partial.evaluate x₁ request entities = .ok (.value false) ∧ EvaluatesToConcrete x₃ request entities) -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> simp only [hx₁, Spec.Value.asBool, Except.bind_err, Except.bind_ok] at h₁ - case ok pval₁ => - cases pval₁ <;> simp only [Except.ok.injEq] at h₁ - case value v₁ => - cases v₁ - case prim p₁ => - cases p₁ <;> simp only [Except.bind_ok, Except.bind_err] at h₁ - case bool b₁ => - cases b₁ <;> simp only [reduceIte] at h₁ - case true => - left - cases hx₂ : Partial.evaluate x₂ request entities - <;> simp only [hx₂, Except.ok.injEq] at h₁ - case ok v₂ => subst h₁ ; simp - case false => - right - cases hx₃ : Partial.evaluate x₃ request entities - <;> simp only [hx₃, Except.ok.injEq] at h₁ - case ok v₃ => subst h₁ ; simp - case set | record => simp at h₁ - case ext x => cases x <;> simp at h₁ - -/-- - Inductive argument that if partial-evaluation of an `Expr.ite` returns - a concrete value, then it returns the same value after any substitution of - unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ x₂ x₃ : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) - (ih₂₃ : - (Partial.evaluate x₁ req entities = .ok (.value true) ∧ SubstPreservesEvaluationToConcrete x₂ req req' entities subsmap) ∨ - (Partial.evaluate x₁ req entities = .ok (.value false) ∧ SubstPreservesEvaluationToConcrete x₃ req req' entities subsmap) - ) : - SubstPreservesEvaluationToConcrete (Expr.ite x₁ x₂ x₃) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete Partial.evaluate Spec.Value.asBool - intro h_req v - specialize ih₁ h_req - rcases ih₂₃ with ⟨hx₁, ih₂⟩ | ⟨hx₁, ih₃⟩ - · specialize ih₂ h_req - specialize ih₁ (.prim (.bool true)) hx₁ - simp only [hx₁, Except.bind_ok, reduceIte] - intro h₁ - simp only [ih₁, Except.bind_ok, reduceIte] - exact ih₂ v h₁ - · specialize ih₃ h_req - specialize ih₁ (.prim (.bool false)) hx₁ - simp only [hx₁, Except.bind_ok, reduceIte] - intro h₁ - simp only [ih₁, Except.bind_ok, reduceIte] - exact ih₃ v h₁ - -/-- - Inductive argument that if partial-evaluation of an `Expr.ite` returns - an error, then it also returns an error (not necessarily the same error) after - any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ x₂ x₃ : Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) - (ih₂ : SubstPreservesEvaluationToError x₂ req req' entities subsmap) - (ih₃ : SubstPreservesEvaluationToError x₃ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.ite x₁ x₂ x₃) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - intro h_req ; specialize ih₁ h_req ; specialize ih₂ h_req ; specialize ih₃ h_req - exact match hx₁ : Partial.evaluate x₁ req entities with - | .error e₁ => by - replace ⟨e₁', ih₁⟩ := ih₁ e₁ hx₁ - simp only [ih₁, Except.bind_err, Except.error.injEq, exists_eq', implies_true] - | .ok (.residual r₁) => by simp only [Except.bind_ok, false_implies, implies_true] - | .ok (.value v₁) => by - simp only [h_spetv x₁ h_req v₁ hx₁, Except.bind_ok] - cases v₁ - <;> simp only [Spec.Value.asBool, Except.bind_err, Except.error.injEq, exists_eq', implies_true] - case prim p₁ => - cases p₁ - <;> simp only [Except.bind_ok, Except.bind_err, Except.error.injEq, exists_eq', implies_true] at * - case bool b₁ => - cases b₁ <;> simp only [Bool.false_eq_true, reduceIte] at * - case true => - exact match hx₂ : Partial.evaluate x₂ req entities with - | .error e' => by simp [hx₂, ih₂ e'] - | .ok (.residual r₂) => by simp only [false_implies, implies_true] - | .ok (.value v₂) => by simp [h_spetv x₂ h_req v₂ hx₂, hx₂] - case false => - exact match hx₃ : Partial.evaluate x₃ req entities with - | .error e' => by simp [hx₃, ih₃ e'] - | .ok (.residual r₃) => by simp only [false_implies, implies_true] - | .ok (.value v₃) => by simp [h_spetv x₃ h_req v₃ hx₃, hx₃] - -end Cedar.Thm.Partial.Evaluation.Evaluate.Ite diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Or.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Or.lean deleted file mode 100644 index 2299f5438..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Or.lean +++ /dev/null @@ -1,70 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.Props - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Or - -open Cedar.Data -open Cedar.Spec (Expr) - -/-- - If partial-evaluating an `Expr.or` produces `ok` with a concrete - value, then so would partial-evaluating either of the operands, unless the - `or` short-circuits --/ -theorem evals_to_concrete_then_operands_eval_to_concrete {x₁ x₂ : Expr} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.or x₁ x₂) request entities → - Partial.evaluate x₁ request entities = .ok (.value true) ∨ - (EvaluatesToConcrete x₁ request entities ∧ EvaluatesToConcrete x₂ request entities) -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> cases hx₂ : Partial.evaluate x₂ request entities - <;> simp only [hx₁, hx₂, Spec.Value.asBool, Except.bind_ok, Except.bind_err] at h₁ - case ok.ok pval₁ pval₂ => - cases pval₁ - case residual r₁ => simp only [Except.ok.injEq] at h₁ - case value v₁ => - cases pval₂ - case value v₂ => right ; exact And.intro (by exists v₁) (by exists v₂) - case residual r₂ => - cases v₁ - case prim p₁ => - cases p₁ <;> simp only [Except.bind_ok, Except.bind_err] at h₁ - case bool b₁ => cases b₁ <;> simp at * - case set | record => simp at h₁ - case ext x => cases x <;> simp at h₁ - case ok.error pval e => - cases pval <;> simp only [Except.ok.injEq] at h₁ - case value v => - cases v - case prim p => - cases p <;> simp only [Except.bind_ok, Except.bind_err] at h₁ - case bool b => - cases b - <;> simp only [reduceIte, Except.ok.injEq, Partial.Value.value.injEq] at h₁ - <;> simp [h₁] - case set | record => simp at h₁ - case ext x => cases x <;> simp at h₁ - -end Cedar.Thm.Partial.Evaluation.Evaluate.Or diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Record.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Record.lean deleted file mode 100644 index b9116c7bf..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Record.lean +++ /dev/null @@ -1,368 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Partial.Value -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.Map -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Record - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr Error Expr Result) - -/-- - `Partial.bindAttr` on concrete arguments is the same as `Spec.bindAttr` on - those arguments --/ -theorem bindAttr_on_concrete_eqv_concrete {a : Attr} {res : Result Spec.Value} : - Partial.bindAttr a (res.map Partial.Value.value) = (Spec.bindAttr a res).map λ (k, v) => (k, Partial.Value.value v) -:= by - unfold Partial.bindAttr Spec.bindAttr - cases res <;> simp [Except.map] - -/-- - `List.mapM_pmap_subtype` specialized for a particular setting involving pairs - and `Spec.bindAttr` --/ -private theorem mapM_pmap_subtype_spec_bindAttr - {p : (Attr × β) → Prop} - (f : β → Result Spec.Value) - (pairs: List (Attr × β)) - (h : ∀ pair ∈ pairs, p pair) : - List.mapM (λ x : {pair : (Attr × β) // p pair} => Spec.bindAttr x.val.fst (f x.val.snd)) (List.pmap Subtype.mk pairs h) = - pairs.mapM (λ x => Spec.bindAttr x.fst (f x.snd)) -:= by - rw [←List.mapM'_eq_mapM] - induction pairs <;> simp [*] - -/-- - `List.mapM_pmap_subtype` specialized for a particular setting involving pairs - and `Partial.bindAttr` --/ -private theorem mapM_pmap_subtype_partial_bindAttr - {p : (Attr × β) → Prop} - (f : β → Result Partial.Value) - (pairs: List (Attr × β)) - (h : ∀ pair ∈ pairs, p pair) : - List.mapM (λ x : {pair : (Attr × β) // p pair} => Partial.bindAttr x.val.fst (f x.val.snd)) (List.pmap Subtype.mk pairs h) = - pairs.mapM (λ x => Partial.bindAttr x.fst (f x.snd)) -:= by - rw [←List.mapM'_eq_mapM] - induction pairs <;> simp [*] - -/-- - `List.mapM₂_eq_mapM` specialized for a particular setting involving pairs and - `Spec.bindAttr` --/ -private theorem mapM₂_eq_mapM_spec_bindAttr [SizeOf β] - (f : β → Result Spec.Value) - (attrs : List (Attr × β)) : - attrs.mapM₂ - (λ x : {x : Attr × β // sizeOf x.snd < 1 + sizeOf attrs} => match x with - | ⟨(a, b), _⟩ => Spec.bindAttr a (f b) - ) = - attrs.mapM λ (a, b) => Spec.bindAttr a (f b) -:= by - simp [List.mapM₂, List.attach₂, mapM_pmap_subtype_spec_bindAttr] - -/-- - `List.mapM₂_eq_mapM` specialized for a particular setting involving pairs and - `Partial.bindAttr` --/ -private theorem mapM₂_eq_mapM_partial_bindAttr [SizeOf β] - (f : β → Result Partial.Value) - (attrs : List (Attr × β)) : - attrs.mapM₂ - (λ x : {x : Attr × β // sizeOf x.snd < 1 + sizeOf attrs} => match x with - | ⟨(a, b), _⟩ => Partial.bindAttr a (f b) - ) = - attrs.mapM λ (a, b) => Partial.bindAttr a (f b) -:= by - simp [List.mapM₂, List.attach₂, mapM_pmap_subtype_partial_bindAttr] - -/-- - Inductive argument that, for an `Expr.record` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {attrs : List (Attr × Expr)} {request : Spec.Request} {entities : Spec.Entities} : - (∀ kv ∈ attrs, PartialEvalEquivConcreteEval kv.snd request entities) → - PartialEvalEquivConcreteEval (Expr.record attrs) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only - rw [mapM₂_eq_mapM_spec_bindAttr (Spec.evaluate · request entities)] - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · request entities)] - induction attrs - case nil => simp [Except.map, pure, Except.pure] - case cons kv tl ih => - specialize ih (by - intro kv' h₁ - exact ih₁ kv' (List.mem_cons_of_mem kv h₁) - ) - cases h₁ : Spec.bindAttr kv.fst (Spec.evaluate kv.snd request entities) - <;> cases h₂ : Partial.bindAttr kv.fst (Partial.evaluate kv.snd request entities) - <;> cases h₃ : Spec.evaluate kv.snd request entities - <;> simp only [h₁, h₂, List.mapM_cons, Except.bind_err, Except.bind_ok, bind_assoc, pure_bind, Option.pure_def, Option.bind_eq_bind, List.map_cons, List.mapM_cons] - <;> simp only [ih₁ kv, Except.map, true_or, List.mem_cons] at h₂ - <;> simp only [h₃, Spec.bindAttr, Partial.bindAttr, Except.bind_ok, Except.bind_err, Except.error.injEq, Except.ok.injEq] at h₁ h₂ - case error.error.error e₁ e₂ e₃ => - simp only [Except.map, Except.error.injEq] - subst h₁ h₂ - rfl - case ok.ok.ok val' pval val => - subst h₁ h₂ - simp only [Option.some_bind] - -- the remaning goal is just a statement about `tl`, not `kv` itself - -- so we can dispatch it using `ih` - generalize h₃ : (tl.mapM λ x => Partial.bindAttr x.fst (Partial.evaluate x.snd request entities)) = pres at * - generalize h₄ : (tl.mapM λ x => Spec.bindAttr x.fst (Spec.evaluate x.snd request entities)) = sres at * - cases pres <;> cases sres - <;> simp only [Except.map, List.mem_cons, forall_eq_or_imp, Except.bind_ok, Except.bind_err, Except.error.injEq] at * - case error.error e₁ e₂ => exact ih - case ok.error pvals e => split at ih <;> simp at ih - case ok.ok pvals vals => - split at ih <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, - Spec.Value.record.injEq] at ih - case h_1 vals' h₂ => - simp only [h₂, Option.some_bind, Except.ok.injEq, Partial.Value.value.injEq, - Spec.Value.record.injEq] - exact Map.make_cons ih - -/-- - Inductive argument that if partial-evaluating an `Expr.record` produces - `ok` with some value, that value is well-formed --/ -theorem partial_eval_wf {attrs: List (Attr × Expr)} {request : Partial.Request} {entities : Partial.Entities} - (ih : ∀ kv ∈ attrs, EvaluatesToWellFormed kv.snd request entities) : - EvaluatesToWellFormed (Expr.record attrs) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · request entities)] - cases hkv : attrs.mapM (λ kv => match kv with | (k, v) => Partial.bindAttr k (Partial.evaluate v request entities)) - <;> simp only [Except.bind_ok, Except.bind_err, false_implies, implies_true] - case ok pvals => - replace hkv := List.mapM_ok_implies_all_from_ok hkv - split <;> simp only [Except.ok.injEq, forall_eq'] - · simp only [Partial.Value.WellFormed, Spec.Value.WellFormed] - rename_i vs h₂ - apply And.intro (Map.make_wf vs) - intro kv h₃ - replace h₃ := Map.make_mem_list_mem h₃ - replace ⟨(k', pval'), h₄, h₂⟩ := List.mapM_some_implies_all_from_some h₂ kv h₃ - split at h₂ <;> simp at h₂ <;> subst h₂ - replace ⟨(k, v), h₅, hkv⟩ := hkv (k', pval') h₄ - rename_i v' h₆ - simp at h₆ ; subst h₆ - simp [Partial.bindAttr] at hkv - cases h₇ : Partial.evaluate v request entities <;> simp [h₇] at hkv - case ok pval' => - replace ⟨hkv, hkv'⟩ := hkv - subst k' pval' - simpa [Partial.Value.WellFormed] using ih (k, v) h₅ (.value v') h₇ - · simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - -/-- - If partial-evaluating an `Expr.record` produces `ok` with a concrete - value, then so would partial-evaluating any of the values it contains --/ -theorem evals_to_concrete_then_vals_eval_to_concrete {attrs : List (Attr × Expr)} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.record attrs) request entities → - ∀ kv ∈ attrs, EvaluatesToConcrete kv.snd request entities -:= by - unfold EvaluatesToConcrete - intro h₁ (k, x) h₂ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · request entities)] at h₁ - cases h₃ : attrs.mapM (λ kv => match kv with | (k, v) => Partial.bindAttr k (Partial.evaluate v request entities)) - <;> simp only [h₃, Except.bind_ok, Except.bind_err] at h₁ - case ok pvals => - replace ⟨(k', pval), h₃, h₄⟩ := List.mapM_ok_implies_all_ok h₃ (k, x) h₂ - split at h₁ <;> simp only [Except.ok.injEq, Partial.Value.value.injEq] at h₁ - subst h₁ - rename_i vs h₁ - replace ⟨(k'', v), _, h₁⟩ := List.mapM_some_implies_all_some h₁ (k', pval) h₃ - split at h₁ <;> simp only [Option.some.injEq, Prod.mk.injEq] at h₁ - replace ⟨h₁, h₁'⟩ := h₁ ; rename_i v' h₅ ; subst k'' v' - simp only at h₅ ; subst pval - simp only [Partial.bindAttr] at h₄ - cases h₅ : Partial.evaluate x request entities - <;> simp only [h₅, Except.bind_ok, Except.bind_err, Except.ok.injEq, Prod.mk.injEq] at h₄ - case ok pval => - replace ⟨h₄, h₄'⟩ := h₄ ; subst k' pval - exists v - -/-- - Lemma: - - Inductive argument that if `mapM` on a list of attrs produces `.ok` with a - list of concrete vals, then it produces the same list of concrete vals after - any substitution of unknowns --/ -theorem mapM_subst_snd_preserves_evaluation_to_values {attrs : List (Attr × Expr)} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ kv ∈ attrs, SubstPreservesEvaluationToConcrete kv.snd req req' entities subsmap) : - req.subst subsmap = some req' → - ∀ (pvals : List (Attr × Partial.Value)), - attrs.mapM (λ kv => do .ok (kv.fst, (← Partial.evaluate kv.snd req entities))) = .ok pvals → - IsAllConcrete (pvals.map Prod.snd) → - attrs.mapM (λ kv => do .ok (kv.fst, (← Partial.evaluate kv.snd req' (entities.subst subsmap)))) = .ok pvals -:= by - intro h_req pvals h₁ h₂ - cases attrs - case nil => - simp only [List.not_mem_nil, false_implies, forall_const, List.mapM_nil, pure, Except.pure, - Except.ok.injEq, List.map_nil] at * - exact h₁ - case cons hd tl => - simp only [List.mem_cons, forall_eq_or_imp, List.mapM_cons, pure, Except.pure, bind_assoc, - Except.bind_ok, List.map_cons] at * - have ⟨ih_hd, ih_tl⟩ := ih ; clear ih - have (khd, xhd) := hd ; clear hd - simp only at * - cases h₃ : Partial.evaluate xhd req entities - <;> simp only [h₃, Except.bind_err, Except.bind_ok] at h₁ - case ok hd_pval => - unfold IsAllConcrete at h₂ - replace ⟨vs, h₂⟩ := h₂ - replace ⟨h₂, h₂'⟩ := And.intro (List.mapM_some_implies_all_some h₂) (List.mapM_some_implies_all_from_some h₂) - cases h₅ : tl.mapM (λ kv => do let v ← Partial.evaluate kv.snd req entities ; .ok (kv.fst, v)) - <;> simp only [h₅, Except.bind_ok, Except.ok.injEq, Except.bind_err] at h₁ - case ok tl_pvals => - subst h₁ - cases h₄ : Partial.evaluate xhd req' (entities.subst subsmap) - <;> simp only [Except.bind_err, Except.bind_ok] - case error e => - replace ⟨v, _, h₂⟩ := h₂ hd_pval (by simp) - cases hd_pval <;> simp only [Option.some.injEq] at h₂ - case value v' => - subst v' - unfold SubstPreservesEvaluationToConcrete at ih_hd - simp only [ih_hd h_req v h₃] at h₄ - case ok hd'_pval => - have ih₂ := mapM_subst_snd_preserves_evaluation_to_values ih_tl h_req tl_pvals h₅ (by - unfold IsAllConcrete - apply List.all_some_implies_mapM_some - intro tl_pval h₆ - replace ⟨v, _, h₂⟩ := h₂ tl_pval (by simp [h₆]) - exists v - ) - simp only [ih₂, Except.bind_ok, Except.ok.injEq, List.cons.injEq, Prod.mk.injEq, - true_and, and_true] - cases hd_pval <;> simp only [List.map_cons, List.mem_cons, List.mem_map, forall_eq_or_imp, - and_false, false_and, exists_const, forall_exists_index, and_imp, forall_apply_eq_imp_iff₂, - Option.some.injEq] at h₂ - case value hd_val => - unfold SubstPreservesEvaluationToConcrete at ih_hd - simp only [ih_hd h_req hd_val h₃, Except.ok.injEq] at h₄ - exact h₄.symm - -/-- Helper lemma proved by induction -/ -private theorem mapM_pairs_snd {pvals : List (Attr × Partial.Value)} {pairs : List (Attr × Spec.Value)}: - pvals.mapM (λ kv => match kv.snd with - | .value v => some (kv.fst, v) - | .residual _ => none) - = some pairs → - pvals.mapM (λ kv => match kv.snd with - | .value v => some v - | .residual _ => none) - = some (pairs.map Prod.snd) -:= by - intro h₁ - cases pvals <;> simp only [List.mapM_nil, List.mapM_cons, Option.pure_def, - Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq] at * - case nil => subst h₁ ; simp only [List.map_nil] - case cons hd tl => - have (khd, vhd) := hd ; clear hd - simp only at * - replace ⟨(khd', vhd'), h₁, h₂⟩ := h₁ - cases vhd <;> simp only [Option.some.injEq, Prod.mk.injEq, exists_eq_left'] at * - replace ⟨h₁, h₁'⟩ := h₁ ; subst khd' vhd' ; rename_i vhd - replace ⟨tl', h₂, h₃⟩ := h₂ - subst h₃ - exists (tl'.map Prod.snd) - simp only [List.map_cons, and_true] - exact mapM_pairs_snd h₂ - -/-- - Inductive argument that if partial-evaluation of an `Expr.record` - returns a concrete value, then it returns the same value after any - substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {attrs : List (Attr × Expr)} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ kv ∈ attrs, SubstPreservesEvaluationToConcrete kv.snd req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.record attrs) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete - unfold Partial.evaluate - intro h_req v - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · req entities)] - cases h₁ : attrs.mapM (λ kv => match kv with | (k, v) => Partial.bindAttr k (Partial.evaluate v req entities)) - <;> simp only [Except.bind_err, Except.bind_ok, Bool.not_eq_true', false_implies] - case ok pvals => - split <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, false_implies] - rename_i avs h₂ - -- avs are the concrete values produced by evaluating the record values pre-subst - intro h ; subst h - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · req' (entities.subst subsmap))] - simp only [Partial.bindAttr] at * - rw [mapM_subst_snd_preserves_evaluation_to_values ih h_req pvals h₁ (by - unfold IsAllConcrete - exists (avs.map Prod.snd) - simp only [List.mapM_map] - exact mapM_pairs_snd h₂ - )] - simp only [Except.bind_ok, h₂] - -/-- - Inductive argument that if partial-evaluation of an `Expr.record` - returns an error, then it also returns an error (not necessarily the same error) - after any substitution of unknowns --/ -theorem subst_preserves_errors {attrs : List (Attr × Expr)} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ kv ∈ attrs, SubstPreservesEvaluationToError kv.snd req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.record attrs) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - simp only [Partial.evaluate] - intro h_req e - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · req entities)] - rw [mapM₂_eq_mapM_partial_bindAttr (Partial.evaluate · req' (entities.subst subsmap))] - cases hattrs : attrs.mapM λ kv => Partial.bindAttr kv.fst (Partial.evaluate kv.snd req entities) - case error e' => - simp only [Except.bind_err, Except.error.injEq, List.mapM_map] - intro _ ; subst e' - replace ⟨(k, x), hx, hattrs⟩ := List.mapM_error_implies_exists_error hattrs - simp only [Partial.bindAttr, do_error] at hattrs - replace ⟨e', ih⟩ := ih (k, x) hx h_req e hattrs - have ⟨e'', h₁⟩ := List.element_error_implies_mapM_error hx (f := λ kv => Partial.bindAttr kv.fst (Partial.evaluate kv.snd req' (entities.subst subsmap))) (by - simp only [Partial.bindAttr, do_error] - exact ih - ) - simp only [h₁, Except.bind_err, Except.error.injEq, exists_eq'] - case ok pvals => - simp only [Except.bind_ok] - intro h₁ - split at h₁ <;> simp at h₁ - -end Cedar.Thm.Partial.Evaluation.Evaluate.Record diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Set.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Set.lean deleted file mode 100644 index 239689dee..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Set.lean +++ /dev/null @@ -1,250 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Policy -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.List -import Cedar.Thm.Data.LT -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Set - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr Result) - -/-- - Lemma (used for both the Set and Call cases): - - Inductive argument that `mapM`'ing partial evaluation over a list of exprs - gives the same output as `mapM`'ing concrete evaluation over the same exprs --/ -theorem mapM_partial_eval_eqv_concrete_eval {xs : List Expr} {request : Spec.Request} {entities : Spec.Entities} : - (∀ x ∈ xs, PartialEvalEquivConcreteEval x request entities) → - xs.mapM (λ x => Partial.evaluate x request entities) = (xs.mapM (Spec.evaluate · request entities)).map λ vs => vs.map Partial.Value.value -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - induction xs - case nil => simp [Except.map, pure, Except.pure] - case cons hd tl ih => - specialize ih (by - intro x' h₁ - exact ih₁ x' (List.mem_cons_of_mem hd h₁) - ) - cases h₁ : Spec.evaluate hd request entities - <;> cases h₂ : Partial.evaluate hd request entities - <;> simp only [h₁, h₂, List.mapM_cons, Except.bind_err, Except.bind_ok] - case error.error e₁ e₂ => - simp only [ih₁ hd, h₁, Except.map, List.mem_cons, true_or, Except.error.injEq] at h₂ - simp only [h₂, Except.map] - case ok.error val e | error.ok e pval => - simp [ih₁ hd, h₁, Except.map] at h₂ - case ok.ok val pval => - simp only [ih₁, h₁, Except.map, List.mem_cons, true_or, Except.ok.injEq] at h₂ - subst h₂ - -- the remaining goal is just a statement about `tl`, not `hd` itself - -- so we can dispatch it using `ih` - generalize h₃ : (tl.mapM λ x => Partial.evaluate x request entities) = pres at * - generalize h₄ : (tl.mapM λ x => Spec.evaluate x request entities) = sres at * - cases pres <;> cases sres - <;> simp only [Except.map, pure, Except.pure, List.mem_cons, Except.error.injEq, Except.ok.injEq, Except.bind_ok, Except.bind_err, List.cons.injEq, List.map_cons, forall_eq_or_imp, true_and] at * - case error.error e₁ e₂ => exact ih - case ok.ok pvals vals => exact ih - -/-- - Inductive argument that, for an `Expr.set` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval {xs : List Expr} {request : Spec.Request} {entities : Spec.Entities} : - (∀ x ∈ xs, PartialEvalEquivConcreteEval x request entities) → - PartialEvalEquivConcreteEval (Expr.set xs) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] - rw [List.mapM₁_eq_mapM (Spec.evaluate · request entities)] - rw [mapM_partial_eval_eqv_concrete_eval ih₁] - cases xs.mapM (Spec.evaluate · request entities) <;> simp only [Except.map, Except.bind_err, Except.bind_ok] - case ok vs => simp [List.mapM_map, List.mapM_some] - -/-- - Inductive argument that if partial-evaluating an `Expr.set` produces - `ok` with some value, that value is well-formed --/ -theorem partial_eval_wf {xs : List Expr} {request : Partial.Request} {entities : Partial.Entities} - (ih : ∀ x ∈ xs, EvaluatesToWellFormed x request entities) : - EvaluatesToWellFormed (Expr.set xs) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] - cases hx : xs.mapM (Partial.evaluate · request entities) - <;> simp only [Except.bind_ok, Except.bind_err, false_implies, implies_true] - case ok pvals => - split <;> simp only [Except.ok.injEq, forall_eq'] - · simp only [Partial.Value.WellFormed, Spec.Value.WellFormed] - rename_i vs h₂ - apply And.intro (Set.make_wf vs) - intro v h₃ - replace h₃ := (Set.make_mem _ _).mpr h₃ - replace ⟨pval, h₄, h₂⟩ := List.mapM_some_implies_all_from_some h₂ v h₃ - replace ⟨x, h₅, hx⟩ := List.mapM_ok_implies_all_from_ok hx pval h₄ - split at h₂ <;> simp at h₂ - rename_i v' ; subst v' - simpa [Partial.Value.WellFormed] using ih x h₅ (.value v) hx - · simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - -/-- - If partial-evaluating an `Expr.set` produces `ok` with a concrete - value, then so would partial-evaluating any of the elements --/ -theorem evals_to_concrete_then_elts_eval_to_concrete {xs : List Expr} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.set xs) request entities → - ∀ x ∈ xs, EvaluatesToConcrete x request entities -:= by - unfold EvaluatesToConcrete - intro h₁ x h₂ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - rw [List.mapM₁_eq_mapM (Partial.evaluate · request entities)] at h₁ - cases h₃ : xs.mapM (Partial.evaluate · request entities) - <;> simp only [h₃, Except.bind_err, Except.bind_ok] at h₁ - case ok pvals => - replace ⟨pval, h₃, h₄⟩ := List.mapM_ok_implies_all_ok h₃ x h₂ - split at h₁ <;> simp only [Except.ok.injEq, Partial.Value.value.injEq] at h₁ - subst h₁ - rename_i vs h₁ - replace ⟨v, _, h₁⟩ := List.mapM_some_implies_all_some h₁ pval h₃ - cases pval <;> simp only [Option.some.injEq] at h₁ - case value v' => subst v' ; exists v - -/-- - Lemma (used for both the Set and Call cases): - - Inductive argument that if `mapM` on a list of partial exprs produces `.ok` - with a list of concrete vals, then it produces the same list of concrete vals - after any substitution of unknowns --/ -theorem mapM_subst_preserves_evaluation_to_values {xs : List Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ x ∈ xs, SubstPreservesEvaluationToConcrete x req req' entities subsmap) : - req.subst subsmap = some req' → - ∀ (pvals : List Partial.Value), - xs.mapM (Partial.evaluate · req entities) = .ok pvals → - IsAllConcrete pvals → - xs.mapM (Partial.evaluate · req' (entities.subst subsmap)) = .ok pvals -:= by - intro h_req pvals h₁ h₂ - cases xs - case nil => - simp only [List.not_mem_nil, false_implies, forall_const, List.mapM_nil, pure, Except.pure, - Except.ok.injEq, List.map_nil] at * - exact h₁ - case cons hd tl => - simp only [List.mem_cons, forall_eq_or_imp, List.mapM_cons, pure, Except.pure, - List.map_cons] at * - have ⟨ih_hd, ih_tl⟩ := ih ; clear ih - cases h₃ : Partial.evaluate hd req entities - <;> simp only [h₃, Except.bind_ok, Except.bind_err] at h₁ - case ok hd_pval => - unfold IsAllConcrete at h₂ - replace ⟨vs, h₂⟩ := h₂ - replace ⟨h₂, h₂'⟩ := And.intro (List.mapM_some_implies_all_some h₂) (List.mapM_some_implies_all_from_some h₂) - cases h₅ : tl.mapM (Partial.evaluate · req entities) - <;> simp only [h₅, Except.bind_ok, Except.bind_err, Except.ok.injEq] at h₁ - case ok tl_pvals => - subst h₁ - cases h₄ : Partial.evaluate hd req' (entities.subst subsmap) - <;> simp only [Except.bind_ok, Except.bind_err] - case error e => - replace ⟨v, _, h₂⟩ := h₂ hd_pval (by simp) - cases hd_pval <;> simp only [Option.some.injEq] at h₂ - case value v' => - subst v' - unfold SubstPreservesEvaluationToConcrete at ih_hd - simp only [ih_hd h_req v h₃] at h₄ - case ok hd'_pval => - have ih₂ := mapM_subst_preserves_evaluation_to_values ih_tl h_req tl_pvals h₅ (by - unfold IsAllConcrete - apply List.all_some_implies_mapM_some - intro tl_pval h₆ - replace ⟨v, _, h₂⟩ := h₂ tl_pval (by simp [h₆]) - exists v - ) - simp only [ih₂, Except.bind_ok, Except.ok.injEq, List.cons.injEq, and_true] - cases hd_pval <;> simp only [List.mem_cons, forall_eq_or_imp, and_false, false_and, - exists_const, Option.some.injEq] at h₂ - case value hd_val => - unfold SubstPreservesEvaluationToConcrete at ih_hd - simp only [ih_hd h_req hd_val h₃, Except.ok.injEq] at h₄ - exact h₄.symm - -/-- - Inductive argument that if partial-evaluation of an `Expr.set` returns - a concrete value, then it returns the same value after any substitution of - unknowns --/ -theorem subst_preserves_evaluation_to_value {xs : List Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ x ∈ xs, SubstPreservesEvaluationToConcrete x req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.set xs) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete - unfold Partial.evaluate - intro h_req v - rw [List.mapM₁_eq_mapM (Partial.evaluate · req entities)] - cases h₁ : xs.mapM (Partial.evaluate · req entities) - <;> simp only [Except.bind_err, Except.bind_ok, Bool.not_eq_true', false_implies] - case ok pvals => - split <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, false_implies] - rename_i vs h₂ - -- vs are the concrete values produced by evaluating the set elements pre-subst - intro h ; subst h - rw [List.mapM₁_eq_mapM (Partial.evaluate · req' (entities.subst subsmap))] - rw [mapM_subst_preserves_evaluation_to_values ih h_req pvals h₁ (by unfold IsAllConcrete ; exists vs)] - simp only [h₂, Except.bind_ok] - -/-- - Inductive argument that if partial-evaluation of an `Expr.set` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns --/ -theorem subst_preserves_errors {xs : List Expr} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih : ∀ x ∈ xs, SubstPreservesEvaluationToError x req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.set xs) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - simp only [Partial.evaluate] - intro h_req e - rw [List.mapM₁_eq_mapM (Partial.evaluate · req entities)] - rw [List.mapM₁_eq_mapM (Partial.evaluate · req' (entities.subst subsmap))] - cases hxs : xs.mapM (Partial.evaluate · req entities) - case error e' => - simp only [Except.bind_err, Except.error.injEq, List.mapM_map] - intro _ ; subst e' - replace ⟨x, hx, hxs⟩ := List.mapM_error_implies_exists_error hxs - replace ⟨e', ih⟩ := ih x hx h_req e hxs - have ⟨e'', h₁⟩ := List.element_error_implies_mapM_error hx (f := λ x => Partial.evaluate x req' (entities.subst subsmap)) ih - simp only [h₁, Except.bind_err, Except.error.injEq, exists_eq'] - case ok pvals => - simp only [Except.bind_ok] - intro h₁ - split at h₁ <;> simp at h₁ - -end Cedar.Thm.Partial.Evaluation.Evaluate.Set diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Unary.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Unary.lean deleted file mode 100644 index 6c69f2fcc..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Unary.lean +++ /dev/null @@ -1,140 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.EvaluateUnaryApp -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Unary - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr Prim UnaryOp) - -/-- - Inductive argument that, for an `Expr.unaryApp` with concrete - request/entities, partial evaluation and concrete evaluation give the same - output --/ -theorem on_concrete_eqv_concrete_eval {x₁ : Expr} {request : Spec.Request} {entities : Spec.Entities} {op : UnaryOp} : - PartialEvalEquivConcreteEval x₁ request entities → - PartialEvalEquivConcreteEval (Expr.unaryApp op x₁) request entities -:= by - unfold PartialEvalEquivConcreteEval - intro ih₁ - unfold Partial.evaluate Spec.evaluate - simp only [ih₁] - cases Spec.evaluate x₁ request entities <;> simp only [Except.bind_err, Except.bind_ok] - case error e => simp [Except.map] - case ok v₁ => rfl - -/-- - Inductive argument that if partial-evaluating an `Expr.unaryApp` - produces `ok` with some value, that value is well-formed - - This theorem does not actually require that x₁ is WellFormed --/ -theorem partial_eval_wf {x₁ : Expr} {op : UnaryOp} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToWellFormed (Expr.unaryApp op x₁) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - intro pval - cases hx₁ : Partial.evaluate x₁ request entities <;> simp [hx₁] - case ok pval₁ => exact EvaluateUnaryApp.evaluateUnaryApp_wf - -/-- - If partial-evaluating an `Expr.unaryApp` produces `ok` with a concrete - value, then so would partial-evaluating its operand --/ -theorem evals_to_concrete_then_operand_evals_to_concrete {x₁ : Expr} {op : UnaryOp} {request : Partial.Request} {entities : Partial.Entities} : - EvaluatesToConcrete (Expr.unaryApp op x₁) request entities → - EvaluatesToConcrete x₁ request entities -:= by - unfold EvaluatesToConcrete - intro h₁ - unfold Partial.evaluate at h₁ - replace ⟨v, h₁⟩ := h₁ - cases hx₁ : Partial.evaluate x₁ request entities - <;> simp only [hx₁, Except.bind_err, Except.bind_ok] at h₁ - case ok pval₁ => - have ⟨v₁, hv₁⟩ := EvaluateUnaryApp.returns_concrete_then_operand_evals_to_concrete h₁ - subst pval₁ - exists v₁ - -/-- - Inductive argument that if partial-evaluation of an `Expr.unaryApp` - returns a concrete value, then it returns the same value after any - substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {x₁ : Expr} {op : UnaryOp} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (ih₁ : SubstPreservesEvaluationToConcrete x₁ req req' entities subsmap) : - SubstPreservesEvaluationToConcrete (Expr.unaryApp op x₁) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete at * - unfold Partial.evaluate - intro h_req v - specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, Except.ok.injEq, Except.bind_ok, Except.bind_err, false_implies, forall_const] at * - case ok pval₁ => - cases pval₁ - case residual r₁ => simp only [Partial.evaluateUnaryApp, Except.ok.injEq, false_implies] - case value v₁ => - simp only [Partial.Value.value.injEq, forall_eq'] at ih₁ - simp only [ih₁, Except.bind_ok, imp_self] - -/-- - Inductive argument that if partial-evaluation of an `Expr.unaryApp` - returns an error, then it also returns an error (not necessarily the same - error) after any substitution of unknowns - - The proof of `subst_preserves_evaluation_to_value` for this - request/entities/subsmap is passed in as an argument, because this file can't - import `Thm/Partial/Evaluation.lean` to access it. - See #372. --/ -theorem subst_preserves_errors {x₁ : Expr} {op : UnaryOp} {req req' : Partial.Request} {entities : Partial.Entities} {subsmap : Subsmap} - (h_spetv : ∀ x, SubstPreservesEvaluationToConcrete x req req' entities subsmap) - (ih₁ : SubstPreservesEvaluationToError x₁ req req' entities subsmap) : - SubstPreservesEvaluationToError (Expr.unaryApp op x₁) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToError at * - unfold Partial.evaluate - intro h_req ; specialize ih₁ h_req - cases hx₁ : Partial.evaluate x₁ req entities - <;> simp only [hx₁, false_implies, implies_true, Except.error.injEq] at ih₁ - case error e₁ => - replace ⟨e₁', ih₁⟩ := ih₁ e₁ rfl - simp [ih₁] - case ok pval₁ => - simp only [Except.bind_ok] - intro e₁ h₁ - cases hx₁' : Partial.evaluate x₁ req' (entities.subst subsmap) - case error e₁' => exists e₁' - case ok pval₁' => - simp only [Except.bind_ok] - cases pval₁ - case residual r₁ => exists e₁ - case value v₁ => - simp only [h_spetv x₁ h_req v₁ hx₁, Except.ok.injEq] at hx₁' ; subst pval₁' - exists e₁ - - -end Cedar.Thm.Partial.Evaluation.Evaluate.Unary diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Var.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Var.lean deleted file mode 100644 index 62e4bbe00..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Evaluate/Var.lean +++ /dev/null @@ -1,281 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.LT -import Cedar.Thm.Data.List -import Cedar.Thm.Data.Map -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Subst -import Cedar.Thm.Partial.WellFormed - -namespace Cedar.Thm.Partial.Evaluation.Evaluate.Var - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr Error Expr Prim Var) - -/-- - `Partial.evaluateVar` on concrete arguments gives the same output as - `Spec.evaluate` on those arguments --/ -theorem evaluateVar_on_concrete_eqv_concrete_eval (v : Var) (request : Spec.Request) (entities : Spec.Entities) - (wf : request.context.WellFormed) : - Partial.evaluateVar v request = (Spec.evaluate (Expr.var v) request entities).map Partial.Value.value -:= by - unfold Partial.evaluateVar Spec.evaluate - cases v <;> simp only [Spec.Request.asPartialRequest, Except.map] - case context => - split - case h_1 m h₁ => - simp only [Except.ok.injEq, Partial.Value.value.injEq, Spec.Value.record.injEq] - rw [← Map.eq_iff_kvs_equiv (wf₁ := Map.mapMOnValues_some_wf (Map.mapOnValues_wf.mp wf) h₁) (wf₂ := wf)] - simp only [List.Equiv, List.subset_def] - constructor - case left => - intro (k, v) h₂ - rw [Map.mapOnValues_eq_make_map _ wf] at h₁ - unfold Map.toList at h₁ - replace ⟨pv, h₁, h₃⟩ := Map.mapMOnValues_some_implies_all_from_some h₁ (k, v) h₂ - replace h₁ := Map.make_mem_list_mem h₁ - cases pv <;> simp only [Option.some.injEq] at h₃ - case value v => - subst v - rw [List.mem_map] at h₁ - replace ⟨(k', v'), h₁, h₃⟩ := h₁ - simp only [Prod.mk.injEq, Partial.Value.value.injEq] at h₃ - replace ⟨h₃, h₃'⟩ := h₃ - subst k' v' - exact h₁ - case right => - intro (k, v) h₂ - have ⟨v', h₃, h₄⟩ := Map.mapMOnValues_some_implies_all_some h₁ (k, v) (Map.in_kvs_in_mapOnValues h₂) - simp only [Option.some.injEq] at h₄ - subst h₄ - simp [h₃] - case h_2 h₁ => - exfalso - replace ⟨v, h₁, h₂⟩ := Map.mapMOnValues_none_iff_exists_none.mp h₁ - cases v <;> simp only at h₂ - case residual r => - rw [Map.mapOnValues_eq_make_map _ wf] at h₁ - replace h₁ := Map.mem_values_make h₁ - simp [List.mem_map] at h₁ - -/-- - Inductive argument that, for an `Expr.var` with concrete request/entities, - partial evaluation and concrete evaluation give the same output --/ -theorem on_concrete_eqv_concrete_eval (v : Var) (request : Spec.Request) (entities : Spec.Entities) - (wf : request.context.WellFormed) : - PartialEvalEquivConcreteEval (Expr.var v) request entities -:= by - unfold PartialEvalEquivConcreteEval Partial.evaluate - exact evaluateVar_on_concrete_eqv_concrete_eval v request entities wf - -/-- - if `Partial.evaluateVar` returns `ok` with some value, it is a well-formed value --/ -theorem evaluateVar_wf {v : Var} {request : Partial.Request} - (wf_r : request.WellFormed) : - ∀ pval, Partial.evaluateVar v request = .ok pval → pval.WellFormed -:= by - unfold Partial.evaluateVar - cases v <;> simp - case principal => - cases request.principal - <;> simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - case action => - cases request.action - <;> simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - case resource => - cases request.resource - <;> simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - case context => - split <;> simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed, Spec.Value.WellFormed] - · rename_i m h₁ - apply And.intro (Map.mapMOnValues_some_wf wf_r.left h₁) - intro (k, v) h₂ - replace wf_r := wf_r.right (.value v) - simp [Partial.Value.WellFormed] at wf_r - apply wf_r ; clear wf_r - replace ⟨pval, h₁, h₃⟩ := Map.mapMOnValues_some_implies_all_from_some h₁ (k, v) h₂ - cases pval <;> simp at h₃ ; subst v ; rename_i v - exact Map.in_list_in_values h₁ - -/-- - If partial-evaluating a `Var` expression returns `ok` with some value, it is a - well-formed value --/ -theorem partial_eval_wf {v : Var} {request : Partial.Request} {entities : Partial.Entities} - (wf_r : request.WellFormed) : - EvaluatesToWellFormed (Expr.var v) request entities -:= by - unfold EvaluatesToWellFormed Partial.evaluate - exact evaluateVar_wf wf_r - -/-- - Lemma: If `context` has only concrete values before substitution, then it has - only concrete values after substitution --/ -theorem subst_preserves_all_concrete {req req' : Partial.Request} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - req.context.mapMOnValues (λ v => match v with | .value v => some v | .residual _ => none) = some m → - (k, pval') ∈ req'.context.kvs → - ∃ v, pval' = .value v ∧ (k, .value v) ∈ req.context.kvs -:= by - intro h_req h₁ h₂ - have wf_req' : req'.WellFormed := Subst.req_subst_preserves_wf wf_r wf_s h_req - unfold Partial.Request.WellFormed at wf_r wf_req' - have h_keys := Subst.req_subst_preserves_keys_of_context h_req - have wf_keys := Map.keys_wf req.context wf_r.left - have ⟨keys, h₃⟩ := Set.if_wellformed_then_exists_make req.context.keys wf_keys - rw [h₃] at h_keys - unfold Map.keys at h_keys h₃ - replace h_keys := Set.make_mk_eqv h_keys - replace h₃ := Set.make_mk_eqv h₃.symm - simp only [List.Equiv, List.subset_def, List.mem_map, forall_exists_index, and_imp, - forall_apply_eq_imp_iff₂] at h_keys h₃ - replace ⟨_, h_keys⟩ := h_keys - replace ⟨h₃, _⟩ := h₃ - specialize h_keys (k, pval') h₂ - simp only at h_keys - replace ⟨(k', pval), h₃, h₃'⟩ := h₃ h_keys - simp only at h₃' ; subst k' - replace h₁ := Map.mapMOnValues_some_implies_all_some h₁ (k, pval) h₃ - cases pval - case residual r => simp only [and_false, exists_const] at h₁ - case value v => - have h₄ := Subst.req_subst_preserves_concrete_context_vals h₃ h_req - have h₅ := Map.key_maps_to_one_value k _ _ _ wf_req'.left h₂ h₄ - exists v - -/-- - If evaluating a request context returns a concrete value, then it returns the - same value after any substitution of unknowns --/ -theorem subst_preserves_evaluate_req_context_to_value {req req' : Partial.Request} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - req.context.mapMOnValues (λ v => match v with | .value v => some v | .residual _ => none) = some m → - req'.context.mapMOnValues (λ v => match v with | .value v => some v | .residual _ => none) = some m -:= by - intro h_req h₁ - suffices req.context = req'.context by rw [← this] ; exact h₁ - have wf_req' : req'.WellFormed := Subst.req_subst_preserves_wf wf_r wf_s h_req - unfold Partial.Request.WellFormed at wf_req' - apply (Map.eq_iff_kvs_equiv wf_r.left wf_req'.left).mp - simp only [List.Equiv, List.subset_def] - constructor <;> intro (k, pval') h₄ - · replace h₁ := Map.mapMOnValues_some_implies_all_some h₁ (k, pval') h₄ - cases pval' - case value v => exact Subst.req_subst_preserves_concrete_context_vals h₄ h_req - case residual r => simp only [and_false, exists_const] at h₁ - · have ⟨v, h₃, h₅⟩ := subst_preserves_all_concrete wf_r wf_s h_req h₁ h₄ - subst pval' - exact h₅ - -/-- - If `Partial.evaluateVar` returns a concrete value, then it returns the same - value after any substitution of unknowns --/ -theorem subst_preserves_evaluateVar_to_value {var : Var} {req req' : Partial.Request} {v : Spec.Value} {subsmap : Subsmap} - (wf_r : req.WellFormed) - (wf_s : subsmap.WellFormed) : - req.subst subsmap = some req' → - Partial.evaluateVar var req = .ok (.value v) → - Partial.evaluateVar var req' = .ok (.value v) -:= by - unfold Partial.evaluateVar - intro h_req h₁ - cases var <;> simp only at h₁ - case principal => - cases h₂ : req.principal <;> simp only [h₂, Except.ok.injEq, Partial.Value.value.injEq] at h₁ - case known uid => - subst h₁ - simp [Subst.req_subst_preserves_known_principal h₂ h_req] - case action => - cases h₂ : req.action <;> simp only [h₂, Except.ok.injEq, Partial.Value.value.injEq] at h₁ - case known uid => - subst h₁ - simp [Subst.req_subst_preserves_known_action h₂ h_req] - case resource => - cases h₂ : req.resource <;> simp only [h₂, Except.ok.injEq, Partial.Value.value.injEq] at h₁ - case known uid => - subst h₁ - simp [Subst.req_subst_preserves_known_resource h₂ h_req] - case context => - simp only - split at h₁ <;> simp only [Except.ok.injEq, Partial.Value.value.injEq] at h₁ ; subst h₁ - rename_i m h₁ - -- `m` is the `Spec.Value`-valued version of `req.context` (which we know has only concrete values from h₁) - split <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, Spec.Value.record.injEq] - · rename_i m' h₂ - -- `m'` is the `Spec.Value`-valued version of `req'.context` (which we know has only concrete values from h₂) - replace h₁ := subst_preserves_evaluate_req_context_to_value wf_r wf_s h_req h₁ - suffices some m = some m' by simpa using this.symm - rw [← h₁, ← h₂] - rfl - · rename_i h₂ - replace ⟨pval, h₂, h₃⟩ := Map.mapMOnValues_none_iff_exists_none.mp h₂ - cases pval <;> simp only at h₃ - case residual r => - replace ⟨k, h₂⟩ := Map.in_values_exists_key h₂ - have ⟨v, h₄⟩ := subst_preserves_all_concrete wf_r wf_s h_req h₁ h₂ - simp at h₄ - -/-- - If partial-evaluation of a `Var` returns a concrete value, then it returns the - same value after any substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value (var : Var) (req req' : Partial.Request) (entities : Partial.Entities) (subsmap : Subsmap) - (wf_r : req.WellFormed) - (wf_s : subsmap.WellFormed) : - SubstPreservesEvaluationToConcrete (Expr.var var) req req' entities subsmap -:= by - unfold SubstPreservesEvaluationToConcrete Partial.evaluate - intro h_req v - exact subst_preserves_evaluateVar_to_value wf_r wf_s h_req - -/-- - If `Partial.evaluateVar` returns an error, then it returns the same error - after any substitution of unknowns --/ -theorem subst_preserves_evaluateVar_to_error {var : Var} {req req' : Partial.Request} {e : Error} {subsmap : Subsmap} : - req.subst subsmap = some req' → - Partial.evaluateVar var req = .error e → Partial.evaluateVar var req' = .error e -:= by - cases var <;> simp only [Partial.evaluateVar, imp_self, implies_true] - case context => split <;> split <;> simp - -/-- - If partial-evaluation of a `Var` returns an error, then it returns the same - error after any sustitution of unknowns --/ -theorem subst_preserves_errors {var : Var} {req req' : Partial.Request} {e : Error} {subsmap : Subsmap} : - req.subst subsmap = some req' → - Partial.evaluate (Expr.var var) req entities = .error e → - Partial.evaluate (Expr.var var) req' (entities.subst subsmap) = .error e -:= by - simp only [Partial.evaluate] - exact subst_preserves_evaluateVar_to_error - -end Cedar.Thm.Partial.Evaluation.Evaluate.Var diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateBinaryApp.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateBinaryApp.lean deleted file mode 100644 index faeeba254..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateBinaryApp.lean +++ /dev/null @@ -1,408 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Partial.Subst - -/-! Theorems about `Partial.evaluateBinaryApp` -/ - -namespace Cedar.Thm.Partial.Evaluation.EvaluateBinaryApp - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (BinaryOp EntityUID Expr intOrErr Prim Result) - -/-- - `Partial.Entities.ancestorsOrEmpty` on concrete entities is the same as - `Spec.Entities.ancestorsOrEmpty` on those entities --/ -theorem ancestorsOrEmpty_on_concrete_eqv_concrete {entities : Spec.Entities} {uid : EntityUID} : - Partial.Entities.ancestorsOrEmpty entities uid = Spec.Entities.ancestorsOrEmpty entities uid -:= by - unfold Partial.Entities.ancestorsOrEmpty Spec.Entities.ancestorsOrEmpty - unfold Spec.Entities.asPartialEntities Spec.EntityData.asPartialEntityData - rw [← Map.find?_mapOnValues] - cases entities.find? uid <;> simp - -/-- - `Partial.inₑ` on concrete arguments is the same as `Spec.inₑ` on those arguments --/ -theorem partialInₑ_on_concrete_eqv_concrete {uid₁ uid₂ : EntityUID} {entities : Spec.Entities} : - Partial.inₑ uid₁ uid₂ entities = Spec.inₑ uid₁ uid₂ entities -:= by - unfold Partial.inₑ Spec.inₑ - cases uid₁ == uid₂ <;> simp only [Bool.true_or, Bool.false_or] - case false => simp only [ancestorsOrEmpty_on_concrete_eqv_concrete] - -/-- - `Partial.inₛ` on concrete arguments is the same as `Spec.inₛ` on those arguments --/ -theorem partialInₛ_on_concrete_eqv_concrete {uid : EntityUID} {vs : Set Spec.Value} {entities : Spec.Entities} : - Partial.inₛ uid vs entities = Spec.inₛ uid vs entities -:= by - unfold Partial.inₛ Spec.inₛ - simp only [partialInₑ_on_concrete_eqv_concrete] - -/-- - `Partial.apply₂` on concrete arguments is the same as `Spec.apply₂` on those - arguments --/ -theorem partialApply₂_on_concrete_eqv_concrete {op : BinaryOp} {v₁ v₂ : Spec.Value} {entities : Spec.Entities} : - Partial.apply₂ op v₁ v₂ entities = (Spec.apply₂ op v₁ v₂ entities).map Partial.Value.value -:= by - unfold Partial.apply₂ Spec.apply₂ Except.map - cases op <;> split <;> rename_i h - <;> simp only [false_implies, forall_const] at h - <;> try simp only [Except.ok.injEq, Partial.Value.value.injEq, Spec.Value.prim.injEq, Spec.Prim.bool.injEq] - case add | sub | mul => split <;> rename_i h <;> simp [h] - case mem.h_10 uid₁ uid₂ => simp only [partialInₑ_on_concrete_eqv_concrete] - case mem.h_11 uid vs => - simp only [partialInₛ_on_concrete_eqv_concrete] - cases Spec.inₛ uid vs entities <;> simp only [Except.bind_ok, Except.bind_err] - case mem.h_12 => - split <;> rename_i h₂ <;> split at h₂ - <;> simp only [imp_self, false_implies, implies_true, forall_const, forall_eq', - Except.error.injEq, Spec.Value.prim.injEq, Spec.Value.set.injEq, Spec.Prim.entityUID.injEq, - forall_apply_eq_imp_iff] at * - exact h₂ - -/-- - `Partial.evaluateBinaryApp` on concrete arguments is the same as `Spec.apply₂` on - those arguments --/ -theorem on_concrete_eqv_concrete {op : BinaryOp} {v₁ v₂ : Spec.Value} {entities : Spec.Entities} : - Partial.evaluateBinaryApp op v₁ v₂ entities = (Spec.apply₂ op v₁ v₂ entities).map Partial.Value.value -:= by - simp only [Partial.evaluateBinaryApp, partialApply₂_on_concrete_eqv_concrete] - -/-- - if `Partial.inₛ` returns `ok` with some value, that is a well-formed value --/ -theorem partialInₛ_wf {uid : EntityUID} {vs : Set Spec.Value} : - ∀ pval, Partial.inₛ uid vs entities = .ok pval → pval.WellFormed -:= by - unfold Partial.inₛ - intro pval - cases vs.mapOrErr Spec.Value.asEntityUID Spec.Error.typeError <;> simp - case ok uids => - intro h ; subst h ; simp [Spec.Value.WellFormed, Prim.WellFormed] - -/-- - if `Partial.apply₂` on two well-formed values and well-formed entities - returns `ok` with some value, that is a well-formed value as well --/ -theorem partialApply₂_wf {v₁ v₂ : Spec.Value} {op : BinaryOp} {entities : Partial.Entities} - (wf₁ : v₁.WellFormed) - (wf₂ : v₂.WellFormed) : - ∀ pval, Partial.apply₂ op v₁ v₂ entities = .ok pval → pval.WellFormed -:= by - unfold Partial.apply₂ - intro pval - split <;> intro h₁ <;> try simp at h₁ <;> subst h₁ - all_goals try { - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - } - · rename_i i j - cases h₂ : intOrErr (i.add? j) <;> simp [h₂] at h₁ - case ok v => - subst h₁ - unfold intOrErr at h₂ - split at h₂ <;> simp at h₂ - subst h₂ - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - · rename_i i j - cases h₂ : intOrErr (i.sub? j) <;> simp [h₂] at h₁ - case ok v => - subst h₁ - unfold intOrErr at h₂ - split at h₂ <;> simp at h₂ - subst h₂ - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - · rename_i i j - cases h₂ : intOrErr (i.mul? j) <;> simp [h₂] at h₁ - case ok v => - subst h₁ - unfold intOrErr at h₂ - split at h₂ <;> simp at h₂ - subst h₂ - simp [Partial.Value.WellFormed, Spec.Value.WellFormed, Prim.WellFormed] - · rename_i uid vs - cases h₂ : Partial.inₛ uid vs entities <;> simp [h₂] at h₁ - case ok v => - subst h₁ - simp [Partial.Value.WellFormed] - exact partialInₛ_wf v h₂ - -/-- - if `Partial.evaluateBinaryApp` on two well-formed values and well-formed - entities returns `ok` with some value, that is a well-formed value as well --/ -theorem evaluateBinaryApp_wf {pval₁ pval₂ : Partial.Value} {op : BinaryOp} {entities : Partial.Entities} - (wf₁ : pval₁.WellFormed) - (wf₂ : pval₂.WellFormed) : - ∀ pval, Partial.evaluateBinaryApp op pval₁ pval₂ entities = .ok pval → pval.WellFormed -:= by - unfold Partial.evaluateBinaryApp - split - · rename_i v₁ v₂ h₁ - simp at h₁ ; replace ⟨h₁, h₁'⟩ := h₁ ; subst h₁ h₁' - simp only [Partial.Value.WellFormed] at wf₁ wf₂ - exact partialApply₂_wf wf₁ wf₂ - · intro pval h₁ ; simp only [Except.ok.injEq] at h₁ ; subst h₁ - simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - -/-- - If `Partial.evaluateBinaryApp` produces `ok` with a concrete value, then so - would partial-evaluating either of the operands --/ -theorem returns_concrete_then_operands_eval_to_concrete {pval₁ pval₂ : Partial.Value} {op : BinaryOp} {entities : Partial.Entities} : - Partial.evaluateBinaryApp op pval₁ pval₂ entities = .ok (.value v) → - (∃ v₁, pval₁ = .value v₁) ∧ (∃ v₂, pval₂ = .value v₂) -:= by - unfold Partial.evaluateBinaryApp - intro h₁ - cases pval₁ <;> cases pval₂ - case value.value v₁ v₂ => - exact And.intro (by exists v₁) (by exists v₂) - all_goals simp only [Except.ok.injEq] at h₁ - -/-- - The return value of `Partial.inₑ` is not affected by substitution of unknowns - in `entities` --/ -theorem partialInₑ_subst_const {uid₁ uid₂ : EntityUID} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.inₑ uid₁ uid₂ entities = Partial.inₑ uid₁ uid₂ (entities.subst subsmap) -:= by - unfold Partial.inₑ - cases uid₁ == uid₂ <;> simp only [Bool.false_or, Bool.true_or] - case false => - rw [← Subst.entities_subst_preserves_ancestorsOrEmpty entities uid₁ subsmap] - -/-- - The return value of `Partial.inₛ` is not affected by substitution of unknowns - in `entities` --/ -theorem partialInₛ_subst_const {uid₁ : EntityUID} {s₂ : Set Spec.Value} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.inₛ uid₁ s₂ entities = Partial.inₛ uid₁ s₂ (entities.subst subsmap) -:= by - unfold Partial.inₛ - cases s₂.mapOrErr Spec.Value.asEntityUID .typeError - case error e => simp only [Except.bind_err] - case ok uids => simp only [← partialInₑ_subst_const, Except.bind_ok] - -/-- - If `Partial.apply₂` returns a concrete value, then it returns the same value - after any substitution of unknowns in `entities` --/ -theorem partialApply₂_subst_preserves_evaluation_to_value {v₁ v₂ : Spec.Value} {op : BinaryOp} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.apply₂ op v₁ v₂ entities = .ok (.value v) → - Partial.apply₂ op v₁ v₂ (entities.subst subsmap) = .ok (.value v) -:= by - unfold Partial.apply₂ - cases op - case eq => simp only [Except.ok.injEq, Partial.Value.value.injEq, imp_self] - case mem => - cases v₁ <;> cases v₂ - case prim.prim p₁ p₂ => - cases p₁ <;> cases p₂ - <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, imp_self] - case entityUID.entityUID uid₁ uid₂ => - rw [← partialInₑ_subst_const] - simp only [imp_self] - case prim.set p₁ s₂ => - cases p₁ <;> simp only [imp_self] - case entityUID uid₁ => - rw [← partialInₛ_subst_const] - simp only [imp_self] - all_goals simp only [Partial.apply₂.match_1.eq_12, imp_self] - all_goals { - cases v₁ <;> cases v₂ - case prim.prim p₁ p₂ => - cases p₁ <;> cases p₂ - <;> simp only [Except.ok.injEq, Partial.Value.value.injEq, imp_self] - all_goals simp only [Partial.apply₂.match_1.eq_12, imp_self] - } - -/-- - If `Partial.evaluateBinaryApp` returns a concrete value, then it returns - the same value after any substitution of unknowns in `entities` --/ -theorem subst_preserves_evaluation_to_value {pval₁ pval₂ : Partial.Value} {op : BinaryOp} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.evaluateBinaryApp op pval₁ pval₂ entities = .ok (.value v) → - Partial.evaluateBinaryApp op pval₁ pval₂ (entities.subst subsmap) = .ok (.value v) -:= by - unfold Partial.evaluateBinaryApp - cases pval₁ <;> cases pval₂ <;> simp only [Except.ok.injEq, imp_self] - case value.value v₁ v₂ => exact partialApply₂_subst_preserves_evaluation_to_value - -/-- - If `Partial.apply₂` returns an error, then it also returns an error (not - necessarily the same error) after any substitution of unknowns in `entities` --/ -theorem partialApply₂_subst_preserves_errors {v₁ v₂ : Spec.Value} {op : BinaryOp} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.apply₂ op v₁ v₂ entities = .error e → - ∃ e', Partial.apply₂ op v₁ v₂ (entities.subst subsmap) = .error e' -:= by - simp only [Partial.apply₂] - cases op - case eq => simp only [exists_false, imp_self] - case mem => - cases v₁ <;> cases v₂ - case prim.prim p₁ p₂ => - cases p₁ <;> cases p₂ - <;> simp only [Except.error.injEq, exists_eq', implies_true, exists_false, imp_self] - case prim.set p₁ s₂ => - cases p₁ <;> simp only [Except.error.injEq, exists_eq', implies_true] - case entityUID uid₁ => - rw [← partialInₛ_subst_const] - intro _ ; exists e - all_goals simp only [Partial.apply₂.match_1.eq_12, Except.error.injEq, exists_eq', implies_true] - case add | sub | mul => - cases v₁ <;> cases v₂ - case prim.prim p₁ p₂ => - cases p₁ <;> cases p₂ - <;> simp only [Except.error.injEq, exists_eq', implies_true, exists_false, imp_self] - case int.int i₁ i₂ => intro _ ; exists e - all_goals simp only [Partial.apply₂.match_1.eq_12, Except.error.injEq, exists_eq', implies_true, exists_false, imp_self] - all_goals { - cases v₁ <;> cases v₂ - case prim.prim p₁ p₂ => - cases p₁ <;> cases p₂ - <;> simp only [Except.error.injEq, exists_eq', implies_true, exists_false, imp_self] - all_goals simp only [Partial.apply₂.match_1.eq_12, Except.error.injEq, exists_eq', implies_true, exists_false, imp_self] - } - -/-- - If `Partial.evaluateBinaryApp` returns an error, then it also returns an error - (not necessarily the same error) after any substitution of unknowns in - `entities` --/ -theorem subst_preserves_errors {pval₁ pval₂ : Partial.Value} {op : BinaryOp} {entities : Partial.Entities} (subsmap : Subsmap) : - Partial.evaluateBinaryApp op pval₁ pval₂ entities = .error e → - ∃ e', Partial.evaluateBinaryApp op pval₁ pval₂ (entities.subst subsmap) = .error e' -:= by - simp only [Partial.evaluateBinaryApp] - cases pval₁ <;> cases pval₂ <;> simp only [exists_false, imp_self] - case value.value v₁ v₂ => exact partialApply₂_subst_preserves_errors - -/-- - `Partial.apply₂` followed by a substitution and then `Partial.evaluateValue`, - is equivalent to substituting first and then `Partial.apply₂` --/ -theorem reeval_eqv_substituting_first_partialApply₂ {op : BinaryOp} {v₁ v₂ : Spec.Value} {entities : Partial.Entities} {subsmap : Subsmap} : - Partial.apply₂ op v₁ v₂ entities = .ok pv → - Partial.evaluateValue (pv.subst subsmap) (entities.subst subsmap) = Partial.apply₂ op v₁ v₂ (entities.subst subsmap) -:= by - cases pv - case value v => - simp only [Subst.subst_concrete_value, Partial.evaluateValue] - intro h - exact (EvaluateBinaryApp.partialApply₂_subst_preserves_evaluation_to_value h).symm - case residual r => - cases op <;> simp only [Partial.apply₂, Except.ok.injEq, false_implies] - case mem => - cases v₁ - case prim p₁ => - cases p₁ - case entityUID uid₁ => - cases v₂ - case prim p₂ => - cases p₂ <;> simp only [Except.ok.injEq, false_implies] - case set s₂ => simp only [do_ok, and_false, exists_const, false_implies] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - case less | lessEq | add | sub | mul => - cases v₁ - case prim p₁ => - cases p₁ - case int i₁ => - cases v₂ - case prim p₂ => - cases p₂ - case int i₂ => - simp only [do_ok, Except.ok.injEq, false_implies, and_false, exists_const] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - case contains => - cases v₁ - case set s₁ => simp only [Except.ok.injEq, false_implies] - all_goals simp only [false_implies] - case containsAll | containsAny => - cases v₁ - case set s₁ => - cases v₂ - case set s₂ => simp only [Except.ok.injEq, false_implies] - all_goals simp only [false_implies] - all_goals simp only [false_implies] - -/-- - If `Partial.evaluateBinaryApp` returns a residual, re-evaluating that residual with a - substitution is equivalent to substituting first, evaluating the args, and calling - `Partial.evaluateBinaryApp` on the substituted/evaluated arg --/ -theorem reeval_eqv_substituting_first (op : BinaryOp) (pval₁ pval₂ : Partial.Value) (entities : Partial.Entities) (subsmap : Subsmap) - (wf₁ : pval₁.WellFormed) - (wf₂ : pval₂.WellFormed) : - let re_evaluated := Partial.evaluateBinaryApp op pval₁ pval₂ entities >>= λ residual => Partial.evaluateValue (residual.subst subsmap) (entities.subst subsmap) - let subst_first := do - let pval₁' ← Partial.evaluateValue (pval₁.subst subsmap) (entities.subst subsmap) - let pval₂' ← Partial.evaluateValue (pval₂.subst subsmap) (entities.subst subsmap) - Partial.evaluateBinaryApp op pval₁' pval₂' (entities.subst subsmap) - match (re_evaluated, subst_first) with - | (Except.error _, Except.error _) => true -- don't require that the errors are equal - | (_, _) => re_evaluated = subst_first -:= by - unfold Partial.evaluateBinaryApp - split <;> rename_i h₁ <;> simp only [Prod.mk.injEq] at h₁ <;> replace ⟨h₁, h₁'⟩ := h₁ <;> subst h₁ h₁' - · -- both `pval₁` and `pval₂` are concrete - rename_i v₁ v₂ - simp only [Partial.Value.subst, Partial.evaluateValue, Except.bind_ok] - cases h₁ : Partial.apply₂ op v₁ v₂ entities <;> simp only [Except.bind_ok, Except.bind_err] - case error e => - have ⟨e', h⟩ := EvaluateBinaryApp.partialApply₂_subst_preserves_errors h₁ (subsmap := subsmap) - simp only [h, implies_true] - case ok pv => - rw [← reeval_eqv_substituting_first_partialApply₂ h₁] - split <;> simp only - · -- `pval₁` and `pval₂` aren't both concrete - simp only [Except.bind_ok] - split - · trivial - · rename_i hₑ h₁ ; simp only [Prod.mk.injEq] at h₁ ; replace ⟨h₁, h₁'⟩ := h₁ ; subst h₁ h₁' - cases hv₁ : Partial.evaluateValue (pval₁.subst subsmap) (entities.subst subsmap) - <;> cases hv₂ : Partial.evaluateValue (pval₂.subst subsmap) (entities.subst subsmap) - <;> simp only [hv₁, hv₂, Except.bind_ok, Except.bind_err, Except.error.injEq, imp_false, - forall_apply_eq_imp_iff] at hₑ - <;> simp only [Except.bind_ok, Except.bind_err] - case error.error e₁ e₂ | error.ok e₁ pv₂ | ok.error pv₁ e₂ => - simp only [Partial.Value.subst, Partial.ResidualExpr.subst, Partial.evaluateValue, - Partial.evaluateResidual, hv₁, hv₂, Except.bind_err, Except.bind_ok, Except.error.injEq, - forall_eq'] at hₑ - case ok.ok pv₁ pv₂ => - simp only [Partial.Value.subst, Partial.ResidualExpr.subst, Partial.evaluateValue, - Partial.evaluateResidual, hv₁, hv₂, Except.bind_ok] - split - <;> rename_i h <;> simp only [Prod.mk.injEq] at h <;> replace ⟨h, h'⟩ := h <;> subst h h' - <;> simp only [Partial.evaluateBinaryApp] diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateCall.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateCall.lean deleted file mode 100644 index 904200417..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateCall.lean +++ /dev/null @@ -1,178 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.List -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.Evaluation.Evaluate.Set -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Partial.Subst - -/-! Theorems about `Partial.evaluateCall` -/ - -namespace Cedar.Thm.Partial.Evaluation.EvaluateCall - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Error Expr Ext ExtFun Prim Result) - -/-- - `Partial.evaluateCall` on concrete arguments gives the same output as - `Spec.call` on those same arguments --/ -theorem on_concrete_eqv_concrete {vs : List Spec.Value} {xfn : ExtFun} : - Partial.evaluateCall xfn (vs.map Partial.Value.value) = (Spec.call xfn vs).map Partial.Value.value -:= by - unfold Partial.evaluateCall - simp only [List.mapM_map, List.mapM_some, Except.map] - cases Spec.call xfn vs <;> simp - -/-- - if `Spec.call` returns `ok` with some value, that is a well-formed value --/ -theorem specCall_wf {vs : List Spec.Value} {xfn : ExtFun} - (wf : ∀ v ∈ vs, v.WellFormed) : - ∀ v, Spec.call xfn vs = .ok v → v.WellFormed -:= by - unfold Spec.Value.WellFormed - intro v - cases v <;> simp - case prim p => simp [Prim.WellFormed] - case set | record => - unfold Spec.call Spec.res - split <;> simp at * <;> split <;> simp - case ext x => cases x <;> simp [Ext.WellFormed] - -/-- - if `Partial.evaluateCall` on well-formed arguments returns `ok` with some - value, that is a well-formed value as well --/ -theorem evaluateCall_wf {pvals : List Partial.Value} {xfn : ExtFun} - (wf : ∀ pval ∈ pvals, pval.WellFormed) : - ∀ pval, Partial.evaluateCall xfn pvals = .ok pval → pval.WellFormed -:= by - unfold Partial.evaluateCall Partial.Value.WellFormed Partial.ResidualExpr.WellFormed - intro pval h₁ - split at h₁ - · rename_i vs h₂ - cases h₃ : Spec.call xfn vs <;> simp [h₃] at h₁ - subst pval - rename_i v' - apply specCall_wf _ v' h₃ - intro v h₅ - replace ⟨pval, h₄, h₂⟩ := List.mapM_some_implies_all_from_some h₂ v h₅ - specialize wf pval h₄ - unfold Partial.Value.WellFormed at wf - cases pval <;> simp at wf h₂ - case value v' => subst v' ; exact wf - · simp only [Except.ok.injEq] at h₁ ; subst h₁ ; simp only - -/-- - If `Partial.evaluateCall` produces `ok` with a concrete value, then all of the - arguments are concrete --/ -theorem returns_concrete_then_args_concrete {args : List Partial.Value} {xfn : ExtFun} : - Partial.evaluateCall xfn args = .ok (.value v) → - ∀ arg ∈ args, ∃ v, arg = .value v -:= by - unfold Partial.evaluateCall - split <;> intro h₁ arg h₂ - · rename_i vs h₃ - replace ⟨v, h₃, h₄⟩ := List.mapM_some_implies_all_some h₃ arg h₂ - cases arg <;> simp only [Option.some.injEq] at h₄ - subst v ; rename_i v - exists v - · rename_i h₃ - replace ⟨arg', h₃, h₄⟩ := List.mapM_none_iff_exists_none.mp h₃ - cases arg' <;> simp only [Except.ok.injEq] at h₁ h₄ - -/-- - something akin to `Partial.Evaluation.EvaluateValue.eval_spec_value`, lifted to lists of `Partial.Value` --/ -theorem mapM_eval_spec_value {pvals : List Partial.Value} (entities : Partial.Entities) : - (pvals.mapM λ pval => match pval with | .value v => some v | .residual _ => none) = some vs → - (pvals.mapM (Partial.evaluateValue · entities)) = .ok (vs.map Partial.Value.value) -:= match pvals with - | [] => by intro h₁ ; simp at h₁ ; subst vs ; simp [pure, Except.pure] - | hd :: tl => by - simp only [List.mapM_cons, Option.pure_def, Option.bind_eq_bind, Option.bind_eq_some, - Option.some.injEq, forall_exists_index, and_imp, pure, Except.pure] - intro vhd hvhd vtl hvtl _ ; subst vs - cases hd <;> simp only [Option.some.injEq] at hvhd ; subst hvhd - case value vhd => - simp only [Partial.evaluateValue, Except.bind_ok, List.map_cons] - simp only [mapM_eval_spec_value (pvals := tl) entities hvtl, Except.bind_ok] - -/-- - If `Partial.evaluateCall` returns a residual, re-evaluating that residual with - a substitution is equivalent to substituting first, evaluating the arguments, - and then calling `Partial.evaluateCall` on the substituted/evaluated arguments --/ -theorem reeval_eqv_substituting_first (pvals : List Partial.Value) (xfn : ExtFun) {req req' : Partial.Request} (entities : Partial.Entities) {subsmap : Subsmap} : - req.subst subsmap = some req' → - let re_evaluated := Partial.evaluateCall xfn pvals >>= λ residual => Partial.evaluateValue (residual.subst subsmap) (entities.subst subsmap) - let subst_first := (pvals.map (Partial.Value.subst subsmap)).mapM (Partial.evaluateValue · (entities.subst subsmap)) >>= λ args => Partial.evaluateCall xfn args - match (re_evaluated, subst_first) with - | (Except.error _, Except.error _) => true -- don't require that the errors are equal - | (_, _) => re_evaluated = subst_first -:= by - unfold Partial.evaluateCall - simp only ; split <;> rename_i h₁ - · simp only [implies_true] - · -- re-evaluation and subst-first don't _both_ return errors - rename_i hₑ - simp at h₁ ; replace ⟨h₁, h₁'⟩ := h₁ ; subst h₁ h₁' - split <;> rename_i h₂ <;> simp only [h₂, bind_assoc, Except.bind_ok, List.mapM_map, Function.comp_apply] at hₑ - · -- pvals are all concrete - rename_i vs - rw [← Subst.subst_concrete_values (pvals := pvals) (by unfold IsAllConcrete ; exists vs)] - cases h_call : Spec.call xfn vs - <;> simp only [h_call, Except.bind_err, Except.bind_ok, Except.error.injEq] at hₑ - case error e => - simp only [Except.bind_err] - cases h₃ : (pvals.map (Partial.Value.subst subsmap)).mapM λ pval => Partial.evaluateValue pval (entities.subst subsmap) - case error e' => simp only [List.mapM_map] at h₃ ; simp [h₃] at hₑ - case ok pvals' => - rw [← Subst.subst_concrete_values (pvals := pvals) (by unfold IsAllConcrete ; exists vs)] at h₃ - rw [mapM_eval_spec_value _ h₂, Except.ok.injEq] at h₃ ; subst pvals' - rw [mapM_eval_spec_value _ h₂, Except.bind_ok, List.mapM_map] - simp only [h_call, List.mapM_some, Except.bind_err, implies_true] - case ok v => - simp only [Subst.subst_concrete_value, Partial.evaluateValue, Except.bind_ok] - cases h₃ : pvals.mapM λ pval => Partial.evaluateValue pval (entities.subst subsmap) - case error e' => - -- pvals are all concrete, but evaluating them produces an error - exfalso - replace ⟨pval, h_pval, h₃⟩ := List.mapM_error_implies_exists_error h₃ - replace ⟨v', _, h₂⟩ := List.mapM_some_implies_all_some h₂ pval h_pval - cases pval <;> simp at h₂ - case value v'' => - subst v'' - simp [Partial.evaluateValue] at h₃ - case ok pvals' => - -- pvals are all concrete, and evaluating them produces pvals' ; we'll show pvals = pvals' - simp only [mapM_eval_spec_value _ h₂, Except.ok.injEq] at h₃ ; subst pvals' - simp only [mapM_eval_spec_value _ h₂, Except.bind_ok, List.mapM_map] - simp only [h_call, List.mapM_some, Except.bind_ok, implies_true] - · -- pvals are not all concrete - simp only [Except.bind_ok, Partial.Value.subst, Partial.ResidualExpr.subst, List.map₁_eq_map, - List.mapM_map] - simp only [Partial.evaluateValue, Partial.evaluateResidual, Partial.evaluateCall] - rw [List.mapM₁_eq_mapM (Partial.evaluateValue · (entities.subst subsmap)), List.mapM_map] - intro _ ; rfl diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateGetAttr.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateGetAttr.lean deleted file mode 100644 index c0c22e036..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateGetAttr.lean +++ /dev/null @@ -1,269 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.LT -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Partial.Subst - -namespace Cedar.Thm.Partial.Evaluation.EvaluateGetAttr - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr EntityUID Error Expr Prim Result) - -/-- - `Partial.attrsOf` on concrete arguments is the same as `Spec.attrsOf` on those - arguments --/ -theorem attrsOf_on_concrete_eqv_concrete {v : Spec.Value} {entities : Spec.Entities} : - Partial.attrsOf v (Partial.Entities.attrs entities) = (Spec.attrsOf v (Spec.Entities.attrs entities)).map λ m => m.mapOnValues Partial.Value.value -:= by - unfold Partial.attrsOf Spec.attrsOf Except.map - cases v <;> simp only - case prim p => - cases p <;> simp only - case entityUID uid => - unfold Partial.Entities.attrs Spec.Entities.attrs Spec.Entities.asPartialEntities - cases h₁ : entities.findOrErr uid Error.entityDoesNotExist - <;> simp only [h₁, Map.findOrErr_mapOnValues, Except.map, Spec.EntityData.asPartialEntityData, - Except.bind_ok, Except.bind_err] - -/-- - `Partial.getAttr` on concrete arguments is the same as `Spec.getAttr` on those - arguments --/ -theorem getAttr_on_concrete_eqv_concrete {v : Spec.Value} {entities : Spec.Entities} {attr : Attr} : - Partial.getAttr v attr entities = (Spec.getAttr v attr entities).map Partial.Value.value -:= by - unfold Partial.getAttr Spec.getAttr - simp only [attrsOf_on_concrete_eqv_concrete, Except.map] - cases Spec.attrsOf v entities.attrs <;> simp only [Except.bind_err, Except.bind_ok] - case ok m => simp only [Map.findOrErr_mapOnValues, Except.map] - -/-- - `Partial.evaluateGetAttr` on concrete arguments is the same as `Spec.getAttr` - on those arguments --/ -theorem on_concrete_eqv_concrete {v : Spec.Value} {a : Attr} {entities : Spec.Entities} : - Partial.evaluateGetAttr v a entities = Spec.getAttr v a entities -:= by - simp only [Partial.evaluateGetAttr, getAttr_on_concrete_eqv_concrete, pure, Except.pure, Except.map] - cases Spec.getAttr v a entities <;> simp only [Except.bind_ok, Except.bind_err] - -/-- - if `entities.attrs uid` is `ok` with some attrs, those attrs are a - well-formed `Map`, and all the values in those attrs are well-formed --/ -theorem partialEntities_attrs_wf {entities : Partial.Entities} {uid : EntityUID} {attrs: Map String Partial.Value} - (wf_e : entities.WellFormed) : - entities.attrs uid = .ok attrs → - attrs.WellFormed ∧ ∀ v ∈ attrs.values, v.WellFormed -:= by - unfold Partial.Entities.attrs - intro h₁ - cases h₂ : entities.es.findOrErr uid Error.entityDoesNotExist - <;> simp only [h₂, Except.bind_err, Except.bind_ok, Except.ok.injEq] at h₁ - case ok attrs => - subst h₁ - unfold Partial.Entities.WellFormed Partial.EntityData.WellFormed at wf_e - have ⟨wf_m, wf_edata⟩ := wf_e ; clear wf_e - constructor - · apply (wf_edata _ _).left - simp only [← Map.findOrErr_ok_iff_in_values (v := attrs) (e := Error.entityDoesNotExist) wf_m] - exists uid - · intro pval h₃ - replace h₂ := Map.findOrErr_ok_implies_in_values h₂ - exact (wf_edata attrs h₂).right.right pval h₃ - -/-- - if `Partial.attrsOf` returns `ok` with some attrs, those attrs are a - well-formed `Map`, and all the values in those attrs are well-formed --/ -theorem attrsOf_wf {entities : Partial.Entities} {v : Spec.Value} {attrs : Map String Partial.Value} - (wf₁ : v.WellFormed) - (wf_e : entities.WellFormed) : - Partial.attrsOf v entities.attrs = .ok attrs → - attrs.WellFormed ∧ ∀ v ∈ attrs.values, v.WellFormed -:= by - unfold Partial.attrsOf - cases v <;> try simp only [false_implies, Except.ok.injEq] - case prim p => - cases p <;> simp only [false_implies] - case entityUID uid => exact partialEntities_attrs_wf wf_e - case record m => - intro h₁ ; subst h₁ - unfold Spec.Value.WellFormed at wf₁ - replace ⟨wf₁, wf_vs⟩ := wf₁ - apply And.intro (Map.mapOnValues_wf.mp wf₁) - intro pval h₁ - have ⟨k, h₁'⟩ := Map.in_values_exists_key h₁ - rw [Map.values_mapOnValues] at h₁ - replace ⟨v, _, h₃⟩ := List.mem_map.mp h₁ - subst h₃ - simp [Partial.Value.WellFormed] - apply wf_vs (k, v) - exact Map.in_mapOnValues_in_kvs wf₁ h₁' (by simp) - -/-- - if `Partial.getAttr` on a well-formed value and well-formed entities returns - `ok` with some value, that is a well-formed value as well --/ -theorem getAttr_wf {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} - (wf₁ : v₁.WellFormed) - (wf_e : entities.WellFormed) : - ∀ v, Partial.getAttr v₁ attr entities = .ok v → v.WellFormed -:= by - unfold Partial.getAttr - cases h₁ : Partial.attrsOf v₁ entities.attrs <;> simp - case ok attrs => - have ⟨_, wf_vs⟩ := attrsOf_wf wf₁ wf_e h₁ - intro pval h₂ - exact wf_vs pval (Map.findOrErr_ok_implies_in_values h₂) - -/-- - if `Partial.evaluateGetAttr` on a well-formed value and well-formed entities - returns `ok` with some value, that is a well-formed value as well --/ -theorem evaluateGetAttr_wf {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} - (wf₁ : pval₁.WellFormed) - (wf_e : entities.WellFormed) : - ∀ pval, Partial.evaluateGetAttr pval₁ attr entities = .ok pval → pval.WellFormed -:= by - unfold Partial.evaluateGetAttr - cases pval₁ <;> simp only [Except.bind_ok] - case residual r₁ => - intro pval h_pval - simp only [Except.ok.injEq] at h_pval - subst pval - simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - case value v₁ => - simp [Partial.Value.WellFormed] at wf₁ - exact getAttr_wf wf₁ wf_e - -/-- - If `Partial.getAttr` returns a concrete value, then it returns the same value - after any substitution of unknowns in `entities` --/ -theorem getAttr_subst_preserves_evaluation_to_value {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - Partial.getAttr v₁ attr entities = .ok (.value v) → - Partial.getAttr v₁ attr (entities.subst subsmap) = .ok (.value v) -:= by - unfold Partial.getAttr - unfold Partial.attrsOf - cases v₁ - case prim p₁ => - cases p₁ <;> simp only [Except.bind_err, imp_self] - case entityUID uid₁ => - cases h₁ : entities.attrs uid₁ - <;> simp only [Except.bind_ok, Except.bind_err, false_implies] - case ok attrs => - intro h₂ - replace h₂ := Map.findOrErr_ok_implies_in_kvs h₂ - unfold Map.toList at h₂ - have ⟨attrs', h₃, h₄⟩ := Subst.entities_subst_preserves_concrete_attrs subsmap h₁ h₂ - simp only [h₃, Except.bind_ok] - apply (Map.findOrErr_ok_iff_in_kvs _).mpr h₄ - have wf' := Subst.entities_subst_preserves_wf wf_e wf_s - exact (partialEntities_attrs_wf wf' h₃).left - case set | record => simp - case ext x => cases x <;> simp - -/-- - If `Partial.evaluateGetAttr` returns a concrete value, then it returns the - same value after any substitution of unknowns in `entities` --/ -theorem subst_preserves_evaluation_to_value {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - Partial.evaluateGetAttr pval₁ attr entities = .ok (.value v) → - Partial.evaluateGetAttr pval₁ attr (entities.subst subsmap) = .ok (.value v) -:= by - unfold Partial.evaluateGetAttr - cases pval₁ <;> simp only [Except.bind_ok] - case value v₁ => exact match h₁ : Partial.getAttr v₁ attr entities with - | .error _ => by simp only [Except.bind_err, false_implies] - | .ok (.residual r₁) => by simp only [Except.ok.injEq, false_implies] - | .ok (.value v₁') => by - simp only [Except.bind_ok, getAttr_subst_preserves_evaluation_to_value wf_e wf_s h₁] - simp only [Partial.evaluateValue, Except.ok.injEq, Partial.Value.value.injEq, imp_self] - case residual r₁ => simp only [Except.ok.injEq, imp_self] - -/-- - If `Partial.getAttr` returns an error, then it also returns an error (not - necessarily the same error) after any substitution of unknowns in `entities` --/ -theorem getAttr_subst_preserves_errors {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} {subsmap : Subsmap} - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - Partial.getAttr v₁ attr entities = .error e → - ∃ e', Partial.getAttr v₁ attr (entities.subst subsmap) = .error e' -:= by - simp only [Partial.getAttr, Partial.attrsOf] - exact match v₁ with - | .prim (.entityUID uid) => match ha : entities.attrs uid with - | .ok attrs => match ha' : (entities.subst subsmap).attrs uid with - | .ok attrs' => match e with - | .attrDoesNotExist => by - simp only [ha, ha', Except.bind_ok] - have wf_attrs := EvaluateGetAttr.partialEntities_attrs_wf wf_e ha - have wf_attrs' := EvaluateGetAttr.partialEntities_attrs_wf (Subst.entities_subst_preserves_wf wf_e wf_s) ha' - intro h₁ - exists .attrDoesNotExist - simp only [Map.findOrErr_err_iff_not_in_keys (wf_attrs.left)] at h₁ - simp only [Map.findOrErr_err_iff_not_in_keys (wf_attrs'.left)] - replace ⟨attrs'', ha'', h₁⟩ := Subst.entities_subst_preserves_absent_attrs subsmap ha h₁ - simp [ha'] at ha'' ; subst attrs'' - exact h₁ - | .entityDoesNotExist | .typeError | .arithBoundsError | .extensionError => by - simp only [ha, ha', Except.bind_ok] - intro h₁ ; rcases Map.findOrErr_returns attrs attr Error.attrDoesNotExist with h₂ | h₂ - · simp only [h₁, exists_const] at h₂ - · simp only [h₁, Except.error.injEq] at h₂ - | .error e => by - simp only [ha, ha', Except.bind_ok, Except.bind_err, Except.error.injEq, exists_eq', - implies_true] - | .error e' => by - simp only [ha, Except.bind_err, Except.error.injEq] - intro h ; subst e' - simp [(Subst.entities_subst_preserves_error_attrs subsmap).mp ha] - | .record attrs => by - simp only [Except.bind_ok] - intro _ ; exists e - | .prim (.bool _) | .prim (.int _) | .prim (.string _) => by simp - | .set _ | .ext _ => by simp - -/-- - If `Partial.evaluateGetAttr` returns an error, then it also returns an error - (not necessarily the same error) after any substitution of unknowns in - `entities` --/ -theorem subst_preserves_errors {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} (subsmap : Subsmap) - (wf_e : entities.WellFormed) - (wf_s : subsmap.WellFormed) : - Partial.evaluateGetAttr pval₁ attr entities = .error e → - ∃ e', Partial.evaluateGetAttr pval₁ attr (entities.subst subsmap) = .error e' -:= by - simp only [Partial.evaluateGetAttr] - cases pval₁ <;> simp only [exists_false, imp_self] - case value v₁ => exact getAttr_subst_preserves_errors wf_e wf_s diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateHasAttr.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateHasAttr.lean deleted file mode 100644 index 43b2ad2aa..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateHasAttr.lean +++ /dev/null @@ -1,188 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Partial.Subst - -namespace Cedar.Thm.Partial.Evaluation.EvaluateHasAttr - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr Error Expr Prim Result) - -/-- - `Partial.attrsOf` on concrete arguments is the same as `Spec.attrsOf` on those - arguments - - Note that the "concrete arguments" provided to `Partial.attrsOf` and - `Spec.attrsOf` in this theorem are different from the "concrete arguments" - provided in the theorem of the same name in Partial/Evaluation/GetAttr.lean --/ -theorem attrsOf_on_concrete_eqv_concrete {v : Spec.Value} {entities : Spec.Entities} : - Partial.attrsOf v (λ uid => .ok (entities.asPartialEntities.attrsOrEmpty uid)) = - (Spec.attrsOf v (λ uid => .ok (entities.attrsOrEmpty uid))).map λ m => m.mapOnValues Partial.Value.value -:= by - unfold Partial.attrsOf Spec.attrsOf Except.map - cases v <;> simp only - case prim p => - cases p <;> simp only - case entityUID uid => - unfold Partial.Entities.attrsOrEmpty Spec.Entities.attrsOrEmpty Spec.Entities.asPartialEntities - cases h₁ : (entities.mapOnValues Spec.EntityData.asPartialEntityData).find? uid - <;> simp only [Except.ok.injEq] - <;> cases h₂ : entities.find? uid <;> simp only - <;> unfold Spec.EntityData.asPartialEntityData at h₁ - <;> simp only [← Map.find?_mapOnValues, Option.map_eq_none', Option.map_eq_some'] at h₁ - case none.none => simp [Map.mapOnValues_empty] - case none.some => simp [h₁] at h₂ - case some.none => simp [h₂] at h₁ - case some.some edata₁ edata₂ => - replace ⟨edata₁, ⟨h₁, h₃⟩⟩ := h₁ - simp only [h₂, Option.some.injEq] at h₁ - subst h₁ h₃ - simp [Map.mapOnValues] - -/-- - `Partial.hasAttr` on concrete arguments is the same as `Spec.hasAttr` on those - arguments --/ -theorem hasAttr_on_concrete_eqv_concrete {v : Spec.Value} {entities : Spec.Entities} {attr : Attr} : - Partial.hasAttr v attr entities = Spec.hasAttr v attr entities -:= by - unfold Partial.hasAttr Spec.hasAttr - simp only [attrsOf_on_concrete_eqv_concrete, Except.map] - cases Spec.attrsOf v λ uid => .ok (entities.attrsOrEmpty uid) - <;> simp only [Except.bind_ok, Except.bind_err, Except.ok.injEq, Spec.Value.prim.injEq, Spec.Prim.bool.injEq] - case ok m => simp [← Map.mapOnValues_contains] - -/-- - `Partial.evaluateHasAttr` on concrete arguments is the same as `Spec.hasAttr` - on those arguments --/ -theorem on_concrete_eqv_concrete {v : Spec.Value} {a : Attr} {entities : Spec.Entities} : - Partial.evaluateHasAttr v a entities = Spec.hasAttr v a entities -:= by - simp [Partial.evaluateHasAttr, hasAttr_on_concrete_eqv_concrete, pure, Except.pure] - -/-- - if `Partial.hasAttr` returns `ok` with some value, that is a well-formed value --/ -theorem partialHasAttr_wf {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} : - ∀ v, Partial.hasAttr v₁ attr entities = .ok v → v.WellFormed -:= by - unfold Partial.hasAttr - cases Partial.attrsOf v₁ λ uid => .ok (entities.attrsOrEmpty uid) <;> simp - case ok m => simp [Spec.Value.WellFormed, Prim.WellFormed] - -/-- - if `Partial.evaluateHasAttr` returns `ok` with some value, that is a - well-formed value --/ -theorem evaluateHasAttr_wf {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} : - ∀ pval, Partial.evaluateHasAttr pval₁ attr entities = .ok pval → pval.WellFormed -:= by - unfold Partial.evaluateHasAttr - split - · rename_i v - cases h₁ : Partial.hasAttr v attr entities - case error e => simp only [Except.bind_err, false_implies, implies_true] - case ok v => - simp only [Partial.Value.WellFormed, Except.bind_ok, Except.ok.injEq, forall_eq'] - exact partialHasAttr_wf v h₁ - · intro pval h₁ ; simp only [Except.ok.injEq] at h₁ ; subst h₁ - simp only [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - -/-- - If `Partial.evaluateHasAttr` produces `ok` with a concrete value, then so - would partial-evaluating its operand --/ -theorem returns_concrete_then_operand_evals_to_concrete {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} : - Partial.evaluateHasAttr pval₁ attr entities = .ok (.value v) → - ∃ v₁, pval₁ = .value v₁ -:= by - unfold Partial.evaluateHasAttr - intro h₁ - cases pval₁ - case value v₁ => exists v₁ - case residual r₁ => simp only [Except.ok.injEq] at h₁ - -/-- - The return value of `Partial.hasAttr` is not affected by substitution of - unknowns in `entities` --/ -theorem hasAttr_subst_const {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} {subsmap : Subsmap} - (wf : entities.WellFormed) : - Partial.hasAttr v₁ attr entities = Partial.hasAttr v₁ attr (entities.subst subsmap) -:= by - unfold Partial.hasAttr Partial.attrsOf - cases v₁ <;> simp only [Except.bind_ok, Except.bind_err] - case prim p₁ => - cases p₁ - <;> simp only [Except.bind_ok, Except.bind_err, Except.ok.injEq, Spec.Value.prim.injEq, Spec.Prim.bool.injEq] - case entityUID uid => - exact Subst.entities_subst_preserves_contains_on_attrsOrEmpty entities uid attr subsmap wf - -/-- - If `Partial.evaluateHasAttr` returns a concrete value, then it returns the - same value after any substitution of unknowns in `entities` --/ -theorem subst_preserves_evaluation_to_value {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} {subsmap : Subsmap} - (wf : entities.WellFormed) : - Partial.evaluateHasAttr pval₁ attr entities = .ok (.value v) → - Partial.evaluateHasAttr pval₁ attr (entities.subst subsmap) = .ok (.value v) -:= by - unfold Partial.evaluateHasAttr - cases pval₁ <;> simp only [Except.ok.injEq, imp_self] - case value v₁ => simp only [← hasAttr_subst_const wf, imp_self] - -/-- - If `Partial.hasAttr` returns an error, then it also returns an error (not - necessarily the same error) after any substitution of unknowns in `entities` --/ -theorem hasAttr_subst_preserves_errors {v₁ : Spec.Value} {attr : Attr} {entities : Partial.Entities} (subsmap : Subsmap) : - Partial.hasAttr v₁ attr entities = .error e → - ∃ e', Partial.hasAttr v₁ attr (entities.subst subsmap) = .error e' -:= by - simp only [Partial.hasAttr, Partial.attrsOf] - exact match v₁ with - | .prim (.entityUID uid) => by simp only [Except.bind_ok, exists_false, imp_self] - | .record attrs => by simp only [Except.bind_ok, exists_false, imp_self] - | .prim (.bool _) | .prim (.int _) | .prim (.string _) => by simp - | .set _ | .ext _ => by simp - -/-- - If `Partial.evaluateHasAttr` returns an error, then it also returns an error - (not necessarily the same error) after any substitution of unknowns in - `entities` --/ -theorem subst_preserves_errors {pval₁ : Partial.Value} {attr : Attr} {entities : Partial.Entities} (subsmap : Subsmap) : - Partial.evaluateHasAttr pval₁ attr entities = .error e → - ∃ e', Partial.evaluateHasAttr pval₁ attr (entities.subst subsmap) = .error e' -:= by - simp only [Partial.evaluateHasAttr] - cases pval₁ <;> simp only [exists_false, imp_self] - case value v₁ => - intro h₁ - rw [do_error] at h₁ - have ⟨e', h₂⟩ := hasAttr_subst_preserves_errors subsmap h₁ - exists e' - simp only [h₂, Except.bind_err] diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateUnaryApp.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateUnaryApp.lean deleted file mode 100644 index ada1a71a0..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/EvaluateUnaryApp.lean +++ /dev/null @@ -1,113 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Evaluator -import Cedar.Thm.Data.Control -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed -import Cedar.Thm.Partial.Subst - -/-! Theorems about `Partial.evaluateUnaryApp` -/ - -namespace Cedar.Thm.Partial.Evaluation.EvaluateUnaryApp - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr Prim UnaryOp) - -/-- - `Partial.evaluateUnaryApp` on concrete arguments gives the same output as - `Spec.apply₁` on the same arguments --/ -theorem on_concrete_eqv_concrete (op : UnaryOp) (v : Spec.Value) : - Partial.evaluateUnaryApp op v = (Spec.apply₁ op v).map Partial.Value.value -:= by - rfl - -/-- - if `Spec.apply₁` returns `ok` with some value, that is a well-formed value as - well - - This theorem does not actually require that the input value is WellFormed --/ -theorem specApply₁_wf {v : Spec.Value} {op : UnaryOp} : - Spec.apply₁ op v = .ok v' → v'.WellFormed -:= by - unfold Spec.apply₁ - intro h - split at h <;> try simp at h <;> subst h - · simp [Spec.Value.WellFormed, Prim.WellFormed] - · unfold Spec.intOrErr at h - split at h <;> simp at h - subst h ; simp [Spec.Value.WellFormed, Prim.WellFormed] - · simp [Spec.Value.WellFormed, Prim.WellFormed] - · simp [Spec.Value.WellFormed, Prim.WellFormed] - -/-- - if `Partial.evaluateUnaryApp` on a well-formed value returns `ok` with some - value, that is a well-formed value as well - - This theorem does not actually require that the input value is WellFormed --/ -theorem evaluateUnaryApp_wf {pval : Partial.Value} {op : UnaryOp} : - Partial.evaluateUnaryApp op pval = .ok pval' → pval'.WellFormed -:= by - unfold Partial.evaluateUnaryApp - cases pval <;> simp only [Except.ok.injEq] - case residual r => intro h₁ ; subst h₁ ; simp [Partial.Value.WellFormed, Partial.ResidualExpr.WellFormed] - case value v => - cases h₁ : Spec.apply₁ op v - case error e => simp only [Except.bind_err, false_implies] - case ok v' => - simp only [Except.bind_ok, Except.ok.injEq] - intro h ; subst h ; simp only [Partial.Value.WellFormed] - exact specApply₁_wf h₁ - -/-- - If `Partial.evaluateUnaryApp` produces `ok` with a concrete value, then so - would partial-evaluating its operand --/ -theorem returns_concrete_then_operand_evals_to_concrete {pval₁ : Partial.Value} {op : UnaryOp} : - Partial.evaluateUnaryApp op pval₁ = .ok (.value v) → - ∃ v₁, pval₁ = .value v₁ -:= by - unfold Partial.evaluateUnaryApp - cases pval₁ - case value v₁ => intro _ ; exists v₁ - case residual r₁ => simp only [Except.ok.injEq, exists_const, imp_self] - -/-- - If `Partial.evaluateUnaryApp` returns a concrete value, then it returns the - same value after any substitution of unknowns --/ -theorem subst_preserves_evaluation_to_value {pval₁ : Partial.Value} {op : UnaryOp} {subsmap : Subsmap} : - Partial.evaluateUnaryApp op pval₁ = .ok (.value v) → - Partial.evaluateUnaryApp op (pval₁.subst subsmap) = .ok (.value v) -:= by - cases pval₁ <;> simp [Partial.evaluateUnaryApp] - case value v₁ => simp [Subst.subst_concrete_value] - -/-- - If `Partial.evaluateUnaryApp` returns an error, then it returns the same error - after any substitution of unknowns --/ -theorem subst_preserves_errors {pval₁ : Partial.Value} {op : UnaryOp} {subsmap : Subsmap} : - Partial.evaluateUnaryApp op pval₁ = .error e → - Partial.evaluateUnaryApp op (pval₁.subst subsmap) = .error e -:= by - cases pval₁ <;> simp [Partial.evaluateUnaryApp] - case value v₁ => simp [Subst.subst_concrete_value, do_error] diff --git a/cedar-lean/Cedar/Thm/Partial/Evaluation/Props.lean b/cedar-lean/Cedar/Thm/Partial/Evaluation/Props.lean deleted file mode 100644 index fd78155ad..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Evaluation/Props.lean +++ /dev/null @@ -1,77 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Partial.Evaluator -import Cedar.Spec.Expr -import Cedar.Thm.Partial.WellFormed - -/-! - This file contains definitions of `Prop`s used by multiple files in the - Thm/Partial/Evaluation folder --/ - -namespace Cedar.Thm.Partial - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Expr) - -/-- - Prop that partial evaluation and concrete evaluation of the same concrete - expression/request/entities produce the same result --/ -def PartialEvalEquivConcreteEval (expr : Expr) (request : Spec.Request) (entities : Spec.Entities) : Prop := - Partial.evaluate expr request entities = (Spec.evaluate expr request entities).map Partial.Value.value - -/-- - Prop that partial evaluation returns a concrete value --/ -def EvaluatesToConcrete (expr : Expr) (request : Partial.Request) (entities : Partial.Entities) : Prop := - ∃ v, Partial.evaluate expr request entities = .ok (.value v) - -/-- - Prop that .subst preserves evaluation to a concrete value --/ -def SubstPreservesEvaluationToConcrete (expr : Expr) (req req' : Partial.Request) (entities : Partial.Entities) (subsmap : Subsmap) : Prop := - req.subst subsmap = some req' → - ∀ v, - Partial.evaluate expr req entities = .ok (.value v) → - Partial.evaluate expr req' (entities.subst subsmap) = .ok (.value v) - -/-- - Prop that .subst preserves evaluation to an error - - (not necessarily the same error, but some error) --/ -def SubstPreservesEvaluationToError (expr : Expr) (req req' : Partial.Request) (entities : Partial.Entities) (subsmap : Subsmap) : Prop := - req.subst subsmap = some req' → - ∀ e, - Partial.evaluate expr req entities = .error e → - ∃ e', Partial.evaluate expr req' (entities.subst subsmap) = .error e' - -/-- - Prop that a list of partial values is actually a list of concrete values --/ -def IsAllConcrete (pvals : List Partial.Value) : Prop := - ∃ vs, pvals.mapM (λ x => match x with | .value v => some v | .residual _ => none) = some vs - -/-- - Prop that partial evaluation returns a well-formed value --/ -def EvaluatesToWellFormed (expr : Expr) (request : Partial.Request) (entities : Partial.Entities) : Prop := - ∀ pval, Partial.evaluate expr request entities = .ok pval → pval.WellFormed - -end Cedar.Thm.Partial diff --git a/cedar-lean/Cedar/Thm/Partial/Subst.lean b/cedar-lean/Cedar/Thm/Partial/Subst.lean deleted file mode 100644 index 4f4ee5838..000000000 --- a/cedar-lean/Cedar/Thm/Partial/Subst.lean +++ /dev/null @@ -1,457 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Data.Map -import Cedar.Data.SizeOf -import Cedar.Partial.Entities -import Cedar.Partial.Request -import Cedar.Partial.Value -import Cedar.Spec.Expr -import Cedar.Thm.Data.List -import Cedar.Thm.Data.LT -import Cedar.Thm.Partial.Evaluation.Props -import Cedar.Thm.Partial.WellFormed - -/-! ## Lemmas about `subst` operations -/ - -namespace Cedar.Thm.Partial.Subst - -open Cedar.Data -open Cedar.Partial (Subsmap Unknown) -open Cedar.Spec (Attr EntityUID Error Prim) - -/-- - Partial.Value.subst on a concrete value is that value --/ -theorem subst_concrete_value (value : Spec.Value) (subsmap : Subsmap) : - (Partial.Value.value value).subst subsmap = value -:= by - simp only [Partial.Value.subst] - -/-- - If a list of `Partial.Value`s is all concrete, then mapping - `Partial.Value.subst` over it does nothing --/ -theorem subst_concrete_values {pvals : List Partial.Value} {subsmap : Subsmap} : - IsAllConcrete pvals → - pvals = pvals.map (Partial.Value.subst subsmap) -:= match pvals with - | [] => by simp only [List.map_nil, implies_true] - | hd :: tl => by - simp only [IsAllConcrete, List.mapM_cons, Option.pure_def, Option.bind_eq_bind, - Option.bind_eq_some, Option.some.injEq, List.map_cons, List.cons.injEq, forall_exists_index, - and_imp] - intro vs vhd - exact match hd with - | .residual r => by simp only [false_implies] - | .value v => by - simp only [Option.some.injEq] - intro _ ; subst vhd - intro vtl hvtl _ ; subst vs - simp [Subst.subst_concrete_value] - apply subst_concrete_values - unfold IsAllConcrete - exists vtl - -/-- - Partial.ResidualExpr.subst preserves well-formedness --/ -theorem residual_subst_preserves_wf {x : Partial.ResidualExpr} {subsmap : Subsmap} : - x.WellFormed → subsmap.WellFormed → (x.subst subsmap).WellFormed -:= by - cases x - case unknown u => - simp only [Partial.ResidualExpr.WellFormed, Partial.Value.WellFormed, - Partial.ResidualExpr.subst, true_implies] - split - · rename_i h ; split at h - · subst h ; rename_i v _ h - replace h := Map.find?_mem_toList h - intro wf_s - suffices (Partial.Value.value v).WellFormed by simpa [Partial.Value.WellFormed] using this - apply wf_s.right - simp only [Map.toList] at h - exact Map.in_list_in_values h - · simp only at h - · simp only [implies_true] - all_goals { - simp only [Partial.ResidualExpr.WellFormed, Partial.Value.WellFormed, - Partial.ResidualExpr.subst, implies_true, imp_self] - } - -/-- - Partial.Value.subst preserves well-formedness --/ -theorem val_subst_preserves_wf {pv : Partial.Value} {subsmap : Subsmap} : - pv.WellFormed → subsmap.WellFormed → (pv.subst subsmap).WellFormed -:= match pv with - | .value v => by simp only [Partial.Value.WellFormed, subst_concrete_value] ; intro h _ ; exact h - | .residual r => by - -- we want to unfold only the first occurrence of `Partial.Value.WellFormed`. - -- I'm not aware of any way in Lean to do this directly, but this workaround works - have h_tmp : (Partial.Value.residual r).WellFormed ↔ r.WellFormed := by - simp only [Partial.Value.WellFormed] - rw [h_tmp] ; clear h_tmp - simp only [Partial.Value.subst] - exact residual_subst_preserves_wf - -/-- - Partial.Request.subst preserves well-formedness --/ -theorem req_subst_preserves_wf {req req' : Partial.Request} {subsmap : Subsmap} : - req.WellFormed → - subsmap.WellFormed → - req.subst subsmap = some req' → - req'.WellFormed -:= by - unfold Partial.Request.WellFormed Partial.Request.subst - intro wf_r wf_s h₁ - have ⟨wf_c, wf_vals⟩ := wf_r ; clear wf_r - simp only [Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq] at h₁ - replace ⟨principal, _, ⟨action, _, ⟨resource, _, h₁⟩⟩⟩ := h₁ - subst h₁ ; simp only - apply And.intro (Map.mapOnValues_wf.mp wf_c) - intro pval' h₁ - rw [Map.values_mapOnValues] at h₁ - replace ⟨pval, h₁, h₂⟩ := List.mem_map.mp h₁ - subst pval' - exact val_subst_preserves_wf (wf_vals pval h₁) wf_s - -/-- - Partial.Request.subst preserves a known principal UID --/ -theorem req_subst_preserves_known_principal {req req' : Partial.Request} {uid : EntityUID} {subsmap : Subsmap} : - req.principal = .known uid → - req.subst subsmap = some req' → - req'.principal = .known uid -:= by - intro h₁ h_req - simp only [Partial.Request.subst, Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq] at h_req - replace ⟨principal, h_p, ⟨action, _, ⟨resource, _, h_req⟩⟩⟩ := h_req - subst req' - simp only - simp only [Partial.UidOrUnknown.subst, h₁, Option.some.injEq] at h_p - exact h_p.symm - -/-- - Partial.Request.subst preserves a known action UID --/ -theorem req_subst_preserves_known_action {req req' : Partial.Request} {uid : EntityUID} {subsmap : Subsmap} : - req.action = .known uid → - req.subst subsmap = some req' → - req'.action = .known uid -:= by - intro h₁ h_req - simp only [Partial.Request.subst, Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq] at h_req - replace ⟨principal, _, ⟨action, h_a, ⟨resource, _, h_req⟩⟩⟩ := h_req - subst req' - simp only - simp only [Partial.UidOrUnknown.subst, h₁, Option.some.injEq] at h_a - exact h_a.symm - -/-- - Partial.Request.subst preserves a known resource UID --/ -theorem req_subst_preserves_known_resource {req req' : Partial.Request} {uid : EntityUID} {subsmap : Subsmap} : - req.resource = .known uid → - req.subst subsmap = some req' → - req'.resource = .known uid -:= by - intro h₁ h_req - simp only [Partial.Request.subst, Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq] at h_req - replace ⟨principal, _, ⟨action, _, ⟨resource, h_r, h_req⟩⟩⟩ := h_req - subst req' - simp only - simp only [Partial.UidOrUnknown.subst, h₁, Option.some.injEq] at h_r - exact h_r.symm - -/-- - Partial.Request.subst preserves the keyset of `context` --/ -theorem req_subst_preserves_keys_of_context {req req' : Partial.Request} {subsmap : Subsmap} : - req.subst subsmap = some req' → - req.context.keys = req'.context.keys -:= by - unfold Partial.Request.subst - simp only [Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq, forall_exists_index, - and_imp] - intro p _ a _ r _ _ - subst req' ; simp only - exact (Map.keys_mapOnValues (Partial.Value.subst subsmap) req.context).symm - -/-- - Partial.Request.subst preserves concrete values in the `context` --/ -theorem req_subst_preserves_concrete_context_vals {req req' : Partial.Request} {k : Attr} {subsmap : Subsmap} : - (k, .value v) ∈ req.context.kvs → - req.subst subsmap = some req' → - (k, .value v) ∈ req'.context.kvs -:= by - unfold Partial.Request.subst - simp only [Option.bind_eq_bind, Option.bind_eq_some, Option.some.injEq, forall_exists_index, - and_imp] - intro h₁ p _ a _ r _ h₂ - subst req' ; simp only - rw [← subst_concrete_value v subsmap] - exact Map.in_kvs_in_mapOnValues h₁ - -/-- - Partial.EntityData.subst preserves well-formedness --/ -theorem entitydata_subst_preserves_wf {ed : Partial.EntityData} (subsmap : Subsmap) : - ed.WellFormed → subsmap.WellFormed → (ed.subst subsmap).WellFormed -:= by - unfold Partial.EntityData.WellFormed Partial.EntityData.subst - intro h₁ h₂ - and_intros - · exact Map.mapOnValues_wf.mp h₁.left - · exact h₁.right.left - · intro pval h₃ - simp [Map.values_mapOnValues] at h₃ - replace ⟨pval', h₃, h₄⟩ := h₃ - subst h₄ - exact val_subst_preserves_wf (h₁.right.right pval' h₃) h₂ - -/-- - Partial.Entities.subst preserves well-formedness --/ -theorem entities_subst_preserves_wf {entities : Partial.Entities} {subsmap : Subsmap} : - entities.WellFormed → subsmap.WellFormed → (entities.subst subsmap).WellFormed -:= by - unfold Partial.Entities.WellFormed Partial.Entities.subst - intro h₁ h₂ - constructor - · exact Map.mapOnValues_wf.mp h₁.left - · intro ed' h₃ - simp only [Map.values_mapOnValues, List.mem_map] at h₃ - replace ⟨ed, h₃, h₄⟩ := h₃ - subst ed' - exact entitydata_subst_preserves_wf subsmap (h₁.right ed h₃) h₂ - -/-- - Partial.EntityData.subst preserves .ancestors --/ -theorem entitydata_subst_preserves_ancestors (ed : Partial.EntityData) (subsmap : Subsmap) : - ed.ancestors = (ed.subst subsmap).ancestors -:= by - simp [Partial.EntityData.subst] - -/-- - Partial.EntityData.subst preserves .contains on .attrs --/ -theorem entitydata_subst_preserves_contains_on_attrs (ed : Partial.EntityData) (attr : Attr) (subsmap : Subsmap) - (wf : ed.WellFormed) : - ed.attrs.contains attr = (ed.subst subsmap).attrs.contains attr -:= by - unfold Partial.EntityData.subst - unfold Partial.EntityData.WellFormed at wf - apply Eq.symm - cases h₁ : ed.attrs.contains attr - case false => - rw [← Bool.not_eq_true] at * - rw [Map.contains_iff_some_find?] at * - simp only [not_exists] at * - intro pval h₂ - conv at h₁ => intro pval ; rw [← Map.in_list_iff_find?_some wf.left] - rw [← Map.in_list_iff_find?_some (Map.mapOnValues_wf.mp wf.left)] at h₂ - simp only [Map.kvs, Map.mapOnValues, List.mem_map, Prod.mk.injEq] at h₂ - replace ⟨(attr', pval'), h₂, h₃, h₄⟩ := h₂ - subst h₃ h₄ - simp only [Map.kvs] at h₁ - exact h₁ pval' h₂ - case true => - rw [Map.contains_iff_some_find?] at * - replace ⟨pval, h₁⟩ := h₁ - rw [← Map.in_list_iff_find?_some wf.left] at h₁ - exists (pval.subst subsmap) - rw [← Map.in_list_iff_find?_some (Map.mapOnValues_wf.mp wf.left)] - simp only [Map.kvs, Map.mapOnValues, List.mem_map, Prod.mk.injEq] - exists (attr, pval) - -/-- - if an attr was present before Partial.EntityData.subst, then the substituted - version of that attr is present after Partial.EntityData.subst --/ -theorem entitydata_subst_preserves_attrs {ed : Partial.EntityData} (subsmap : Subsmap) : - (k, pval) ∈ ed.attrs.kvs → (k, pval.subst subsmap) ∈ (ed.subst subsmap).attrs.kvs -:= by - unfold Partial.EntityData.subst - exact Map.in_kvs_in_mapOnValues - -/-- - Partial.EntityData.subst preserves concrete attribute values --/ -theorem entitydata_subst_preserves_concrete_attrs {ed : Partial.EntityData} (subsmap : Subsmap) : - (k, .value v) ∈ ed.attrs.kvs → (k, .value v) ∈ (ed.subst subsmap).attrs.kvs -:= by - intro h₁ - have h₂ := entitydata_subst_preserves_attrs subsmap h₁ - rw [subst_concrete_value] at h₂ - exact h₂ - -/-- - Partial.EntityData.subst preserves the absence of attribute values --/ -theorem entitydata_subst_preserves_absent_attrs {ed : Partial.EntityData} (subsmap : Subsmap) : - k ∉ ed.attrs.keys → k ∉ (ed.subst subsmap).attrs.keys -:= by - simp only [Partial.EntityData.subst, Map.keys_mapOnValues, imp_self] - -/-- - Partial.Entities.subst preserves .ancestorsOrEmpty --/ -theorem entities_subst_preserves_ancestorsOrEmpty (entities : Partial.Entities) (uid : EntityUID) (subsmap : Subsmap) : - entities.ancestorsOrEmpty uid = (entities.subst subsmap).ancestorsOrEmpty uid -:= by - unfold Partial.Entities.subst Partial.Entities.ancestorsOrEmpty - cases h₁ : entities.es.find? uid - case none => simp only [Map.find?_mapOnValues_none _ h₁] - case some ed => - simp only [Map.find?_mapOnValues_some _ h₁] - exact entitydata_subst_preserves_ancestors ed subsmap - -/-- - Partial.Entities.subst preserves absent entities --/ -theorem entities_subst_preserves_absent_entities {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.es.find? uid = none → (entities.subst subsmap).es.find? uid = none -:= by - simp only [Partial.Entities.subst] - intro h - exact Map.find?_mapOnValues_none _ h - -/-- - Partial.Entities.subst preserves present entities --/ -theorem entities_subst_preserves_present_entities {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.es.find? uid = some ed → ∃ ed', (entities.subst subsmap).es.find? uid = some ed' -:= by - simp only [Partial.Entities.subst] - intro h - exists (ed.subst subsmap) - exact Map.find?_mapOnValues_some _ h - -/-- - if an attr was present before Partial.Entities.subst, then the substituted - version of that attr is present after Partial.Entities.subst --/ -theorem entities_subst_preserves_attrs {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.attrs uid = .ok attrs → - (k, pval) ∈ attrs.kvs → - ∃ attrs', (entities.subst subsmap).attrs uid = .ok attrs' ∧ (k, pval.subst subsmap) ∈ attrs'.kvs -:= by - unfold Partial.Entities.subst Partial.Entities.attrs - cases h₁ : entities.es.findOrErr uid Error.entityDoesNotExist - case error e => simp only [Except.bind_err, false_implies] - case ok ed => - simp only [Except.bind_ok, Except.ok.injEq] - intro h h₂ ; subst h - simp only [Map.findOrErr_mapOnValues, Except.map, h₁, Except.bind_ok, Except.ok.injEq, - exists_eq_left'] - exact entitydata_subst_preserves_attrs subsmap h₂ - -/-- - Partial.Entities.subst preserves concrete attribute values --/ -theorem entities_subst_preserves_concrete_attrs {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.attrs uid = .ok attrs → - (k, .value v) ∈ attrs.kvs → - ∃ attrs', (entities.subst subsmap).attrs uid = .ok attrs' ∧ (k, .value v) ∈ attrs'.kvs -:= by - intro h₁ h₂ - have h₃ := entities_subst_preserves_attrs subsmap h₁ h₂ - rw [subst_concrete_value] at h₃ - exact h₃ - -/-- - Partial.Entities.subst preserves the absence of attribute values --/ -theorem entities_subst_preserves_absent_attrs {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.attrs uid = .ok attrs → - k ∉ attrs.keys → - ∃ attrs', (entities.subst subsmap).attrs uid = .ok attrs' ∧ k ∉ attrs'.keys -:= by - -- structure of this proof is extremely similar to the proof of - -- `entities_subst_preserves_attrs`, maybe they could be shared - simp only [Partial.Entities.subst, Partial.Entities.attrs] - cases h₁ : entities.es.findOrErr uid Error.entityDoesNotExist - case error e => simp only [Except.bind_err, false_implies] - case ok ed => - simp only [Except.bind_ok, Except.ok.injEq] - intro h h₂ ; subst h - simp only [Map.findOrErr_mapOnValues, Except.map, h₁, Except.bind_ok, Except.ok.injEq, - exists_eq_left'] - exact entitydata_subst_preserves_absent_attrs subsmap h₂ - -/-- - Partial.Entities.subst preserves errors returned by `Partial.Entities.attrs` --/ -theorem entities_subst_preserves_error_attrs {entities : Partial.Entities} {uid : EntityUID} (subsmap : Subsmap) : - entities.attrs uid = .error e ↔ (entities.subst subsmap).attrs uid = .error e -:= by - unfold Partial.Entities.subst Partial.Entities.attrs - constructor - case mp => - rcases Map.findOrErr_returns entities.es uid Error.entityDoesNotExist with h₁ | h₁ - · replace ⟨edata, h₁⟩ := h₁ ; simp [h₁] - · simp [h₁] - intro h₂ ; subst e - rw [Map.findOrErr_err_iff_find?_none] at h₁ - cases h₂ : (entities.es.mapOnValues (Partial.EntityData.subst subsmap)).findOrErr uid Error.entityDoesNotExist - case error e => - rcases Map.findOrErr_returns (entities.es.mapOnValues (Partial.EntityData.subst subsmap)) uid Error.entityDoesNotExist with h₃ | h₃ - <;> simp [h₂] at h₃ - · simp [h₃] - case ok edata => - rw [Map.findOrErr_ok_iff_find?_some] at h₂ - simp [Map.find?_mapOnValues_none (Partial.EntityData.subst subsmap) h₁] at h₂ - case mpr => - rcases Map.findOrErr_returns (entities.subst subsmap).es uid Error.entityDoesNotExist with h₁ | h₁ - · replace ⟨edata, h₁⟩ := h₁ - unfold Partial.Entities.subst at h₁ - simp [h₁] - · unfold Partial.Entities.subst at h₁ - simp [h₁] - intro h₂ ; subst e - rw [Map.findOrErr_err_iff_find?_none] at h₁ - cases h₂ : entities.es.findOrErr uid Error.entityDoesNotExist <;> simp - case error e => - rcases Map.findOrErr_returns entities.es uid Error.entityDoesNotExist with h₃ | h₃ - · simp only [h₂, exists_const] at h₃ - · simpa [h₂] using h₃ - case ok edata => - rw [Map.findOrErr_ok_iff_find?_some] at h₂ - have ⟨ed', h₃⟩ := entities_subst_preserves_present_entities subsmap h₂ - unfold Partial.Entities.subst at h₃ - simp [h₃] at h₁ - -/-- - Partial.Entities.subst preserves `Map.contains` for the attrs maps --/ -theorem entities_subst_preserves_contains_on_attrsOrEmpty (entities : Partial.Entities) (uid : EntityUID) (attr : Attr) (subsmap : Subsmap) - (wf : entities.WellFormed) : - (entities.attrsOrEmpty uid).contains attr = ((entities.subst subsmap).attrsOrEmpty uid).contains attr -:= by - unfold Partial.Entities.subst Partial.Entities.attrsOrEmpty - cases h₁ : entities.es.find? uid - case none => simp only [Map.find?_mapOnValues_none _ h₁] - case some ed => - simp only [Map.find?_mapOnValues_some _ h₁] - apply entitydata_subst_preserves_contains_on_attrs ed attr subsmap - unfold Partial.Entities.WellFormed at wf - apply wf.right - simp only [← Map.in_list_iff_find?_some wf.left] at h₁ - exact Map.in_list_in_values h₁ diff --git a/cedar-lean/Cedar/Thm/Partial/WellFormed.lean b/cedar-lean/Cedar/Thm/Partial/WellFormed.lean deleted file mode 100644 index 87677672f..000000000 --- a/cedar-lean/Cedar/Thm/Partial/WellFormed.lean +++ /dev/null @@ -1,91 +0,0 @@ -/- - Copyright Cedar Contributors - - Licensed under the Apache License, Version 2.0 (the "License"); - you may not use this file except in compliance with the License. - You may obtain a copy of the License at - - https://www.apache.org/licenses/LICENSE-2.0 - - Unless required by applicable law or agreed to in writing, software - distributed under the License is distributed on an "AS IS" BASIS, - WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. - See the License for the specific language governing permissions and - limitations under the License. --/ - -import Cedar.Data.SizeOf -import Cedar.Partial.Entities -import Cedar.Partial.Request -import Cedar.Partial.Value -import Cedar.Spec.Request -import Cedar.Spec.Value -import Cedar.Thm.Data.Map -import Cedar.Thm.Data.Set - -/-! - The definition of `WellFormed` used by the `Partial` authorization and - evaluation theorems --/ - -namespace Cedar.Spec - -open Cedar.Data - -/-- All `Prim`s are structurally WellFormed. -/ -def Prim.WellFormed : Spec.Prim → Prop - | _ => true - -/-- All `Ext`s are structurally WellFormed. -/ -def Ext.WellFormed : Ext → Prop - | .decimal _ => true - | .ipaddr _ => true - -def Value.WellFormed : Spec.Value → Prop - | .prim p => p.WellFormed - | .set s => s.WellFormed ∧ ∀ elt ∈ s, elt.WellFormed - | .record r => r.WellFormed ∧ ∀ kv ∈ r.kvs, kv.snd.WellFormed - | .ext x => x.WellFormed -decreasing_by - all_goals simp_wf - case _ h₁ => -- set - have := Set.sizeOf_lt_of_mem h₁ - omega - case _ h₁ => -- record - have h₂ := Map.sizeOf_lt_of_value h₁ - apply Nat.lt_trans h₂ - have h₃ := Map.sizeOf_lt_of_kvs r - simp [Map.kvs] at * - omega - -def Request.WellFormed : Spec.Request → Prop - | { context, .. } => context.WellFormed ∧ ∀ val ∈ context.values, val.WellFormed - -end Cedar.Spec - -namespace Cedar.Partial - -/-- All `ResidualExpr`s are structurally WellFormed. -/ -def ResidualExpr.WellFormed : Partial.ResidualExpr → Prop - | _ => true - -def Value.WellFormed : Partial.Value → Prop - | .value v => v.WellFormed - | .residual r => r.WellFormed - -def Request.WellFormed : Partial.Request → Prop - | { context, .. } => context.WellFormed ∧ ∀ pval ∈ context.values, pval.WellFormed - -def EntityData.WellFormed : Partial.EntityData → Prop - | { attrs, ancestors } => - attrs.WellFormed ∧ - ancestors.WellFormed ∧ - ∀ pval ∈ attrs.values, pval.WellFormed - -def Entities.WellFormed : Partial.Entities → Prop - | { es } => es.WellFormed ∧ ∀ edata ∈ es.values, edata.WellFormed - -def Subsmap.WellFormed : Subsmap → Prop - | { m } => m.WellFormed ∧ ∀ v ∈ m.values, v.WellFormed - -end Cedar.Partial diff --git a/cedar-lean/Cedar/Thm/Validation.lean b/cedar-lean/Cedar/Thm/Validation.lean index 9786070a2..55eadac38 100644 --- a/cedar-lean/Cedar/Thm/Validation.lean +++ b/cedar-lean/Cedar/Thm/Validation.lean @@ -18,6 +18,7 @@ import Cedar.Spec import Cedar.Data import Cedar.Validation import Cedar.Thm.Validation.Validator +import Cedar.Thm.Validation.RequestEntityValidation /-! This file contains the top-level correctness properties for the Cedar validator. @@ -39,12 +40,15 @@ either produces a boolean value, or throws an error of type `entityDoesNotExist` `arithBoundsError`. These errors cannot be protected against at validation time, as they depend on runtime information. -/ + theorem validation_is_sound (policies : Policies) (schema : Schema) (request : Request) (entities : Entities) : validate policies schema = .ok () → - RequestAndEntitiesMatchSchema schema request entities → + validateRequest schema request = .ok () → + validateEntities schema entities = .ok () → AllEvaluateToBool policies request entities := by - intro h₀ h₁ + intro h₀ h₁ h₂ + have h₁ := request_and_entities_validate_implies_match_schema schema request entities h₁ h₂ unfold validate at h₀ simp only [AllEvaluateToBool] cases h₃ : policies with diff --git a/cedar-lean/Cedar/Thm/Validation/RequestEntityValidation.lean b/cedar-lean/Cedar/Thm/Validation/RequestEntityValidation.lean new file mode 100644 index 000000000..bc028b175 --- /dev/null +++ b/cedar-lean/Cedar/Thm/Validation/RequestEntityValidation.lean @@ -0,0 +1,283 @@ +import Cedar.Validation.RequestEntityValidator +import Cedar.Thm.Validation.Typechecker.Types +import Cedar.Thm.Validation.Validator + +namespace Cedar.Thm + +open Cedar.Data +open Cedar.Spec +open Cedar.Validation + +theorem instance_of_bool_type_refl (b : Bool) (bty : BoolType) : + instanceOfBoolType b bty = true → InstanceOfBoolType b bty +:= by + simp only [InstanceOfBoolType, instanceOfBoolType] + intro h₀ + cases h₁ : b <;> cases h₂ : bty <;> subst h₁ <;> subst h₂ <;> simp only at * + +theorem instance_of_entity_type_refl (e : EntityUID) (ety : EntityType) : + instanceOfEntityType e ety = true → InstanceOfEntityType e ety +:= by + simp only [InstanceOfEntityType, instanceOfEntityType] + intro h₀ + simp only [beq_iff_eq] at h₀ + assumption + +theorem instance_of_ext_type_refl (ext : Ext) (extty : ExtType) : + instanceOfExtType ext extty = true → InstanceOfExtType ext extty +:= by + simp only [InstanceOfExtType, instanceOfExtType] + intro h₀ + cases h₁ : ext <;> cases h₂ : extty <;> subst h₁ <;> subst h₂ <;> simp only at * + +theorem instance_of_type_refl (v : Value) (ty : CedarType) : + instanceOfType v ty = true → InstanceOfType v ty +:= by + intro h₀ + unfold instanceOfType at h₀ + cases v with + | prim p => + cases p with + | bool b => + cases ty + case bool bty => + apply InstanceOfType.instance_of_bool b bty + apply instance_of_bool_type_refl + assumption + all_goals + contradiction + | int i => + cases ty + case int => + apply InstanceOfType.instance_of_int + all_goals + contradiction + | string s => + cases ty + case string => + apply InstanceOfType.instance_of_string + all_goals + contradiction + | entityUID uid => + cases ty + case entity ety => + apply InstanceOfType.instance_of_entity uid ety + apply instance_of_entity_type_refl + assumption + all_goals + contradiction + | set s => + cases ty + case set sty => + apply InstanceOfType.instance_of_set s sty + simp only [List.all_eq_true] at h₀ + intro v hv + simp only [← Set.in_list_iff_in_set] at hv + specialize h₀ ⟨v, hv⟩ + simp only [List.attach_def, List.mem_pmap_subtype, hv, true_implies] at h₀ + exact instance_of_type_refl v sty h₀ + all_goals + contradiction + all_goals + contradiction + | record r => + cases ty + case record rty => + apply InstanceOfType.instance_of_record r rty + all_goals + simp only [Bool.and_eq_true, List.all_eq_true] at h₀ + intro k h₁ + simp only [Map.contains_iff_some_find?] at h₁ + have ⟨⟨h₂, _⟩, _⟩ := h₀ + obtain ⟨v, h₁⟩ := h₁ + specialize h₂ (k, v) + simp only at h₂ + apply h₂ + exact Map.find?_mem_toList h₁ + intro k v qty h₁ h₂ + have ⟨⟨_, h₄⟩, _⟩ := h₀ + have h₆ : sizeOf (k,v).snd < 1 + sizeOf r.kvs + := by + have hin := Map.find?_mem_toList h₁ + simp only + replace hin := List.sizeOf_lt_of_mem hin + simp only [Prod.mk.sizeOf_spec, Map.toList] at hin + omega + specialize h₄ ⟨(k, v), h₆⟩ + simp only [List.attach₂, List.mem_pmap_subtype] at h₄ + have h₇ := h₄ (Map.find?_mem_toList h₁) + cases h₈ : rty.find? k with + | none => + rw [h₂] at h₈ + contradiction + | some vl => + simp only [h₈] at h₇ + simp only [h₈, Option.some.injEq] at h₂ + subst h₂ + exact instance_of_type_refl v vl.getType h₇ + intro k qty h₁ h₂ + have ⟨⟨_, h₄⟩, h₅⟩ := h₀ + clear h₀ + simp only [List.attach₂] at h₄ + simp only [requiredAttributePresent, Bool.if_true_right, Bool.decide_eq_true] at h₅ + specialize h₅ (k, qty) + simp only [h₁, Bool.or_eq_true, Bool.not_eq_true'] at h₅ + have h₆ := Map.find?_mem_toList h₁ + simp only [Map.toList] at h₆ + have h₅ := h₅ h₆ + cases h₅ with + | inl h₅ => + rw [h₂] at h₅ + contradiction + | inr h₅ => exact h₅ + all_goals + contradiction + | ext e => + cases ty + case ext ety => + apply InstanceOfType.instance_of_ext + apply instance_of_ext_type_refl + assumption + all_goals + contradiction +termination_by v +decreasing_by + all_goals + simp_wf + simp only [Bool.and_eq_true, List.all_eq_true] at h₀ + case _ v' _ _ _ _ h₁ _ _ _ => + subst h₁ + simp only [Value.set.sizeOf_spec] + have := Set.sizeOf_lt_of_mem hv + omega + case _ h₉ _ _ _ _ _ _ => + subst h₉ + have h₁ := Map.find?_mem_toList h₁ + simp only [Map.toList, Map.kvs] at h₁ + simp only [Value.record.sizeOf_spec, gt_iff_lt] + have := Map.sizeOf_lt_of_value h₁ + omega + +theorem instance_of_request_type_refl (request : Request) (reqty : RequestType) : + instanceOfRequestType request reqty = true → InstanceOfRequestType request reqty +:= by + intro h₀ + simp only [InstanceOfRequestType] + simp only [instanceOfRequestType, Bool.and_eq_true, beq_iff_eq] at h₀ + obtain ⟨⟨⟨h₁,h₂⟩,h₃⟩, h₄⟩ := h₀ + constructor + case left => + apply instance_of_entity_type_refl + exact h₁ + case right => + constructor + case left => + exact h₂ + case right => + constructor + case left => + apply instance_of_entity_type_refl + exact h₃ + case right => + apply instance_of_type_refl + exact h₄ + +theorem instance_of_entity_schema_refl (entities : Entities) (ets : EntitySchema) : + instanceOfEntitySchema entities ets = .ok () → InstanceOfEntitySchema entities ets +:= by + intro h₀ + simp only [InstanceOfEntitySchema] + simp only [instanceOfEntitySchema] at h₀ + generalize h₁ : (fun x : EntityUID × EntityData => instanceOfEntitySchema.instanceOfEntityData ets x.fst x.snd) = f + rw [h₁] at h₀ + intro uid data h₂ + have h₀ := List.forM_ok_implies_all_ok (Map.toList entities) f h₀ + specialize h₀ (uid, data) + have h₀ := h₀ (Map.find?_mem_toList h₂) + rw [← h₁] at h₀ + simp only [instanceOfEntitySchema.instanceOfEntityData] at h₀ + cases h₂ : Map.find? ets uid.ty <;> simp [h₂] at h₀ + case some entry => + exists entry + simp only [true_and] + split at h₀ <;> try simp only at h₀ + rename_i h₃ + constructor + · exact instance_of_type_refl (Value.record data.attrs) (CedarType.record entry.attrs) h₃ + · split at h₀ <;> try simp only at h₀ + rename_i h₄ + simp only [Set.all, List.all_eq_true] at h₄ + constructor + · intro anc ancin + simp only [Set.contains, List.elem_eq_mem, decide_eq_true_eq] at h₄ + rw [← Set.in_list_iff_in_set] at ancin + exact h₄ anc ancin + · split at h₀ <;> try simp only at h₀ + unfold InstanceOfEntityTags + rename_i h₅ + simp only [instanceOfEntitySchema.instanceOfEntityTags] at h₅ + split at h₅ <;> rename_i heq <;> simp only [heq] + · intro v hv + simp only [List.all_eq_true] at h₅ + apply instance_of_type_refl + exact h₅ v hv + · simp only [beq_iff_eq] at h₅ + exact h₅ + +theorem instance_of_action_schema_refl (entities : Entities) (acts : ActionSchema) : + instanceOfActionSchema entities acts = .ok () → InstanceOfActionSchema entities acts +:= by + intro h₀ + simp only [InstanceOfActionSchema] + simp only [instanceOfActionSchema] at h₀ + generalize h₁ : (fun x : EntityUID × ActionSchemaEntry => instanceOfActionSchema.instanceOfActionSchemaData entities x.fst x.snd) = f + rw [h₁] at h₀ + intro uid entry h₂ + have h₀ := List.forM_ok_implies_all_ok (Map.toList acts) f h₀ + specialize h₀ (uid, entry) + have h₀ := h₀ (Map.find?_mem_toList h₂) + rw [← h₁] at h₀ + simp only [instanceOfActionSchema.instanceOfActionSchemaData, beq_iff_eq] at h₀ + cases h₂ : Map.find? entities uid <;> simp [h₂] at h₀ + case some data => + exists data + constructor + rfl + simp only [h₀] + + + +theorem request_and_entities_match_env (env : Environment) (request : Request) (entities : Entities) : + requestMatchesEnvironment env request → + entitiesMatchEnvironment env entities = .ok () → + RequestAndEntitiesMatchEnvironment env request entities +:= by + intro h₀ h₁ + simp only [RequestAndEntitiesMatchEnvironment] + simp only [requestMatchesEnvironment] at h₀ + simp only [entitiesMatchEnvironment] at h₁ + constructor + exact instance_of_request_type_refl request env.reqty h₀ + cases h₂ : instanceOfEntitySchema entities env.ets <;> simp only [h₂, Except.bind_err, Except.bind_ok] at h₁ + constructor + exact instance_of_entity_schema_refl entities env.ets h₂ + exact instance_of_action_schema_refl entities env.acts h₁ + +theorem request_and_entities_validate_implies_match_schema (schema : Schema) (request : Request) (entities : Entities) : + validateRequest schema request = .ok () → + validateEntities schema entities = .ok () → + RequestAndEntitiesMatchSchema schema request entities +:= by + intro h₀ h₁ + simp only [RequestAndEntitiesMatchSchema] + simp only [validateRequest, List.any_eq_true, ite_eq_left_iff, not_exists, not_and, + Bool.not_eq_true, imp_false, Classical.not_forall, not_imp, Bool.not_eq_false] at h₀ + simp only [validateEntities] at h₁ + obtain ⟨env, ⟨h₀, h₂⟩⟩ := h₀ + exists env + constructor + exact h₀ + apply request_and_entities_match_env + exact h₂ + have h₃ := List.forM_ok_implies_all_ok schema.toEnvironments (fun x => entitiesMatchEnvironment x entities) h₁ env h₀ + simp only [h₃] diff --git a/cedar-lean/Cedar/Thm/Validation/Typechecker/Basic.lean b/cedar-lean/Cedar/Thm/Validation/Typechecker/Basic.lean index c1a579384..80de841ba 100644 --- a/cedar-lean/Cedar/Thm/Validation/Typechecker/Basic.lean +++ b/cedar-lean/Cedar/Thm/Validation/Typechecker/Basic.lean @@ -58,11 +58,14 @@ def EvaluatesTo (e: Expr) (request : Request) (entities : Entities) (v : Value) evaluate e request entities = .ok v /-- -On input to the typechecking function, for any (e,k) in the Capabilities, -e is a record- or entity-typed expression that has key k. +On input to the typechecking function, for any (e, .attr k) in the Capabilities, +e is a record- or entity-typed expression that has attribute k. +Similarly, for any (e, .tag k) in the Capabilities, +e is an entity-typed expression that has tag k. -/ def CapabilitiesInvariant (c : Capabilities) (request : Request) (entities : Entities) : Prop := - ∀ (e : Expr) (k : Attr), (e, k) ∈ c → EvaluatesTo (.hasAttr e k) request entities true + (∀ (e : Expr) (k : Attr), (e, .attr k) ∈ c → EvaluatesTo (.hasAttr e k) request entities true) ∧ + (∀ (e k : Expr), (e, .tag k) ∈ c → EvaluatesTo (.binaryApp .hasTag e k) request entities true) /-- The Capabilities output by the typechecking function will satisfy @@ -85,7 +88,8 @@ def TypeOfIsSound (x₁ : Expr) : Prop := theorem empty_capabilities_invariant (request : Request) (entities : Entities) : CapabilitiesInvariant ∅ request entities := by - intro e k h + constructor <;> + intro e k h <;> contradiction theorem empty_guarded_capabilities_invariant {e: Expr} {request : Request} {entities : Entities} : @@ -97,11 +101,11 @@ theorem empty_guarded_capabilities_invariant {e: Expr} {request : Request} {enti theorem capability_implies_record_attribute {x₁ : Expr} {a : Attr} {c₁ : Capabilities} {request : Request} {entities : Entities} {r : Map Attr Value} (h₁ : CapabilitiesInvariant c₁ request entities) (h₂ : evaluate x₁ request entities = Except.ok (Value.record r)) - (h₃ : (x₁, a) ∈ c₁) : + (h₃ : (x₁, .attr a) ∈ c₁) : ∃ vₐ, r.find? a = some vₐ := by simp [CapabilitiesInvariant] at h₁ - specialize h₁ x₁ a h₃ + replace h₁ := h₁.left x₁ a h₃ simp [EvaluatesTo, evaluate, h₂, hasAttr, attrsOf, Map.contains_iff_some_find?] at h₁ exact h₁ @@ -109,11 +113,11 @@ theorem capability_implies_entity_attribute {x₁ : Expr} {a : Attr} {c₁ : Cap (h₁ : CapabilitiesInvariant c₁ request entities) (h₂ : evaluate x₁ request entities = Except.ok (Value.prim (Prim.entityUID uid))) (h₃ : Map.find? entities uid = some d) - (h₄ : (x₁, a) ∈ c₁) : + (h₄ : (x₁, .attr a) ∈ c₁) : ∃ vₐ, d.attrs.find? a = some vₐ := by simp [CapabilitiesInvariant] at h₁ - specialize h₁ x₁ a h₄ + replace h₁ := h₁.left x₁ a h₄ simp [EvaluatesTo, evaluate, h₂, hasAttr, attrsOf, Entities.attrsOrEmpty, h₃, Map.contains_iff_some_find?] at h₁ exact h₁ @@ -122,17 +126,29 @@ theorem capability_union_invariant {c₁ c₂ : Capabilities} {request : Request (h₂ : CapabilitiesInvariant c₂ request entities) : CapabilitiesInvariant (c₁ ∪ c₂) request entities := by - simp [CapabilitiesInvariant] at * - intro x a h₃ - specialize h₁ x a ; specialize h₂ x a - cases h₃ <;> rename_i h₃ <;> simp [h₃] at * <;> assumption + simp only [CapabilitiesInvariant, List.mem_union_iff] at * + constructor <;> + intro x k h₃ + case' left => + replace h₁ := h₁.left x k + replace h₂ := h₂.left x k + case' right => + replace h₁ := h₁.right x k + replace h₂ := h₂.right x k + all_goals { + cases h₃ <;> rename_i h₃ <;> simp [h₃] at * <;> assumption + } theorem capability_intersection_invariant {c₁ c₂ : Capabilities} {request : Request} {entities : Entities} (h₁ : CapabilitiesInvariant c₁ request entities ∨ CapabilitiesInvariant c₂ request entities) : CapabilitiesInvariant (c₁ ∩ c₂) request entities := by - simp [CapabilitiesInvariant] at * - intro x a h₃ h₄ - cases h₁ <;> rename_i h₁ <;> apply h₁ x a <;> assumption + simp only [CapabilitiesInvariant, List.mem_inter_iff, and_imp] at * + constructor <;> + intro x k h₂ h₃ + case left => + cases h₁ <;> rename_i h₁ <;> apply h₁.left x k <;> assumption + case right => + cases h₁ <;> rename_i h₁ <;> apply h₁.right x k <;> assumption end Cedar.Thm diff --git a/cedar-lean/Cedar/Thm/Validation/Typechecker/BinaryApp.lean b/cedar-lean/Cedar/Thm/Validation/Typechecker/BinaryApp.lean index bc38da042..0f8d0b017 100644 --- a/cedar-lean/Cedar/Thm/Validation/Typechecker/BinaryApp.lean +++ b/cedar-lean/Cedar/Thm/Validation/Typechecker/BinaryApp.lean @@ -479,7 +479,7 @@ theorem entity_type_in_false_implies_inₑ_false {euid₁ euid₂ : EntityUID} { split at h₃ case h_1 data h₄ => rw [Set.contains_prop_bool_equiv] at h₃ - have ⟨entry, h₂₁, _, h₂₂⟩ := h₁ euid₁ data h₄ + have ⟨entry, h₂₁, _, h₂₂, _⟩ := h₁ euid₁ data h₄ specialize h₂₂ euid₂ h₃ rw [←Set.contains_prop_bool_equiv] at h₂₂ simp [h₂₁, h₂₂] at h₂ @@ -607,7 +607,7 @@ theorem entity_type_in_false_implies_inₛ_false {euid : EntityUID} {euids : Lis cases h₆ : Map.find? entities euid <;> simp only [h₆, List.not_mem_nil] at h₅ rename_i data - replace ⟨entry, h₁, _, h₇⟩ := h₁ euid data h₆ + replace ⟨entry, h₁, _, h₇, _⟩ := h₁ euid data h₆ specialize h₇ euid' h₅ split at h₂ <;> try contradiction rename_i h₈ @@ -827,6 +827,220 @@ theorem type_of_mem_is_sound {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env · exact type_of_mem_is_soundₑ h₁ h₂ h₄ h₅ ih₁ ih₂ · exact type_of_mem_is_soundₛ h₁ h₂ h₄ h₅ ih₁ ih₂ +theorem type_of_hasTag_inversion {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} + (h₁ : typeOf (Expr.binaryApp .hasTag x₁ x₂) c₁ env = .ok (ty, c₂)) : + ∃ ety c₁' c₂', + typeOf x₁ c₁ env = .ok (.entity ety, c₁') ∧ + typeOf x₂ c₁ env = .ok (.string, c₂') ∧ + typeOfHasTag ety x₁ x₂ c₁ env = .ok (ty, c₂) +:= by + simp only [typeOf] at h₁ + cases h₂ : typeOf x₁ c₁ env <;> simp only [h₂, Except.bind_ok, Except.bind_err] at h₁ + cases h₃ : typeOf x₂ c₁ env <;> simp only [h₃, Except.bind_ok, Except.bind_err] at h₁ + rename_i tyc₁ tyc₂ + cases tyc₁ + cases tyc₂ + rename_i ty₁ c₁' ty₂ c₂' + simp only at h₁ + cases ty₁ <;> cases ty₂ <;> + simp only [typeOfBinaryApp, err] at h₁ + rename_i ety + exists ety, c₁', c₂' + +private theorem map_empty_contains_instance_of_ff [DecidableEq α] [DecidableEq β] {k : α} : + InstanceOfType (Value.prim (Prim.bool ((Map.empty : Map α β).contains k))) (CedarType.bool BoolType.ff) +:= by + simp only [Map.not_contains_of_empty, false_is_instance_of_ff] + +private theorem no_tags_type_implies_no_tags {uid : EntityUID} {env : Environment} {entities : Entities} + (h₁ : InstanceOfEntitySchema entities env.ets) + (h₂ : env.ets.tags? uid.ty = .some .none) : + InstanceOfType (Value.prim (Prim.bool ((entities.tagsOrEmpty uid).contains s))) (CedarType.bool BoolType.ff) +:= by + simp only [Entities.tagsOrEmpty] + split + · rename_i d hf + replace ⟨e, hf', _, _, h₁⟩ := h₁ uid d hf + simp only [InstanceOfEntityTags] at h₁ + simp only [EntitySchema.tags?, Option.map_eq_some'] at h₂ + replace ⟨e', h₂, h₃⟩ := h₂ + simp only [hf', Option.some.injEq] at h₂ + subst h₂ + simp only [h₃] at h₁ + simp only [h₁, map_empty_contains_instance_of_ff] + · exact map_empty_contains_instance_of_ff + +private theorem no_type_implies_no_tags {uid : EntityUID} {env : Environment} {entities : Entities} + (h₁ : InstanceOfEntitySchema entities env.ets) + (h₂ : env.ets.tags? uid.ty = .none) : + InstanceOfType (Value.prim (Prim.bool ((entities.tagsOrEmpty uid).contains s))) (CedarType.bool BoolType.ff) +:= by + simp only [Entities.tagsOrEmpty] + split + · rename_i d hf + replace ⟨e, h₁, _, _, _⟩ := h₁ uid d hf + simp only [EntitySchema.tags?, Option.map_eq_none'] at h₂ + simp only [h₁] at h₂ + · exact map_empty_contains_instance_of_ff + +private theorem mem_capabilities_implies_mem_tags {x₁ x₂ : Expr} {c₁ : Capabilities} {request : Request} {entities : Entities} {uid : EntityUID} {s : String} + (h₁ : CapabilitiesInvariant c₁ request entities) + (ih₁ : evaluate x₁ request entities = Except.ok (Value.prim (Prim.entityUID uid))) + (ih₂ : evaluate x₂ request entities = Except.ok (Value.prim (Prim.string s))) + (hin : (x₁, Key.tag x₂) ∈ c₁) : + InstanceOfType (Value.prim (Prim.bool ((entities.tagsOrEmpty uid).contains s))) (CedarType.bool BoolType.tt) +:= by + replace h₁ := h₁.right x₁ x₂ hin + simp only [EvaluatesTo, evaluate, ih₁, ih₂, apply₂, hasTag, Except.bind_ok, Except.ok.injEq, + Value.prim.injEq, Prim.bool.injEq, false_or] at h₁ + simp only [h₁, true_is_instance_of_tt] + +private theorem hasTag_true_implies_cap_inv {x₁ x₂ : Expr} {request : Request} {entities : Entities} {uid : EntityUID} {s : String} + (ih₁ : evaluate x₁ request entities = Except.ok (Value.prim (Prim.entityUID uid))) + (ih₂ : evaluate x₂ request entities = Except.ok (Value.prim (Prim.string s))) + (ht : (entities.tagsOrEmpty uid).contains s = true) : + CapabilitiesInvariant (Capabilities.singleton x₁ (Key.tag x₂)) request entities +:= by + constructor <;> + intro e k hin <;> + simp only [Capabilities.singleton, List.mem_singleton, Prod.mk.injEq, and_false, Key.tag.injEq] at hin + replace ⟨hin, hin'⟩ := hin + subst hin hin' + simp only [EvaluatesTo, evaluate, ih₁, ih₂, apply₂, hasTag, Except.bind_ok, ht, or_true] + +theorem type_of_hasTag_is_sound {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} {request : Request} {entities : Entities} + (h₁ : CapabilitiesInvariant c₁ request entities) + (h₂ : RequestAndEntitiesMatchEnvironment env request entities) + (h₃ : typeOf (Expr.binaryApp .hasTag x₁ x₂) c₁ env = Except.ok (ty, c₂)) + (ih₁ : TypeOfIsSound x₁) + (ih₂ : TypeOfIsSound x₂) : + GuardedCapabilitiesInvariant (Expr.binaryApp .hasTag x₁ x₂) c₂ request entities ∧ + ∃ v, EvaluatesTo (Expr.binaryApp .hasTag x₁ x₂) request entities v ∧ InstanceOfType v ty +:= by + replace ⟨ety, c₁', c₂', h₄, h₅, h₃⟩ := type_of_hasTag_inversion h₃ + replace ⟨_, v₁, ih₁, hty₁⟩ := ih₁ h₁ h₂ h₄ + replace ⟨_, v₂, ih₂, hty₂⟩ := ih₂ h₁ h₂ h₅ + simp only [EvaluatesTo] at * + simp only [GuardedCapabilitiesInvariant, evaluate] + rcases ih₁ with ih₁ | ih₁ | ih₁ | ih₁ <;> + simp only [ih₁, Except.bind_ok, Except.bind_err, false_implies, Except.error.injEq, or_false, or_true, true_and] + any_goals (apply type_is_inhabited) + rcases ih₂ with ih₂ | ih₂ | ih₂ | ih₂ <;> + simp only [ih₂, Except.bind_ok, Except.bind_err, false_implies, Except.error.injEq, or_false, or_true, true_and] + any_goals (apply type_is_inhabited) + replace ⟨uid, hty₁, hv₁⟩ := instance_of_entity_type_is_entity hty₁ + replace ⟨s, hv₂⟩ := instance_of_string_is_string hty₂ + subst hv₁ hv₂ hty₁ + simp only [apply₂, hasTag, Except.ok.injEq, Value.prim.injEq, Prim.bool.injEq, false_or, exists_eq_left'] + simp only [typeOfHasTag, List.empty_eq] at h₃ + have hempty := empty_capabilities_invariant request entities + simp only [List.empty_eq] at hempty + split at h₃ <;> simp [ok, err] at h₃ + case h_1 heq => + replace ⟨h₃, h₆⟩ := h₃ + subst h₃ h₆ + simp only [hempty, implies_true, true_and] + exact no_tags_type_implies_no_tags h₂.right.left heq + case h_2 => + split at h₃ <;> simp only [Except.ok.injEq, Prod.mk.injEq] at h₃ <;> + replace ⟨h₃, h₆⟩ := h₃ <;> + subst h₃ h₆ + case isTrue hin => + simp only [hempty, implies_true, true_and] + exact mem_capabilities_implies_mem_tags h₁ ih₁ ih₂ hin + case isFalse => + simp only [bool_is_instance_of_anyBool, and_true] + intro ht + exact hasTag_true_implies_cap_inv ih₁ ih₂ ht + case h_3 heq => + split at h₃ <;> simp only [Except.ok.injEq, Prod.mk.injEq] at h₃ + rename_i hact + replace ⟨h₃, h₆⟩ := h₃ + subst h₃ h₆ + simp only [hempty, implies_true, true_and] + exact no_type_implies_no_tags h₂.right.left heq + +theorem type_of_getTag_inversion {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} + (h₁ : typeOf (Expr.binaryApp .getTag x₁ x₂) c₁ env = .ok (ty, c₂)) : + c₂ = [] ∧ + ∃ ety c₁' c₂', + typeOf x₁ c₁ env = .ok (.entity ety, c₁') ∧ + typeOf x₂ c₁ env = .ok (.string, c₂') ∧ + env.ets.tags? ety = some (some ty) ∧ + (x₁, .tag x₂) ∈ c₁ +:= by + simp only [typeOf] at h₁ + cases h₂ : typeOf x₁ c₁ env <;> simp only [h₂, Except.bind_ok, Except.bind_err] at h₁ + cases h₃ : typeOf x₂ c₁ env <;> simp only [h₃, Except.bind_ok, Except.bind_err] at h₁ + rename_i tyc₁ tyc₂ + cases tyc₁ + cases tyc₂ + rename_i ty₁ c₁' ty₂ c₂' + simp only at h₁ + cases ty₁ <;> cases ty₂ <;> + simp only [typeOfBinaryApp, err] at h₁ + rename_i ety + simp only [typeOfGetTag, List.empty_eq] at h₁ + split at h₁ <;> simp only [ok, err] at h₁ + split at h₁ <;> simp only [Except.ok.injEq, Prod.mk.injEq] at h₁ + rename_i h₄ h₅ + replace ⟨h₁, h₁'⟩ := h₁ + subst h₁ h₁' + simp only [Except.ok.injEq, Prod.mk.injEq, CedarType.entity.injEq, true_and, h₅, and_true, + exists_and_left, exists_and_right, exists_eq', exists_eq_left', h₄, and_self] + +theorem type_of_getTag_is_sound {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} {request : Request} {entities : Entities} + (h₁ : CapabilitiesInvariant c₁ request entities) + (h₂ : RequestAndEntitiesMatchEnvironment env request entities) + (h₃ : typeOf (Expr.binaryApp .getTag x₁ x₂) c₁ env = Except.ok (ty, c₂)) + (ih₁ : TypeOfIsSound x₁) + (ih₂ : TypeOfIsSound x₂) : + GuardedCapabilitiesInvariant (Expr.binaryApp .getTag x₁ x₂) c₂ request entities ∧ + ∃ v, EvaluatesTo (Expr.binaryApp .getTag x₁ x₂) request entities v ∧ InstanceOfType v ty +:= by + replace ⟨hc, ety, c₁', c₂', h₃, h₄, h₅, h₆⟩ := type_of_getTag_inversion h₃ + subst hc + replace ⟨_, v₁, ih₁, hty₁⟩ := ih₁ h₁ h₂ h₃ + replace ⟨_, v₂, ih₂, hty₂⟩ := ih₂ h₁ h₂ h₄ + simp only [EvaluatesTo] at * + simp only [GuardedCapabilitiesInvariant, evaluate] + rcases ih₁ with ih₁ | ih₁ | ih₁ | ih₁ <;> + simp only [ih₁, Except.bind_ok, Except.bind_err, false_implies, Except.error.injEq, or_false, or_true, true_and] + any_goals (apply type_is_inhabited) + rcases ih₂ with ih₂ | ih₂ | ih₂ | ih₂ <;> + simp only [ih₂, Except.bind_ok, Except.bind_err, false_implies, Except.error.injEq, or_false, or_true, true_and] + any_goals (apply type_is_inhabited) + replace ⟨uid, hty₁, hv₁⟩ := instance_of_entity_type_is_entity hty₁ + replace ⟨s, hv₂⟩ := instance_of_string_is_string hty₂ + subst hv₁ hv₂ hty₁ + simp only [apply₂, hasTag, Except.ok.injEq, Value.prim.injEq, Prim.bool.injEq, false_or, exists_eq_left'] + simp only [getTag, Entities.tags] + have hf₁ := Map.findOrErr_returns entities uid Error.entityDoesNotExist + rcases hf₁ with ⟨d, hf₁⟩ | hf₁ <;> + simp only [hf₁, Except.bind_ok, Except.bind_err, false_implies, Except.error.injEq, or_self, or_false, true_and, + type_is_inhabited, and_self] + rw [Map.findOrErr_ok_iff_find?_some] at hf₁ + replace ⟨entry, hf₂, _, _, h₂⟩ := h₂.right.left uid d hf₁ + simp only [InstanceOfEntityTags] at h₂ + simp only [EntitySchema.tags?, Option.map_eq_some'] at h₅ + replace ⟨_, h₅, h₇⟩ := h₅ + simp only [hf₂, Option.some.injEq] at h₅ + subst h₅ + simp only [h₇] at h₂ + have hf₃ := Map.findOrErr_returns d.tags s Error.tagDoesNotExist + rcases hf₃ with ⟨v, hf₃⟩ | hf₃ <;> + simp only [hf₃, false_implies, Except.error.injEq, or_self, false_and, exists_const, and_false, + Except.ok.injEq, false_or, exists_eq_left'] + · simp only [← List.empty_eq, empty_capabilities_invariant request entities, implies_true, true_and] + apply h₂ + exact Map.findOrErr_ok_implies_in_values hf₃ + · replace h₁ := h₁.right x₁ x₂ h₆ + simp only [EvaluatesTo, evaluate, ih₁, ih₂, apply₂, hasTag, Except.bind_ok, Except.ok.injEq, + Value.prim.injEq, Prim.bool.injEq, false_or] at h₁ + simp only [Entities.tagsOrEmpty, hf₁, Map.contains_iff_some_find?] at h₁ + replace ⟨_, h₁⟩ := h₁ + simp only [Map.findOrErr_err_iff_find?_none, h₁] at hf₃ + theorem type_of_binaryApp_is_sound {op₂ : BinaryOp} {x₁ x₂ : Expr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} {request : Request} {entities : Entities} (h₁ : CapabilitiesInvariant c₁ request entities) (h₂ : RequestAndEntitiesMatchEnvironment env request entities) @@ -847,5 +1061,7 @@ theorem type_of_binaryApp_is_sound {op₂ : BinaryOp} {x₁ x₂ : Expr} {c₁ c | .containsAll | .containsAny => exact type_of_containsA_is_sound (by simp) h₁ h₂ h₃ ih₁ ih₂ | .mem => exact type_of_mem_is_sound h₁ h₂ h₃ ih₁ ih₂ + | .hasTag => exact type_of_hasTag_is_sound h₁ h₂ h₃ ih₁ ih₂ + | .getTag => exact type_of_getTag_is_sound h₁ h₂ h₃ ih₁ ih₂ end Cedar.Thm diff --git a/cedar-lean/Cedar/Thm/Validation/Typechecker/HasAttr.lean b/cedar-lean/Cedar/Thm/Validation/Typechecker/HasAttr.lean index 7fbcdf2aa..a31e7ca04 100644 --- a/cedar-lean/Cedar/Thm/Validation/Typechecker/HasAttr.lean +++ b/cedar-lean/Cedar/Thm/Validation/Typechecker/HasAttr.lean @@ -28,7 +28,7 @@ open Cedar.Validation theorem type_of_hasAttr_inversion {x₁ : Expr} {a : Attr} {c₁ c₂ : Capabilities} {env : Environment} {ty : CedarType} (h₁ : typeOf (Expr.hasAttr x₁ a) c₁ env = Except.ok (ty, c₂)) : - (c₂ = ∅ ∨ c₂ = Capabilities.singleton x₁ a) ∧ + (c₂ = ∅ ∨ c₂ = Capabilities.singleton x₁ (.attr a)) ∧ ∃ c₁', (∃ ety, typeOf x₁ c₁ env = Except.ok (.entity ety, c₁')) ∨ (∃ rty, typeOf x₁ c₁ env = Except.ok (.record rty, c₁')) @@ -76,7 +76,7 @@ theorem type_of_hasAttr_is_sound_for_records {x₁ : Expr} {a : Attr} {c₁ c₁ cases h₇ case isTrue.h₁.false.inl _ h₇ => simp [CapabilitiesInvariant] at h₁ - specialize h₁ x₁ a h₇ + replace h₁ := h₁.left x₁ a h₇ simp [EvaluatesTo, evaluate, h₄, hasAttr, attrsOf, h₆] at h₁ case isTrue.h₁.false.inr h₇ _ h₈ => simp [Qualified.isRequired] at h₈ @@ -123,7 +123,7 @@ theorem type_of_hasAttr_is_sound_for_entities {x₁ : Expr} {a : Attr} {c₁ c cases h₈ : Map.contains (Entities.attrsOrEmpty entities uid) a <;> simp rename_i _ _ _ _ h₉ simp [CapabilitiesInvariant] at h₁ - specialize h₁ x₁ a h₉ + replace h₁ := h₁.left x₁ a h₉ simp [EvaluatesTo, evaluate, h₅, hasAttr, attrsOf, h₈] at h₁ case h_1.h_2 => simp [ok] at h₃ @@ -171,7 +171,9 @@ theorem type_of_hasAttr_is_sound {x₁ : Expr} {a : Attr} {c₁ c₂ : Capabilit apply And.intro case left => simp [GuardedCapabilitiesInvariant, CapabilitiesInvariant] - intro h₆ x aₓ h₇ + intro h₆ + constructor <;> + intro x aₓ h₇ <;> cases h₅ <;> rename_i h₈ <;> subst h₈ <;> simp [Capabilities.singleton] at h₇ have ⟨h₇, h₈⟩ := h₇ subst h₇; subst h₈ diff --git a/cedar-lean/Cedar/Thm/Validation/Typechecker/Types.lean b/cedar-lean/Cedar/Thm/Validation/Typechecker/Types.lean index 00f9bf4d2..07588123f 100644 --- a/cedar-lean/Cedar/Thm/Validation/Typechecker/Types.lean +++ b/cedar-lean/Cedar/Thm/Validation/Typechecker/Types.lean @@ -79,18 +79,25 @@ def InstanceOfRequestType (request : Request) (reqty : RequestType) : Prop := InstanceOfEntityType request.resource reqty.resource ∧ InstanceOfType request.context (.record reqty.context) +def InstanceOfEntityTags (data : EntityData) (entry : EntitySchemaEntry) : Prop := + match entry.tags with + | .some tty => ∀ v ∈ data.tags.values, InstanceOfType v tty + | .none => data.tags = Map.empty + /-- For every entity in the store, 1. The entity's type is defined in the type store. 2. The entity's attributes match the attribute types indicated in the type store. 3. The entity's ancestors' types are consistent with the ancestor information in the type store. +4. The entity's tags' types are consistent with the tags information in the type store. -/ def InstanceOfEntitySchema (entities : Entities) (ets: EntitySchema) : Prop := ∀ uid data, entities.find? uid = some data → ∃ entry, ets.find? uid.ty = some entry ∧ InstanceOfType data.attrs (.record entry.attrs) ∧ - ∀ ancestor, ancestor ∈ data.ancestors → ancestor.ty ∈ entry.ancestors + (∀ ancestor, ancestor ∈ data.ancestors → ancestor.ty ∈ entry.ancestors) ∧ + InstanceOfEntityTags data entry /-- For every action in the entity store, the action's ancestors are consistent diff --git a/cedar-lean/Cedar/Thm/Validation/Validator.lean b/cedar-lean/Cedar/Thm/Validation/Validator.lean index 37c4800a9..ec175bc98 100644 --- a/cedar-lean/Cedar/Thm/Validation/Validator.lean +++ b/cedar-lean/Cedar/Thm/Validation/Validator.lean @@ -36,7 +36,7 @@ def AllEvaluateToBool (policies : Policies) (request : Request) (entities : Enti ∀ policy ∈ policies, EvaluatesToBool policy.toExpr request entities def RequestAndEntitiesMatchSchema (schema : Schema) (request : Request) (entities : Entities) :Prop := - ∀ env ∈ schema.toEnvironments, + ∃ env ∈ schema.toEnvironments, RequestAndEntitiesMatchEnvironment env request entities theorem action_matches_env (env : Environment) (request : Request) (entities : Entities) : @@ -95,7 +95,7 @@ theorem typecheck_policy_is_sound (policy : Policy) (env : Environment) (ty : Ce repeat assumption theorem typecheck_policy_with_environments_is_sound (policy : Policy) (envs : List Environment) (request : Request) (entities : Entities) : - (∀ env ∈ envs, RequestAndEntitiesMatchEnvironment env request entities) → + (∃ env ∈ envs, RequestAndEntitiesMatchEnvironment env request entities) → typecheckPolicyWithEnvironments policy envs = .ok () → ∃ b : Bool, EvaluatesTo policy.toExpr request entities b := by @@ -104,23 +104,12 @@ theorem typecheck_policy_with_environments_is_sound (policy : Policy) (envs : Li cases h₃ : List.mapM (typecheckPolicy policy) envs with | error => simp only [h₃, Except.bind_err] at h₂ | ok ts => - simp only [h₃, Except.bind_ok, ite_eq_right_iff, imp_false, Bool.not_eq_true] at h₂ - cases h₄ : envs with - | nil => - simp only [h₄, List.mapM_nil, pure, Except.pure, Except.ok.injEq] at h₃ - subst h₃ - simp only [allFalse, List.all_nil, Bool.true_eq_false] at h₂ - | cons h t => - rw [List.mapM_ok_iff_forall₂] at h₃ - have h₆ : RequestAndEntitiesMatchEnvironment h request entities := by - have h₇ : h ∈ envs := by simp only [h₄, List.mem_cons, true_or] - specialize h₀ h - apply h₀ h₇ - subst h₄ - rw [List.forall₂_cons_left_iff] at h₃ - simp only [exists_and_left] at h₃ - obtain ⟨ b, _, _, _, _ ⟩ := h₃ - apply typecheck_policy_is_sound policy h b - repeat assumption + simp only [h₃, Except.bind_ok, ite_eq_right_iff, imp_false, Bool.not_eq_true, allFalse] at h₂ + obtain ⟨env, ⟨h₀, h₁⟩⟩ := h₀ + rw [List.mapM_ok_iff_forall₂] at h₃ + have h₄ := List.forall₂_implies_all_left h₃ + specialize h₄ env h₀ + obtain ⟨ty, ⟨_, h₅⟩⟩ := h₄ + exact typecheck_policy_is_sound policy env ty request entities h₁ h₅ end Cedar.Thm diff --git a/cedar-lean/Cedar/Validation/RequestEntityValidator.lean b/cedar-lean/Cedar/Validation/RequestEntityValidator.lean index 76fd25320..10a825918 100644 --- a/cedar-lean/Cedar/Validation/RequestEntityValidator.lean +++ b/cedar-lean/Cedar/Validation/RequestEntityValidator.lean @@ -60,11 +60,11 @@ def instanceOfType (v : Value) (ty : CedarType) : Bool := | .prim (.entityUID e), .entity ety => instanceOfEntityType e ety | .set s, .set ty => s.elts.attach.all (λ ⟨v, _⟩ => instanceOfType v ty) | .record r, .record rty => - r.keys.all rty.keys.contains && + r.kvs.all (λ (k, _) => rty.contains k) && (r.kvs.attach₂.all (λ ⟨(k, v), _⟩ => (match rty.find? k with | .some qty => instanceOfType v qty.getType | _ => true))) && - rty.keys.all (requiredAttributePresent r rty) + rty.kvs.all (λ (k, _) => requiredAttributePresent r rty k) | .ext x, .ext xty => instanceOfExtType x xty | _, _ => false termination_by v @@ -91,16 +91,24 @@ For every entity in the store, 2. The entity's attributes match the attribute types indicated in the type store. 3. The entity's ancestors' types are consistent with the ancestor information in the type store. +4. The entity's tags' types are consistent with the tags information in the type store. -/ def instanceOfEntitySchema (entities : Entities) (ets : EntitySchema) : EntityValidationResult := entities.toList.forM λ (uid, data) => instanceOfEntityData uid data where + instanceOfEntityTags (data : EntityData) (entry : EntitySchemaEntry) : Bool := + match entry.tags with + | .some tty => data.tags.values.all (instanceOfType · tty) + | .none => data.tags == Map.empty instanceOfEntityData uid data := match ets.find? uid.ty with - | .some entry => if instanceOfType data.attrs (.record entry.attrs) then - if data.ancestors.all (λ ancestor => entry.ancestors.contains ancestor.ty) then .ok () - else .error (.typeError s!"entity ancestors inconsistent with type store information") - else .error (.typeError "entity attributes do not match type store") + | .some entry => + if instanceOfType data.attrs (.record entry.attrs) then + if data.ancestors.all (λ ancestor => entry.ancestors.contains ancestor.ty) then + if instanceOfEntityTags data entry then .ok () + else .error (.typeError s!"entity tags inconsistent with type store") + else .error (.typeError s!"entity ancestors inconsistent with type store") + else .error (.typeError "entity attributes do not match type store") | _ => .error (.typeError "entity type not defined in type store") /-- @@ -129,7 +137,8 @@ def entitiesMatchEnvironment (env : Environment) (entities : Entities) : EntityV def actionSchemaEntryToEntityData (ase : ActionSchemaEntry) : EntityData := { ancestors := ase.ancestors, - attrs := Map.empty + attrs := Map.empty, + tags := Map.empty } /-- @@ -151,14 +160,12 @@ def updateSchema (schema : Schema) (actionSchemaEntities : Entities) : Schema := edt.ancestors.elts.map (·.ty) )) let ese : EntitySchemaEntry := { ancestors := Set.make allAncestorsForType, - attrs := Map.empty + attrs := Map.empty, + tags := Option.none } (ty, ese) def validateEntities (schema : Schema) (entities : Entities) : EntityValidationResult := - let actionEntities := (schema.acts.mapOnValues actionSchemaEntryToEntityData) - let entities := Map.make (entities.kvs ++ actionEntities.kvs) - let schema := updateSchema schema actionEntities schema.toEnvironments.forM (entitiesMatchEnvironment · entities) -- json diff --git a/cedar-lean/Cedar/Validation/Typechecker.lean b/cedar-lean/Cedar/Validation/Typechecker.lean index 1524f98ab..20c0133d5 100644 --- a/cedar-lean/Cedar/Validation/Typechecker.lean +++ b/cedar-lean/Cedar/Validation/Typechecker.lean @@ -26,15 +26,21 @@ inductive TypeError where | lubErr (ty₁ : CedarType) (ty₂ : CedarType) | unexpectedType (ty : CedarType) | attrNotFound (ty : CedarType) (attr : Attr) + | tagNotFound (ety : EntityType) (tag : Expr) | unknownEntity (ety : EntityType) | extensionErr (xs : List Expr) | emptySetErr | incompatibleSetTypes (ty : List CedarType) deriving Repr, DecidableEq -abbrev Capabilities := List (Expr × Attr) +inductive Key where + | attr (a : Attr) + | tag (x : Expr) +deriving Repr, DecidableEq + +abbrev Capabilities := List (Expr × Key) -def Capabilities.singleton (e : Expr) (a : Attr) : Capabilities := [(e, a)] +def Capabilities.singleton (e : Expr) (k : Key) : Capabilities := [(e, k)] abbrev ResultType := Except TypeError (CedarType × Capabilities) @@ -133,6 +139,9 @@ def actionUID? (x : Expr) (acts: ActionSchema) : Option EntityUID := do let uid ← entityUID? x if acts.contains uid then .some uid else .none +def actionType? (ety : EntityType) (acts: ActionSchema) : Bool := + acts.keys.any (EntityUID.ty · == ety) + -- x₁ in x₂ where x₁ has type ety₁ and x₂ has type ety₂ def typeOfInₑ (ety₁ ety₂ : EntityType) (x₁ x₂ : Expr) (env : Environment) : BoolType := match actionUID? x₁ env.acts, entityUID? x₂ with @@ -157,16 +166,36 @@ def typeOfInₛ (ety₁ ety₂ : EntityType) (x₁ x₂ : Expr) (env : Environme then .anyBool else .ff +def typeOfHasTag (ety : EntityType) (x : Expr) (t : Expr) (c : Capabilities) (env : Environment) : ResultType := + match env.ets.tags? ety with + | .some .none => ok (.bool .ff) + | .some (.some _) => + if (x, .tag t) ∈ c + then ok (.bool .tt) + else ok (.bool .anyBool) (Capabilities.singleton x (.tag t)) + | .none => + if actionType? ety env.acts + then ok (.bool .ff) -- action tags not allowed + else err (.unknownEntity ety) + +def typeOfGetTag (ety : EntityType) (x : Expr) (t : Expr) (c : Capabilities) (env : Environment) : ResultType := + match env.ets.tags? ety with + | .some .none => err (.tagNotFound ety t) + | .some (.some ty) => if (x, .tag t) ∈ c then ok ty else err (.tagNotFound ety t) + | .none => err (.unknownEntity ety) + def ifLubThenBool (ty₁ ty₂ : CedarType) : ResultType := match ty₁ ⊔ ty₂ with | some _ => ok (.bool .anyBool) | none => err (.lubErr ty₁ ty₂) -def typeOfBinaryApp (op₂ : BinaryOp) (ty₁ ty₂ : CedarType) (x₁ x₂ : Expr) (env : Environment) : ResultType := +def typeOfBinaryApp (op₂ : BinaryOp) (ty₁ ty₂ : CedarType) (x₁ x₂ : Expr) (c : Capabilities) (env : Environment) : ResultType := match op₂, ty₁, ty₂ with | .eq, _, _ => typeOfEq ty₁ ty₂ x₁ x₂ | .mem, .entity ety₁, .entity ety₂ => ok (.bool (typeOfInₑ ety₁ ety₂ x₁ x₂ env)) | .mem, .entity ety₁, .set (.entity ety₂) => ok (.bool (typeOfInₛ ety₁ ety₂ x₁ x₂ env)) + | .hasTag, .entity ety₁, .string => typeOfHasTag ety₁ x₁ x₂ c env + | .getTag, .entity ety₁, .string => typeOfGetTag ety₁ x₁ x₂ c env | .less, .int, .int => ok (.bool .anyBool) | .lessEq, .int, .int => ok (.bool .anyBool) | .add, .int, .int => ok .int @@ -180,14 +209,11 @@ def typeOfBinaryApp (op₂ : BinaryOp) (ty₁ ty₂ : CedarType) (x₁ x₂ : Ex def hasAttrInRecord (rty : RecordType) (x : Expr) (a : Attr) (c : Capabilities) (knownToExist : Bool) : ResultType := match rty.find? a with | .some qty => - if (x, a) ∈ c || (qty.isRequired && knownToExist) + if (x, .attr a) ∈ c || (qty.isRequired && knownToExist) then ok (.bool .tt) - else ok (.bool .anyBool) (Capabilities.singleton x a) + else ok (.bool .anyBool) (Capabilities.singleton x (.attr a)) | .none => ok (.bool .ff) -def actionType? (ety : EntityType) (acts: ActionSchema) : Bool := - acts.keys.any (EntityUID.ty · == ety) - def typeOfHasAttr (ty : CedarType) (x : Expr) (a : Attr) (c : Capabilities) (env : Environment) : ResultType := match ty with | .record rty => hasAttrInRecord rty x a c true @@ -203,7 +229,7 @@ def typeOfHasAttr (ty : CedarType) (x : Expr) (a : Attr) (c : Capabilities) (env def getAttrInRecord (ty : CedarType) (rty : RecordType) (x : Expr) (a : Attr) (c : Capabilities) : ResultType := match rty.find? a with | .some (.required aty) => ok aty - | .some (.optional aty) => if (x, a) ∈ c then ok aty else err (.attrNotFound ty a) + | .some (.optional aty) => if (x, .attr a) ∈ c then ok aty else err (.attrNotFound ty a) | .none => err (.attrNotFound ty a) def typeOfGetAttr (ty : CedarType) (x : Expr) (a : Attr) (c : Capabilities) (env : Environment) : ResultType := @@ -275,7 +301,7 @@ def typeOf (x : Expr) (c : Capabilities) (env : Environment) : ResultType := | .binaryApp op₂ x₁ x₂ => do let (ty₁, _) ← typeOf x₁ c env let (ty₂, _) ← typeOf x₂ c env - typeOfBinaryApp op₂ ty₁ ty₂ x₁ x₂ env + typeOfBinaryApp op₂ ty₁ ty₂ x₁ x₂ c env | .hasAttr x₁ a => do let (ty₁, _) ← typeOf x₁ c env typeOfHasAttr ty₁ x₁ a c env diff --git a/cedar-lean/Cedar/Validation/Types.lean b/cedar-lean/Cedar/Validation/Types.lean index 40950b4bf..232d0f272 100644 --- a/cedar-lean/Cedar/Validation/Types.lean +++ b/cedar-lean/Cedar/Validation/Types.lean @@ -64,6 +64,7 @@ abbrev RecordType := Map Attr QualifiedType structure EntitySchemaEntry where ancestors : Cedar.Data.Set EntityType attrs : RecordType + tags : Option CedarType abbrev EntitySchema := Map EntityType EntitySchemaEntry @@ -73,6 +74,9 @@ def EntitySchema.contains (ets : EntitySchema) (ety : EntityType) : Bool := def EntitySchema.attrs? (ets : EntitySchema) (ety : EntityType) : Option RecordType := (ets.find? ety).map EntitySchemaEntry.attrs +def EntitySchema.tags? (ets : EntitySchema) (ety : EntityType) : Option (Option CedarType) := + (ets.find? ety).map EntitySchemaEntry.tags + def EntitySchema.descendentOf (ets : EntitySchema) (ety₁ ety₂ : EntityType) : Bool := if ety₁ = ety₂ then true diff --git a/cedar-lean/Cedar/Validation/Validator.lean b/cedar-lean/Cedar/Validation/Validator.lean index c56d4c02d..af33f7d10 100644 --- a/cedar-lean/Cedar/Validation/Validator.lean +++ b/cedar-lean/Cedar/Validation/Validator.lean @@ -142,6 +142,7 @@ def validationErrorToJson : ValidationError → Lean.Json | .typeError _ (.lubErr _ _) => "lubErr" | .typeError _ (.unexpectedType _) => "unexpectedType" | .typeError _ (.attrNotFound _ _) => "attrNotFound" + | .typeError _ (.tagNotFound _ _) => "tagNotFound" | .typeError _ (.unknownEntity _) => "unknownEntity" | .typeError _ (.extensionErr _) => "extensionErr" | .typeError _ .emptySetErr => "emptySetErr" diff --git a/cedar-lean/DiffTest/Main.lean b/cedar-lean/DiffTest/Main.lean index bd7ba6cce..f212afebc 100644 --- a/cedar-lean/DiffTest/Main.lean +++ b/cedar-lean/DiffTest/Main.lean @@ -20,7 +20,6 @@ import Cedar.Spec import Cedar.Validation import DiffTest.Util import DiffTest.Parser -import Cedar.Partial.Evaluator /-! This file defines the public interfaces for the Lean implementation. The input and output are stringified JSON objects. -/ @@ -86,34 +85,10 @@ def runAndTime (f : Unit -> α) : BaseIO (Timed α) := do toString (Lean.toJson result) @[export partialAuthorizeDRT] unsafe def partialAuthorizeDRT (req : String) : String := - let result : ParseResult (Timed Cedar.Partial.Response) := - match Lean.Json.parse req with - | .error e => .error s!"partialAuthorizeDRT: failed to parse input: {e}" - | .ok json => do - let request ← getJsonField json "request" >>= jsonToPartialRequest - let entities ← getJsonField json "entities" >>= jsonToEntities - let policies ← getJsonField json "policies" >>= jsonToPolicies - let result := runAndTime (λ () => Cedar.Partial.isAuthorized request entities policies) - .ok (unsafeBaseIO result) - toString (Lean.toJson result) + s!"partialAuthorizeDRT: not supported {req}" @[export partialEvaluateDRT] unsafe def partialEvaluateDRT (req : String) : String := - let result : ParseResult (Timed Bool) := - match Lean.Json.parse req with - | .error e => .error s!"partialEvaluateDRT: failed to parse input: {e}" - | .ok json => do - let expr ← getJsonField json "expr" >>= jsonToExpr - let request ← getJsonField json "request" >>= jsonToRequest - let entities ← getJsonField json "entities" >>= jsonToEntities - let expected ← getJsonField json "expected" >>= jsonToOptionalPartialValue - let result := runAndTime (λ () => Cedar.Partial.evaluate expr request entities ) - let { data, duration } := unsafeBaseIO result - let test_passed := match data, expected with - | .error _, .none => true - | .ok pv₁, .some pv₂ => pv₁ == pv₂ - | _, _ => false - .ok { data := test_passed , duration } - toString (Lean.toJson result) + s!"partialEvaluateDRT: not supported {req}" @[export validateEntitiesDRT] unsafe def validateEntitiesDRT (req : String) : String := let result : ParseResult (Timed EntityValidationResult) := @@ -122,6 +97,9 @@ def runAndTime (f : Unit -> α) : BaseIO (Timed α) := do | .ok json => do let schema ← getJsonField json "schema" >>= jsonToSchema let entities ← getJsonField json "entities" >>= jsonToEntities + let actionEntities := (schema.acts.mapOnValues actionSchemaEntryToEntityData) + let entities := Cedar.Data.Map.make (entities.kvs ++ actionEntities.kvs) + let schema := updateSchema schema actionEntities let result := runAndTime (λ () => Cedar.Validation.validateEntities schema entities ) .ok (unsafeBaseIO result) toString (Lean.toJson result) diff --git a/cedar-lean/DiffTest/Parser.lean b/cedar-lean/DiffTest/Parser.lean index 239313910..b06fc3206 100644 --- a/cedar-lean/DiffTest/Parser.lean +++ b/cedar-lean/DiffTest/Parser.lean @@ -26,7 +26,6 @@ import Cedar.Spec.Ext import Cedar.Validation import DiffTest.Util -import Cedar.Partial namespace DiffTest @@ -107,6 +106,8 @@ def jsonToBinaryOp (json : Lean.Json) : ParseResult BinaryOp := do match op with | "Eq" => .ok .eq | "In" => .ok .mem + | "HasTag" => .ok .hasTag + | "GetTag" => .ok .getTag | "Less" => .ok .less | "LessEq" => .ok .lessEq | "Add" => .ok .add @@ -214,71 +215,6 @@ partial def jsonToExpr (json : Lean.Json) : ParseResult Expr := do | "Unknown" => .error s!"expression contained unknown" | tag => .error s!"jsonToExpr: unknown tag {tag}" -/- -Defined as partial to avoid writing the proof of termination, which isn't required -since we don't prove correctness of the parser. --/ -partial def jsonToPartialValue (json : Lean.Json) : ParseResult Cedar.Partial.Value := do - let json ← getJsonField json "expr_kind" - let (tag, body) ← unpackJsonSum json - match tag with - | "Lit" => do - let prim ← jsonToPrim body - .ok (.value prim) - | "Var" => .error s!"vars are not supported in partial-value residuals" - | "And" => do - let lhs ← getJsonField body "left" >>= jsonToPartialValue - let rhs ← getJsonField body "right" >>= jsonToPartialValue - .ok (.residual (.and lhs rhs)) - | "Or" => do - let lhs ← getJsonField body "left" >>= jsonToPartialValue - let rhs ← getJsonField body "right" >>= jsonToPartialValue - .ok (.residual (.or lhs rhs)) - | "If" => do - let i ← getJsonField body "test_expr" >>= jsonToPartialValue - let t ← getJsonField body "then_expr" >>= jsonToPartialValue - let e ← getJsonField body "else_expr" >>= jsonToPartialValue - .ok (.residual (.ite i t e)) - | "UnaryApp" => do - let op ← getJsonField body "op" >>= jsonToUnaryOp - let arg ← getJsonField body "arg" >>= jsonToPartialValue - .ok (.residual (.unaryApp op arg)) - | "Like" => do - let pat ← getJsonField body "pattern" >>= jsonToPattern - let expr ← getJsonField body "expr" >>= jsonToPartialValue - .ok (.residual (.unaryApp (.like pat) expr)) - | "Is" => do - let ety ← getJsonField body "entity_type" >>= jsonToName - let expr ← getJsonField body "expr" >>= jsonToPartialValue - .ok (.residual (.unaryApp (.is ety) expr)) - | "BinaryApp" => do - let op ← getJsonField body "op" >>= jsonToBinaryOp - let arg1 ← getJsonField body "arg1" >>= jsonToPartialValue - let arg2 ← getJsonField body "arg2" >>= jsonToPartialValue - .ok (.residual (.binaryApp op arg1 arg2)) - | "GetAttr" => do - let e ← getJsonField body "expr" >>= jsonToPartialValue - let attr ← getJsonField body "attr" >>= jsonToString - .ok (.residual (.getAttr e attr)) - | "HasAttr" => do - let e ← getJsonField body "expr" >>= jsonToPartialValue - let attr ← getJsonField body "attr" >>= jsonToString - .ok (.residual (.hasAttr e attr)) - | "Record" => do - let kvs_json ← jsonObjToKVList body - let kvs ← mapMValues kvs_json jsonToPartialValue - .ok (.residual (.record kvs)) - | "Set" => do - let arr_json ← jsonToArray body - let arr ← List.mapM jsonToPartialValue arr_json.toList - .ok (.residual (.set arr)) - | "ExtensionFunctionApp" => do - let fn ← getJsonField body "fn_name" >>= jsonToExtFun - let args_json ← getJsonField body "args" >>= jsonToArray - let args ← List.mapM jsonToPartialValue args_json.toList - .ok (.residual (.call fn args)) - | "Unknown" => .error s!"expression contained unknown" - | tag => .error s!"jsonToExpr: unknown tag {tag}" def extExprToValue (xfn : ExtFun) (args : List Expr) : ParseResult Value := match xfn, args with @@ -309,31 +245,11 @@ partial def exprToValue : Expr → ParseResult Value def jsonToValue (json : Lean.Json) : ParseResult Value := jsonToExpr json >>= exprToValue - -def jsonToPartialValue' (json : Lean.Json) : ParseResult Cedar.Partial.Value := do - match json.getObjVal? "Value" with - | .ok v => Cedar.Partial.Value.value <$> (jsonToValue v) - | .error _ => match json.getObjVal? "Expr" with - | .ok e => jsonToPartialValue e - | .error _ => .error "Expected either `Expr` or `Value`" - -def jsonToOptionalPartialValue (json : Lean.Json) : ParseResult (Option Cedar.Partial.Value) := do - match json with - | Lean.Json.null => .ok none - | _ => do .ok (some (← jsonToPartialValue' json)) - def jsonToOptionalValue (json : Lean.Json) : ParseResult (Option Value) := match json with | Lean.Json.null => .ok .none | _ => do .ok (some (← jsonToValue json)) -def jsonToPartialContext (json : Lean.Json) : (ParseResult (Map Attr Cedar.Partial.Value)) := do - let value ← jsonToPartialValue json - match value with - | .value (.record m) => .ok (m.mapOnValues Cedar.Partial.Value.value) - | .residual (.record kvs) => .ok (Cedar.Data.Map.make kvs) - |_ => .error ("jsonToPartialContext: context must be a record\n" ++ toString (repr value)) - def jsonToContext (json : Lean.Json) : ParseResult (Map Attr Value) := do let value ← jsonToValue json match value with @@ -341,18 +257,6 @@ def jsonToContext (json : Lean.Json) : ParseResult (Map Attr Value) := do | _ => .error ("jsonToContext: context must be a record\n" ++ toString (repr value)) -def jsonToPartialRequest (json : Lean.Json) : ParseResult Cedar.Partial.Request := do - let principal ← getJsonField json "principal" >>= (getJsonField · "Known") >>= (getJsonField · "euid") >>= jsonToEuid - let action ← getJsonField json "action" >>= (getJsonField · "Known") >>= (getJsonField · "euid") >>= jsonToEuid - let resource ← getJsonField json "resource" >>= (getJsonField · "Known") >>= (getJsonField · "euid") >>= jsonToEuid - let context ← getJsonField json "context" >>= jsonToPartialContext - .ok { - principal := .known principal, - action := .known action, - resource := .known resource, - context := context - } - /- The "Known" in this function refers to "known" vs. "unknown" entities. We only need to support the known case here because the Lean does not @@ -376,9 +280,15 @@ def jsonToEntityData (json : Lean.Json) : ParseResult EntityData := do let ancestors ← List.mapM jsonToEuid ancestorsArr.toList let attrsKVs ← getJsonField json "attrs" >>= jsonObjToKVList let attrs ← mapMValues attrsKVs jsonToValue + let tagsKVs ← -- the "tags" field may be absent + match getJsonField json "tags" with + | .ok kvs => jsonObjToKVList kvs + | .error _ => .ok [] + let tags ← mapMValues tagsKVs jsonToValue .ok { ancestors := Set.make ancestors, - attrs := Map.make attrs + attrs := Map.make attrs, + tags := Map.make tags } def jsonToEntities (json : Lean.Json) : ParseResult Entities := do @@ -513,6 +423,7 @@ def descendantsToAncestors [LT α] [DecidableEq α] [DecidableLT α] (descendant structure JsonEntitySchemaEntry where descendants : Cedar.Data.Set EntityType attrs : RecordType + tags : Option CedarType abbrev JsonEntitySchema := Map EntityType JsonEntitySchemaEntry @@ -532,7 +443,8 @@ def invertJsonEntitySchema (ets : JsonEntitySchema) : EntitySchema := (λ (k,v) => (k, { ancestors := ancestorMap.find! k, - attrs := v.attrs + attrs := v.attrs, + tags := v.tags })) ets) def invertJsonActionSchema (acts : JsonActionSchema) : ActionSchema := @@ -548,12 +460,13 @@ def invertJsonActionSchema (acts : JsonActionSchema) : ActionSchema := context := v.context })) acts) --- Add special "unspecified" entity type with no attributes or ancestors +-- Add special "unspecified" entity type with no attributes or ancestors or tags def addUnspecifiedEntityType (ets : EntitySchema) : EntitySchema := let unspecifiedEntry : EntitySchemaEntry := { ancestors := Set.empty attrs := Map.empty + tags := Option.none } Map.make (ets.toList ++ [({id := "", path := []}, unspecifiedEntry)]) @@ -602,9 +515,14 @@ partial def jsonToEntityTypeEntry (json : Lean.Json) : ParseResult JsonEntitySch let descendants_json ← getJsonField json "descendants" >>= jsonToArray let descendants ← List.mapM jsonToName descendants_json.toList let attrs ← getJsonField json "attributes" >>= (getJsonField · "attrs") >>= jsonToRecordType + let tags ← -- the "tags" field may be absent + match getJsonField json "tags" with + | .ok jty => (jsonToCedarType jty).map .some + | .error _ => .ok .none .ok { descendants := Set.make descendants, - attrs := attrs + attrs := attrs, + tags := tags } partial def jsonToActionSchemaEntry (json : Lean.Json) : ParseResult JsonActionSchemaEntry := do diff --git a/cedar-lean/README.md b/cedar-lean/README.md index 0fb609033..dbc83821e 100644 --- a/cedar-lean/README.md +++ b/cedar-lean/README.md @@ -16,6 +16,7 @@ To build code and proofs from the command line: ```shell cd cedar-lean +lake update lake build Cedar ``` @@ -34,14 +35,10 @@ lake exe Cli validate Cli/json-inputs/validate/example2a.json ## Updating the Lean toolchain -Cedar depends on [`std4`](https://github.com/leanprover/std4), and it is configured to use the same version of Lean as `std4`. - -Follow these instructions to update to the latest version of `std4` and Lean: +To change the version of Lean used, you will need to update two files: -```shell -curl https://raw.githubusercontent.com/leanprover/std4/main/lean-toolchain -o lean-toolchain -lake update -``` +* `lean-toolchain` controls the Lean version. You can find all available versions [here](https://github.com/leanprover/lean4/releases). +* `lakefile.lean` lists the project dependencies. Make sure that `batteries` and `doc-gen4` are pinned to commits that match the Lean version. ## Contributing diff --git a/cedar-lean/lake-manifest.json b/cedar-lean/lake-manifest.json deleted file mode 100644 index 2df29adc0..000000000 --- a/cedar-lean/lake-manifest.json +++ /dev/null @@ -1,15 +0,0 @@ -{"version": "1.1.0", - "packagesDir": ".lake/packages", - "packages": - [{"url": "https://github.com/leanprover-community/batteries", - "type": "git", - "subDir": null, - "scope": "", - "rev": "0f3e143dffdc3a591662f3401ce1d7a3405227c0", - "name": "batteries", - "manifestFile": "lake-manifest.json", - "inputRev": "v4.10.0", - "inherited": false, - "configFile": "lakefile.lean"}], - "name": "Cedar", - "lakeDir": ".lake"} diff --git a/cedar-lean/lakefile.lean b/cedar-lean/lakefile.lean index 78a2c8efd..4bdc7c329 100644 --- a/cedar-lean/lakefile.lean +++ b/cedar-lean/lakefile.lean @@ -18,9 +18,9 @@ import Lake open Lake DSL meta if get_config? env = some "dev" then -- dev is so not everyone has to build it -require «doc-gen4» from git "https://github.com/leanprover/doc-gen4" @ "c7f4ac84b973b6efd8f24ba2b006cad1b32c9c53" +require "leanprover" / "doc-gen4" @ git "v4.10.0" -require "leanprover-community" / "batteries" +require "leanprover-community" / "batteries" @ git "v4.10.0" package Cedar diff --git a/cedar-policy-generators/Cargo.toml b/cedar-policy-generators/Cargo.toml index 1ecd2dab9..9548fd9bc 100644 --- a/cedar-policy-generators/Cargo.toml +++ b/cedar-policy-generators/Cargo.toml @@ -12,7 +12,7 @@ clap = { version = "4.3.16", features = ["derive"] } highway = "0.8.1" serde = { version = "1.0", features = ["derive"] } serde_json = { version = "1.0" } -smol_str = { version = "0.2", features = ["serde", "arbitrary"] } +smol_str = { version = "0.3", features = ["serde", "arbitrary"] } rand = "0.8.5" anyhow = "1.0.72" nanoid = "0.4.0" diff --git a/cedar-policy-generators/src/expr.rs b/cedar-policy-generators/src/expr.rs index eb66b82bc..557601998 100644 --- a/cedar-policy-generators/src/expr.rs +++ b/cedar-policy-generators/src/expr.rs @@ -21,8 +21,8 @@ use crate::hierarchy::{ arbitrary_specified_uid, generate_uid_with_type, EntityUIDGenMode, Hierarchy, }; use crate::schema::{ - attr_names_from_ea, entity_type_name_to_schema_type, lookup_common_type, uid_for_action_name, - Schema, + attrs_from_attrs_or_context, entity_type_name_to_schema_type, lookup_common_type, + uid_for_action_name, Schema, }; use crate::settings::ABACSettings; use crate::size_hint_utils::{size_hint_for_choose, size_hint_for_range, size_hint_for_ratio}; @@ -555,7 +555,11 @@ impl<'a> ExprGenerator<'a> { .expect("Failed to select entity index."), ) .expect("Failed to select entity from map."); - let attr_names: Vec = attr_names_from_ea(&self.schema.schema, &entity_type.shape).collect(); + let attr_names: Vec<&SmolStr> = + attrs_from_attrs_or_context(&self.schema.schema, &entity_type.shape) + .attrs + .keys() + .collect::>(); let attr_name = SmolStr::clone(u.choose(&attr_names)?); Ok(ast::Expr::has_attr( self.generate_expr_for_schematype( @@ -1687,11 +1691,8 @@ impl<'a> ExprGenerator<'a> { let mut r = HashMap::new(); u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { let (attr_name, attr_ty) = self.schema.arbitrary_attr(u)?.clone(); - let attr_val = self.generate_attr_value_for_eatypeinternal( - &attr_ty, - max_depth - 1, - u, - )?; + let attr_val = + self.generate_attr_value_for_schematype(&attr_ty, max_depth - 1, u)?; r.insert(attr_name, attr_val); Ok(std::ops::ControlFlow::Continue(())) })?; @@ -1809,7 +1810,7 @@ impl<'a> ExprGenerator<'a> { // maybe add some "additional" attributes not mentioned in schema u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { let (attr_name, attr_ty) = self.schema.arbitrary_attr(u)?.clone(); - let attr_val = self.generate_attr_value_for_eatypeinternal( + let attr_val = self.generate_attr_value_for_schematype( &attr_ty, max_depth - 1, u, @@ -1952,7 +1953,7 @@ impl<'a> ExprGenerator<'a> { u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { let (attr_name, attr_ty) = self.schema.arbitrary_attr(u)?.clone(); let attr_val = - self.generate_value_for_eatypeinternal(&attr_ty, max_depth - 1, u)?; + self.generate_value_for_schematype(&attr_ty, max_depth - 1, u)?; r.insert(attr_name, attr_val); Ok(std::ops::ControlFlow::Continue(())) })?; @@ -2035,7 +2036,7 @@ impl<'a> ExprGenerator<'a> { u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { let (attr_name, attr_ty) = self.schema.arbitrary_attr(u)?.clone(); let attr_val = - self.generate_value_for_eatypeinternal(&attr_ty, max_depth - 1, u)?; + self.generate_value_for_schematype(&attr_ty, max_depth - 1, u)?; r.insert(attr_name, attr_val); Ok(std::ops::ControlFlow::Continue(())) })?; @@ -2085,73 +2086,6 @@ impl<'a> ExprGenerator<'a> { } } - /// generate an arbitrary [`ast::Value`] of the given [`json_schema::EntityAttributeTypeInternal`] - fn generate_value_for_eatypeinternal( - &self, - target_type: &json_schema::EntityAttributeTypeInternal, - max_depth: usize, - u: &mut Unstructured<'_>, - ) -> Result { - match target_type { - json_schema::EntityAttributeTypeInternal::Type(ty) => { - self.generate_value_for_schematype(ty, max_depth, u) - } - json_schema::EntityAttributeTypeInternal::EAMap { value_type } => { - if max_depth == 0 { - // no recursion allowed: just return empty-record - Ok(ast::Value::empty_record(None)) - } else { - let mut r = HashMap::new(); - // add an arbitrary number of attributes with the appropriate type - u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { - let attr_name: SmolStr = u.arbitrary()?; - let attr_val = - self.generate_value_for_schematype(&value_type, max_depth - 1, u)?; - r.insert(attr_name, attr_val); - Ok(std::ops::ControlFlow::Continue(())) - })?; - Ok(ast::Value::record(r, None)) - } - } - } - } - - /// get an [`AttrValue`] of the given [`json_schema::EntityAttributeTypeInternal`] - /// which conforms to this schema - /// - /// `max_depth`: maximum depth of the attribute value expression. - /// For instance, maximum depth of nested sets. Not to be confused with the - /// `depth` parameter to size_hint. - pub fn generate_attr_value_for_eatypeinternal( - &self, - target_type: &json_schema::EntityAttributeTypeInternal, - max_depth: usize, - u: &mut Unstructured<'_>, - ) -> Result { - match target_type { - json_schema::EntityAttributeTypeInternal::Type(ty) => { - self.generate_attr_value_for_schematype(ty, max_depth, u) - } - json_schema::EntityAttributeTypeInternal::EAMap { value_type } => { - if max_depth == 0 { - // no recursion allowed: just return empty-record - Ok(AttrValue::Record(HashMap::new())) - } else { - let mut r = HashMap::new(); - // add an arbitrary number of attributes with the appropriate type - u.arbitrary_loop(None, Some(self.settings.max_width as u32), |u| { - let attr_name: SmolStr = u.arbitrary()?; - let attr_val = - self.generate_attr_value_for_schematype(&value_type, max_depth - 1, u)?; - r.insert(attr_name, attr_val); - Ok(std::ops::ControlFlow::Continue(())) - })?; - Ok(AttrValue::Record(r)) - } - } - } - } - /// get a (fully general) arbitrary constant, as an expression. #[allow(dead_code)] pub fn generate_const_expr(&self, u: &mut Unstructured<'_>) -> Result { @@ -2320,7 +2254,7 @@ fn record_schematype_with_attr( json_schema::Type::Type(json_schema::TypeVariant::Record(json_schema::RecordType { attributes: [( attr_name, - json_schema::RecordAttributeType { + json_schema::TypeOfAttribute { ty: attr_type.into(), required: true, }, diff --git a/cedar-policy-generators/src/hierarchy.rs b/cedar-policy-generators/src/hierarchy.rs index 6851d10fb..4a60765db 100644 --- a/cedar-policy-generators/src/hierarchy.rs +++ b/cedar-policy-generators/src/hierarchy.rs @@ -17,7 +17,7 @@ use crate::abac::Type; use crate::collections::{HashMap, HashSet}; use crate::err::{while_doing, Error, Result}; -use crate::schema::{attrs_from_ea, Schema}; +use crate::schema::{attrs_from_attrs_or_context, Schema}; use crate::size_hint_utils::{size_hint_for_choose, size_hint_for_ratio}; use arbitrary::{Arbitrary, Unstructured}; use cedar_policy_core::ast::{self, Eid, Entity, EntityUID}; @@ -592,7 +592,7 @@ impl<'a, 'u> HierarchyGenerator<'a, 'u> { let Some(entitytypes_by_type) = &entitytypes_by_type else { unreachable!("in schema-based mode, this should always be Some") }; - let attributes = attrs_from_ea( + let attributes = attrs_from_attrs_or_context( &schema.schema, &entitytypes_by_type .get(name) @@ -636,7 +636,7 @@ impl<'a, 'u> HierarchyGenerator<'a, 'u> { if ty.required || self.u.ratio::(1, 2)? { let attr_val = schema .exprgenerator(Some(&hierarchy_no_attrs)) - .generate_attr_value_for_eatypeinternal( + .generate_attr_value_for_schematype( &ty.ty, schema.settings.max_depth, self.u, @@ -654,7 +654,7 @@ impl<'a, 'u> HierarchyGenerator<'a, 'u> { // create the actual ast::Entity object let entity = ast::Entity::new( uid.clone(), - attrs.into_iter().collect(), + attrs.into_iter(), parents.into_iter().collect(), &self.extensions, ) diff --git a/cedar-policy-generators/src/schema.rs b/cedar-policy-generators/src/schema.rs index 1c429e80b..0ea6e133f 100644 --- a/cedar-policy-generators/src/schema.rs +++ b/cedar-policy-generators/src/schema.rs @@ -67,31 +67,30 @@ pub struct Schema { /// list of entity types that occur as a valid resource for at least one /// action in the `schema` pub resource_types: Vec, - /// list of (attribute, attribute type) pairs that occur in the `schema` - attributes: Vec<( - SmolStr, - json_schema::EntityAttributeTypeInternal, - )>, + /// list of (attribute, type) pairs that occur in the `schema` + attributes: Vec<(SmolStr, json_schema::Type)>, /// map from type to (entity type, attribute name) pairs indicating - /// attributes in the `schema` that have that type + /// attributes in the `schema` that have that type. + /// note that we can't make a similar map for json_schema::Type because it + /// isn't Hash or Ord attributes_by_type: HashMap>, } -/// internal helper function, basically `impl Arbitrary for RecordOrContextAttributes` -fn arbitrary_rca>( +/// internal helper function, basically `impl Arbitrary for AttributesOrContext` +fn arbitrary_attrspec>( settings: &ABACSettings, entity_types: &[ast::EntityType], u: &mut Unstructured<'_>, -) -> Result> { +) -> Result> { let attr_names: Vec = u .arbitrary() .map_err(|e| while_doing("generating attribute names for an attrspec".into(), e))?; - Ok(json_schema::RecordOrContextAttributes(json_schema::Type::Type( + Ok(json_schema::AttributesOrContext(json_schema::Type::Type( json_schema::TypeVariant::Record(json_schema::RecordType { attributes: attr_names .into_iter() .map(|attr| { - let mut ty = arbitrary_recordattributetype_with_bounded_depth::( + let mut ty = arbitrary_typeofattribute_with_bounded_depth::( settings, entity_types, settings.max_depth, @@ -100,7 +99,7 @@ fn arbitrary_rca>( if !settings.enable_extensions { // can't have extension types. regenerate until morale improves while ty.ty.is_extension().expect("DRT does not generate schema type using type defs, so `is_extension` should be `Some`") { - ty = arbitrary_recordattributetype_with_bounded_depth::( + ty = arbitrary_typeofattribute_with_bounded_depth::( settings, entity_types, settings.max_depth, @@ -119,32 +118,19 @@ fn arbitrary_rca>( }), ))) } -/// size hint for [`arbitrary_rca()`] -fn arbitrary_rca_size_hint(depth: usize) -> (usize, Option) { +/// size hint for arbitrary_attrspec +fn arbitrary_attrspec_size_hint(depth: usize) -> (usize, Option) { arbitrary::size_hint::recursion_guard(depth, |depth| { arbitrary::size_hint::and_all(&[ as Arbitrary>::size_hint(depth), - arbitrary_recordattributetype_size_hint(depth), + arbitrary_typeofattribute_size_hint(depth), ::size_hint(depth), ]) }) } -/// internal helper function, basically `impl Arbitrary for EntityAttributes` -fn arbitrary_entityattributes>( - settings: &ABACSettings, - entity_types: &[ast::EntityType], - u: &mut Unstructured<'_>, -) -> Result> { - // RFC 68 is not yet fully supported. - // Currently, we never generate `EAMap`s in this function. - Ok(json_schema::EntityAttributes::RecordAttributes( - arbitrary_rca(settings, entity_types, u)?, - )) -} - /// internal helper function, an alternative to the `Arbitrary` impl for -/// [`json_schema::RecordAttributeType`] that implements a bounded maximum depth. +/// `TypeOfAttribute` that implements a bounded maximum depth. /// For instance, if `max_depth` is 3, then Set types (or Record types) /// won't be nested more than 3 deep. /// @@ -155,19 +141,19 @@ fn arbitrary_entityattributes>( /// settings.enable_additional_attributes; it always behaves as if that setting /// is `true` (ie, it may generate `additional_attributes` as either `true` or /// `false`). -fn arbitrary_recordattributetype_with_bounded_depth>( +fn arbitrary_typeofattribute_with_bounded_depth>( settings: &ABACSettings, entity_types: &[ast::EntityType], max_depth: usize, u: &mut Unstructured<'_>, -) -> Result> { - Ok(json_schema::RecordAttributeType { +) -> Result> { + Ok(json_schema::TypeOfAttribute { ty: arbitrary_schematype_with_bounded_depth::(settings, entity_types, max_depth, u)?, required: u.arbitrary()?, }) } -/// size hint for [`arbitrary_recordattributetype_with_bounded_depth()`] -fn arbitrary_recordattributetype_size_hint(depth: usize) -> (usize, Option) { +/// size hint for arbitrary_typeofattribute_with_bounded_depth +fn arbitrary_typeofattribute_size_hint(depth: usize) -> (usize, Option) { arbitrary::size_hint::and( arbitrary_schematype_size_hint(depth), ::size_hint(depth), @@ -236,7 +222,7 @@ pub fn arbitrary_schematype_with_bounded_depth>( .map(|attr_name| { Ok(( attr_name.into(), - arbitrary_recordattributetype_with_bounded_depth( + arbitrary_typeofattribute_with_bounded_depth( settings, entity_types, max_depth - 1, @@ -349,134 +335,43 @@ fn schematype_to_type( } } -/// internal helper function, convert a -/// [`json_schema::EntityAttributeTypeInternal`] to a [`Type`] (loses some -/// information) -fn eatypeinternal_to_type( - schema: &json_schema::NamespaceDefinition, - eatypeinternal: &json_schema::EntityAttributeTypeInternal, -) -> Type { - match eatypeinternal { - json_schema::EntityAttributeTypeInternal::Type(ty) => schematype_to_type(schema, ty), - json_schema::EntityAttributeTypeInternal::EAMap { .. } => Type::record(), // For these purposes, EAMaps are just records, as runtime values of type EAMap are valid runtime values of type Record - } -} - /// Get an arbitrary namespace for a schema. The namespace may be absent. fn arbitrary_namespace(u: &mut Unstructured<'_>) -> Result> { u.arbitrary() .map_err(|e| while_doing("generating namespace".into(), e)) } -/// Information about record or context attributes -pub(crate) struct RecordOrContextAttributes<'a> { +/// Information about attributes from the schema +pub(crate) struct Attributes<'a> { /// the actual attributes - pub attrs: &'a BTreeMap>, + pub attrs: &'a BTreeMap>, /// whether `additional_attributes` is set pub additional_attrs: bool, } -/// Information about entity attributes -pub(crate) struct EntityAttributes { - /// the actual attributes - pub attrs: BTreeMap>, - /// whether `additional_attributes` is set - pub additional_attrs: bool, -} - -/// Given a [`json_schema::RecordOrContextAttributes`], get the -/// [`RecordOrContextAttributes`] describing it -pub(crate) fn attrs_from_rca<'a>( +/// Given a [`json_schema::AttributesOrContext`], get the actual attributes map +/// from it, and whether it has `additional_attributes` set +pub(crate) fn attrs_from_attrs_or_context<'a>( schema: &'a json_schema::NamespaceDefinition, - rca: &'a json_schema::RecordOrContextAttributes, -) -> RecordOrContextAttributes<'a> { - match &rca.0 { + attrsorctx: &'a json_schema::AttributesOrContext, +) -> Attributes<'a> { + match &attrsorctx.0 { json_schema::Type::CommonTypeRef { type_name } => match lookup_common_type(schema, type_name).unwrap_or_else(|| panic!("reference to undefined common type: {type_name}")) { json_schema::Type::CommonTypeRef { .. } => panic!("common type `{type_name}` refers to another common type, which is not allowed as of this writing?"), - json_schema::Type::Type(json_schema::TypeVariant::Record(json_schema::RecordType { attributes, additional_attributes })) => RecordOrContextAttributes { attrs: attributes, additional_attrs: *additional_attributes }, + json_schema::Type::Type(json_schema::TypeVariant::Record(json_schema::RecordType { attributes, additional_attributes })) => Attributes { attrs: attributes, additional_attrs: *additional_attributes }, json_schema::Type::Type(ty) => panic!("expected attributes or context to be a record, got {ty:?}"), } - json_schema::Type::Type(json_schema::TypeVariant::Record(json_schema::RecordType { attributes, additional_attributes })) => RecordOrContextAttributes { attrs: attributes, additional_attrs: *additional_attributes }, + json_schema::Type::Type(json_schema::TypeVariant::Record(json_schema::RecordType { attributes, additional_attributes })) => Attributes { attrs: attributes, additional_attrs: *additional_attributes }, json_schema::Type::Type(ty) => panic!("expected attributes or context to be a record, got {ty:?}"), } } -/// Given a [`json_schema::EntityAttributes`], get the [`EntityAttributes`] -/// describing it -pub(crate) fn attrs_from_ea( - schema: &json_schema::NamespaceDefinition, - ea: &json_schema::EntityAttributes, -) -> EntityAttributes { - match ea { - json_schema::EntityAttributes::RecordAttributes(rca) => { - let RecordOrContextAttributes { - attrs, - additional_attrs, - } = attrs_from_rca(schema, rca); - EntityAttributes { - attrs: attrs - .iter() - .map(|(k, v)| { - ( - k.clone(), - json_schema::EntityAttributeType { - ty: json_schema::EntityAttributeTypeInternal::Type(v.ty.clone()), - required: v.required, - }, - ) - }) - .collect(), - additional_attrs, - } - } - json_schema::EntityAttributes::EntityAttributes( - json_schema::EntityAttributesInternal { - attrs: - json_schema::RecordType { - attributes, - additional_attributes, - }, - .. - }, - ) => EntityAttributes { - attrs: attributes - .iter() - .map(|(k, v)| (k.clone(), v.clone())) - .collect(), - additional_attrs: *additional_attributes, - }, - } -} - -/// Given a [`json_schema::EntityAttributes`], get just the attribute names in it -pub(crate) fn attr_names_from_ea<'a>( - schema: &'a json_schema::NamespaceDefinition, - ea: &'a json_schema::EntityAttributes, -) -> Box + 'a> { - match ea { - json_schema::EntityAttributes::RecordAttributes(rca) => { - let attrs = attrs_from_rca(schema, rca); - Box::new(attrs.attrs.keys().cloned()) - } - json_schema::EntityAttributes::EntityAttributes(rty) => { - Box::new(rty.attrs.attributes.keys().cloned()) - } - } -} - /// Given a [`json_schema::Type`], return all (attribute, type) pairs that occur /// inside it fn attrs_in_schematype( schema: &json_schema::NamespaceDefinition, schematype: &json_schema::Type, -) -> Box< - dyn Iterator< - Item = ( - SmolStr, - json_schema::EntityAttributeTypeInternal, - ), - >, -> { +) -> Box)>> { match schematype { json_schema::Type::Type(variant) => match variant { json_schema::TypeVariant::Boolean => Box::new(std::iter::empty()), @@ -502,16 +397,11 @@ fn attrs_in_schematype( json_schema::TypeVariant::Record(json_schema::RecordType { attributes, .. }) => { let toplevel = attributes .iter() - .map(|(k, v)| { - ( - k.clone(), - json_schema::EntityAttributeTypeInternal::Type(v.ty.clone()), - ) - }) + .map(|(k, v)| (k.clone(), v.ty.clone())) .collect::>(); let recursed = toplevel .iter() - .flat_map(|(_, v)| attrs_in_eatypeinternal(schema, v)) + .flat_map(|(_, v)| attrs_in_schematype(schema, v)) .collect::>(); Box::new(toplevel.into_iter().chain(recursed)) } @@ -524,65 +414,6 @@ fn attrs_in_schematype( } } -/// Given a [`json_schema::EntityType`], return all (attribute, -/// type) pairs that occur inside it -fn attrs_in_etype( - schema: &json_schema::NamespaceDefinition, - etype: &json_schema::EntityType, -) -> Box< - dyn Iterator< - Item = ( - SmolStr, - json_schema::EntityAttributeTypeInternal, - ), - >, -> { - match &etype.shape { - json_schema::EntityAttributes::RecordAttributes( - json_schema::RecordOrContextAttributes(ty), - ) => attrs_in_schematype(schema, ty), - json_schema::EntityAttributes::EntityAttributes( - json_schema::EntityAttributesInternal { - attrs: json_schema::RecordType { attributes, .. }, - .. - }, - ) => { - let toplevel = attributes - .iter() - .map(|(k, v)| (k.clone(), v.ty.clone())) - .collect::>(); - let recursed = toplevel - .iter() - .flat_map(|(_, v)| attrs_in_eatypeinternal(schema, v)) - .collect::>(); - Box::new(toplevel.into_iter().chain(recursed)) - } - } -} - -/// Given a [`json_schema::EntityAttributeTypeInternal`], return all -/// (attribute, type) pairs that occur inside it -fn attrs_in_eatypeinternal( - schema: &json_schema::NamespaceDefinition, - eatypeinternal: &json_schema::EntityAttributeTypeInternal, -) -> Box< - dyn Iterator< - Item = ( - SmolStr, - json_schema::EntityAttributeTypeInternal, - ), - >, -> { - match eatypeinternal { - json_schema::EntityAttributeTypeInternal::Type(ty) => attrs_in_schematype(schema, ty), - json_schema::EntityAttributeTypeInternal::EAMap { value_type } => { - // we can't return any attributes from the EAMap itself because we - // are not guaranteed that any particular attribute names exist - attrs_in_schematype(schema, value_type) - } - } -} - /// Build `attributes_by_type` from other components of `Schema` fn build_attributes_by_type<'a>( schema: &json_schema::NamespaceDefinition, @@ -599,20 +430,16 @@ fn build_attributes_by_type<'a>( .map(|(name, et)| { ( ast::EntityType::from(ast::Name::from(name.clone())).qualify_with(namespace), - attrs_from_ea(schema, &et.shape), + attrs_from_attrs_or_context(schema, &et.shape), ) }) .flat_map(|(tyname, attributes)| { - attributes - .attrs - .iter() - .map(move |(attr_name, ty)| { - ( - eatypeinternal_to_type(schema, &ty.ty), - (tyname.clone(), attr_name.clone()), - ) - }) - .collect::>() + attributes.attrs.iter().map(move |(attr_name, ty)| { + ( + schematype_to_type(schema, &ty.ty), + (tyname.clone(), attr_name.clone()), + ) + }) }); let mut hm: HashMap> = HashMap::new(); for (ty, pair) in triples { @@ -708,7 +535,7 @@ impl Bindings { .map(|(attr, attr_ty)| { Ok(( attr.to_owned(), - json_schema::RecordAttributeType { + json_schema::TypeOfAttribute { ty: self.rewrite_type(u, &attr_ty.ty)?, required: attr_ty.required.to_owned(), }, @@ -729,98 +556,28 @@ impl Bindings { u: &mut Unstructured<'_>, et: &json_schema::EntityType, ) -> Result> { + let ty = &et.shape.0; Ok(json_schema::EntityType { member_of_types: et.member_of_types.clone(), - shape: self.rewrite_entity_attributes(u, &et.shape)?, + shape: json_schema::AttributesOrContext(self.rewrite_record_type(u, ty)?), + tags: None, }) } - /// Replace attribute types in a [`json_schema::EntityAttributes`] with common types - fn rewrite_entity_attributes( - &self, - u: &mut Unstructured<'_>, - ea: &json_schema::EntityAttributes, - ) -> Result> { - match ea { - json_schema::EntityAttributes::RecordAttributes(attrs) => Ok( - json_schema::EntityAttributes::RecordAttributes(self.rewrite_rca(u, attrs)?), - ), - json_schema::EntityAttributes::EntityAttributes(attrs) => Ok( - json_schema::EntityAttributes::from(self.rewrite_record_type(u, &attrs.attrs)?), - ), - } - } - - /// Replace attribute types in a [`json_schema::RecordOrContextAttributes`] with common types - fn rewrite_rca( - &self, - u: &mut Unstructured<'_>, - rca: &json_schema::RecordOrContextAttributes, - ) -> Result> { - Ok(json_schema::RecordOrContextAttributes( - self.rewrite_or_replace_type(u, &rca.0)?, - )) - } - + /// Replace attribute types in a record type with common types fn rewrite_record_type( - &self, - u: &mut Unstructured<'_>, - rty: &json_schema::RecordType>, - ) -> Result>> { - Ok(json_schema::RecordType { - attributes: rty - .attributes - .iter() - .map(|(k, v)| Ok((k.clone(), self.rewrite_eatype(u, v)?))) - .collect::>()?, - additional_attributes: rty.additional_attributes, - }) - } - - fn rewrite_eatype( - &self, - u: &mut Unstructured<'_>, - eatype: &json_schema::EntityAttributeType, - ) -> Result> { - Ok(json_schema::EntityAttributeType { - ty: self.rewrite_eatypeinternal(u, &eatype.ty)?, - required: eatype.required, - }) - } - - fn rewrite_eatypeinternal( - &self, - u: &mut Unstructured<'_>, - eatypeinternal: &json_schema::EntityAttributeTypeInternal, - ) -> Result> { - match eatypeinternal { - json_schema::EntityAttributeTypeInternal::Type(ty) => { - Ok(json_schema::EntityAttributeTypeInternal::Type( - self.rewrite_or_replace_type(u, ty)?, - )) - } - json_schema::EntityAttributeTypeInternal::EAMap { value_type } => { - Ok(json_schema::EntityAttributeTypeInternal::EAMap { - value_type: self.rewrite_or_replace_type(u, value_type)?, - }) - } - } - } - - /// Replace the type with a common-type reference, or rewrite the type to - /// possibly replace subcomponents of the type with common-type references - fn rewrite_or_replace_type( &self, u: &mut Unstructured<'_>, ty: &json_schema::Type, ) -> Result> { - if let Some(ids) = self.bindings.get(ty) { - Ok(json_schema::Type::CommonTypeRef { + let new_ty = if let Some(ids) = self.bindings.get(ty) { + json_schema::Type::CommonTypeRef { type_name: ast::Name::unqualified_name(u.choose(ids)?.clone().into()).into(), - }) + } } else { - self.rewrite_type(u, ty) - } + self.rewrite_type(u, ty)? + }; + Ok(new_ty) } // Generate common types based on the bindings @@ -897,9 +654,7 @@ impl Schema { ) -> Result> { let mut bindings = Bindings::new(); for (_, ty) in &self.attributes { - if let json_schema::EntityAttributeTypeInternal::Type(ty) = ty { - bind_type(ty, u, &mut bindings)?; - } + bind_type(ty, u, &mut bindings)?; } let common_types = bindings.to_common_types(u)?; @@ -925,8 +680,8 @@ impl Schema { Some(applies) => Some(json_schema::ApplySpec { resource_types: applies.resource_types.clone(), principal_types: applies.principal_types.clone(), - context: json_schema::RecordOrContextAttributes( - bindings.rewrite_or_replace_type(u, &applies.context.0)?, + context: json_schema::AttributesOrContext( + bindings.rewrite_record_type(u, &applies.context.0)?, ), }), None => None, @@ -998,12 +753,13 @@ impl Schema { } } let mut attributes = Vec::new(); - for schematype in nsdef.common_types.values() { + for schematype in nsdef + .common_types + .values() + .chain(nsdef.entity_types.values().map(|etype| &etype.shape.0)) + { attributes.extend(attrs_in_schematype(&nsdef, schematype)); } - for etype in nsdef.entity_types.values() { - attributes.extend(attrs_in_etype(&nsdef, etype)); - } let attributes_by_type = build_attributes_by_type(&nsdef, &nsdef.entity_types, namespace.as_ref()); Ok(Schema { @@ -1135,7 +891,8 @@ impl Schema { id.clone(), json_schema::EntityType { member_of_types: vec![], - shape: arbitrary_entityattributes(&settings, &entity_type_names, u)?, + shape: arbitrary_attrspec(&settings, &entity_type_names, u)?, + tags: None, }, )) }) @@ -1228,7 +985,7 @@ impl Schema { Some(json_schema::ApplySpec { resource_types: picked_resource_types, principal_types: picked_principal_types, - context: arbitrary_rca(&settings, &entity_type_names, u)?, + context: arbitrary_attrspec(&settings, &entity_type_names, u)?, }) }, member_of: if settings.enable_action_groups_and_attrs { @@ -1268,33 +1025,18 @@ impl Schema { entity_types: entity_types.into_iter().collect(), actions: actions.into_iter().collect(), }; - let entity_attributes = nsdef - .entity_types - .values() - .map(|et| attrs_from_ea(&nsdef, &et.shape)) - .flat_map(|attrs| { - attrs.attrs.into_iter().map(|(s, ty)| { - ( - s.parse().expect("attribute names should be valid Ids"), - ty.ty, - ) - }) - }); - let context_attributes = nsdef - .actions - .iter() - .filter_map(|(_, action)| action.applies_to.as_ref()) - .map(|a| attrs_from_rca(&nsdef, &a.context)) - .flat_map(|attrs| { - attrs.attrs.into_iter().map(|(s, ty)| { + let attrsorcontexts /* : impl Iterator */ = nsdef.entity_types.values().map(|et| attrs_from_attrs_or_context(&nsdef, &et.shape)) + .chain(nsdef.actions.iter().filter_map(|(_, action)| action.applies_to.as_ref()).map(|a| attrs_from_attrs_or_context(&nsdef, &a.context))); + let attributes: Vec<(SmolStr, json_schema::Type<_>)> = attrsorcontexts + .flat_map(|attributes| { + attributes.attrs.iter().map(|(s, ty)| { ( s.parse().expect("attribute names should be valid Ids"), - json_schema::EntityAttributeTypeInternal::Type(ty.ty.clone()), + ty.ty.clone(), ) }) - }); - let attributes: Vec<(SmolStr, json_schema::EntityAttributeTypeInternal<_>)> = - entity_attributes.chain(context_attributes).collect(); + }) + .collect(); let attributes_by_type = build_attributes_by_type(&nsdef, nsdef.entity_types.iter(), namespace.as_ref()); let actions_eids = nsdef @@ -1329,13 +1071,13 @@ impl Schema { pub fn arbitrary_size_hint(depth: usize) -> (usize, Option) { arbitrary::size_hint::and_all(&[ as Arbitrary>::size_hint(depth), - arbitrary_rca_size_hint(depth), // actually we do one of these per Name that was generated - size_hint_for_ratio(1, 2), // actually many of these calls + arbitrary_attrspec_size_hint(depth), // actually we do one of these per Name that was generated + size_hint_for_ratio(1, 2), // actually many of these calls as Arbitrary>::size_hint(depth), size_hint_for_ratio(1, 8), // actually many of these calls size_hint_for_ratio(1, 4), // zero to many of these calls size_hint_for_ratio(1, 2), // zero to many of these calls - arbitrary_rca_size_hint(depth), + arbitrary_attrspec_size_hint(depth), size_hint_for_ratio(1, 2), // actually many of these calls ::size_hint(depth), ]) @@ -1428,14 +1170,11 @@ impl Schema { .map(json_schema::Type::Type)) } - /// get an attribute name and its attribute type, from the schema + /// get an attribute name and its `json_schema::Type`, from the schema pub fn arbitrary_attr( &self, u: &mut Unstructured<'_>, - ) -> Result<&( - SmolStr, - json_schema::EntityAttributeTypeInternal, - )> { + ) -> Result<&(SmolStr, json_schema::Type)> { u.choose(&self.attributes) .map_err(|e| while_doing("getting arbitrary attr from schema".into(), e)) } @@ -1478,14 +1217,14 @@ impl Schema { ( ast::EntityType::from(ast::Name::from(name.clone())) .qualify_with(self.namespace()), - attrs_from_ea(&self.schema, &et.shape), + attrs_from_attrs_or_context(&self.schema, &et.shape), ) }) .flat_map(|(tyname, attributes)| { attributes .attrs - .into_iter() - .filter(|(_, ty)| matches!(&ty.ty, json_schema::EntityAttributeTypeInternal::Type(t) if t == &target_type)) + .iter() + .filter(|(_, ty)| ty.ty == target_type) .map(move |(attr_name, _)| (tyname.clone(), attr_name.clone())) }) .collect(); @@ -1700,7 +1439,7 @@ impl Schema { let mut attributes: Vec<_> = action .applies_to .as_ref() - .map(|a| attrs_from_rca(&self.schema, &a.context)) + .map(|a| attrs_from_attrs_or_context(&self.schema, &a.context)) .iter() .flat_map(|attributes| attributes.attrs.iter()) .collect(); @@ -1851,21 +1590,21 @@ fn downgrade_schematypevariant_to_raw( }) => json_schema::TypeVariant::Record(json_schema::RecordType { attributes: attributes .into_iter() - .map(|(k, v)| (k, downgrade_rat_to_raw(v))) + .map(|(k, v)| (k, downgrade_toa_to_raw(v))) .collect(), additional_attributes, }), } } -/// Utility function to "downgrade" a [`json_schema::RecordAttributeType`] with fully-qualified +/// Utility function to "downgrade" a [`TypeOfAttribute`] with fully-qualified /// names into one with [`RawName`]s. See notes on [`downgrade_frag_to_raw()`]. -fn downgrade_rat_to_raw( - rat: json_schema::RecordAttributeType, -) -> json_schema::RecordAttributeType { - json_schema::RecordAttributeType { - ty: downgrade_schematype_to_raw(rat.ty), - required: rat.required, +fn downgrade_toa_to_raw( + toa: json_schema::TypeOfAttribute, +) -> json_schema::TypeOfAttribute { + json_schema::TypeOfAttribute { + ty: downgrade_schematype_to_raw(toa.ty), + required: toa.required, } } @@ -1881,79 +1620,18 @@ fn downgrade_entitytype_to_raw( .into_iter() .map(RawName::from_name) .collect(), - shape: downgrade_ea_to_raw(entitytype.shape), + shape: downgrade_aoc_to_raw(entitytype.shape), + tags: entitytype.tags.map(downgrade_schematype_to_raw), } } -/// Utility function to "downgrade" a [`json_schema::RecordOrContextAttributes`] -/// with fully-qualified names into one with [`RawName`]s. See notes on -/// [`downgrade_frag_to_raw()`]. -fn downgrade_rca_to_raw( - rca: json_schema::RecordOrContextAttributes, -) -> json_schema::RecordOrContextAttributes { - json_schema::RecordOrContextAttributes(downgrade_schematype_to_raw(rca.0)) -} - -/// Utility function to "downgrade" a [`json_schema::EntityAttributes`] -/// with fully-qualified names into one with [`RawName`]s. See notes on +/// Utility function to "downgrade" a [`AttributesOrContext`] with +/// fully-qualified names into one with [`RawName`]s. See notes on /// [`downgrade_frag_to_raw()`]. -fn downgrade_ea_to_raw( - ea: json_schema::EntityAttributes, -) -> json_schema::EntityAttributes { - match ea { - json_schema::EntityAttributes::RecordAttributes(rca) => { - json_schema::EntityAttributes::RecordAttributes(downgrade_rca_to_raw(rca)) - } - json_schema::EntityAttributes::EntityAttributes( - json_schema::EntityAttributesInternal { attrs, .. }, - ) => downgrade_rty_to_raw(attrs).into(), - } -} - -/// Utility function to "downgrade" a [`json_schema::RecordType`] -/// with fully-qualified names into one with [`RawName`]s. -/// See notes on [`downgrade_frag_to_raw()`]. -fn downgrade_rty_to_raw( - rty: json_schema::RecordType>, -) -> json_schema::RecordType> { - json_schema::RecordType { - attributes: rty - .attributes - .into_iter() - .map(|(k, v)| (k, downgrade_eatype_to_raw(v))) - .collect(), - additional_attributes: rty.additional_attributes, - } -} - -/// Utility function to "downgrade" a [`json_schema::EntityAttributeType`] -/// with fully-qualified names into one with [`RawName`]s. -/// See notes on [`downgrade_frag_to_raw()`]. -fn downgrade_eatype_to_raw( - eatype: json_schema::EntityAttributeType, -) -> json_schema::EntityAttributeType { - json_schema::EntityAttributeType { - ty: downgrade_eatypeinternal_to_raw(eatype.ty), - required: eatype.required, - } -} - -/// Utility function to "downgrade" a [`json_schema::EntityAttributeTypeInternal`] -/// with fully-qualified names into one with [`RawName`]s. -/// See notes on [`downgrade_frag_to_raw()`]. -fn downgrade_eatypeinternal_to_raw( - eatypeinternal: json_schema::EntityAttributeTypeInternal, -) -> json_schema::EntityAttributeTypeInternal { - match eatypeinternal { - json_schema::EntityAttributeTypeInternal::Type(ty) => { - json_schema::EntityAttributeTypeInternal::Type(downgrade_schematype_to_raw(ty)) - } - json_schema::EntityAttributeTypeInternal::EAMap { value_type } => { - json_schema::EntityAttributeTypeInternal::EAMap { - value_type: downgrade_schematype_to_raw(value_type), - } - } - } +fn downgrade_aoc_to_raw( + aoc: json_schema::AttributesOrContext, +) -> json_schema::AttributesOrContext { + json_schema::AttributesOrContext(downgrade_schematype_to_raw(aoc.0)) } /// Utility function to "downgrade" an [`ActionType`] with fully-qualified names @@ -1986,7 +1664,7 @@ fn downgrade_applyspec_to_raw( .into_iter() .map(RawName::from_name) .collect(), - context: downgrade_rca_to_raw(applyspec.context), + context: downgrade_aoc_to_raw(applyspec.context), } }