section\<open>CryptoDB\<close>
theory CryptoDB
imports "../../TopoS_Impl"
begin

ML\<open>
case !Graphviz.open_viewer of
    OpenImmediately => Graphviz.open_viewer := AskTimeouted 3.0
  | AskTimeouted _ => ()
  | DoNothing => ()
\<close>

definition policy :: "string list_graph" where
  "policy \<equiv> \<lparr> nodesL = [
                        ''A'', ''A_encrypter'', ''A_channel'',
                        ''B'', ''B_encrypter'', ''B_channel'',
                        ''C'', ''C_encrypter'', ''C_channel_in'', ''C_channel_out'', ''C_decrypter'',
                        ''Adversary'',
                        ''CryptoDB''],
              edgesL = [
              (''A'', ''A_encrypter''), (''A_encrypter'', ''A_channel''), (''A_channel'', ''CryptoDB''),
              (''B'', ''B_encrypter''), (''B_encrypter'', ''B_channel''), (''B_channel'', ''CryptoDB''),
              (''C'', ''C_encrypter''), (''C_encrypter'', ''C_channel_out''), (''C_channel_out'', ''CryptoDB''),
              (''CryptoDB'', ''C_channel_in''), (''C_channel_in'', ''C_decrypter''), (''C_decrypter'', ''C'')
              ] \<rparr>"

context begin
  private definition "tainiting_host_attributes \<equiv> [
                           ''A'' \<mapsto> TaintsUntaints {''A''} {},
                           ''A_encrypter'' \<mapsto> TaintsUntaints {} {''A''},
                           ''A_channel'' \<mapsto> TaintsUntaints {} {},
                           ''B'' \<mapsto> TaintsUntaints {''B''} {},
                           ''B_encrypter'' \<mapsto> TaintsUntaints {} {''B''},
                           ''B_channel'' \<mapsto> TaintsUntaints {} {},
                           ''C'' \<mapsto> TaintsUntaints {''C''} {},
                           ''C_encrypter'' \<mapsto> TaintsUntaints {} {''C''},
                           ''C_decrypter'' \<mapsto> TaintsUntaints {''C''} {},
                           ''C_channel_out'' \<mapsto> TaintsUntaints {} {},
                           ''C_channel_in'' \<mapsto> TaintsUntaints {} {},
                           ''Adversary'' \<mapsto> TaintsUntaints {} {}
                           ]"
  private lemma "dom (tainiting_host_attributes) \<subseteq> set (nodesL policy)"
    by(simp add: tainiting_host_attributes_def policy_def)
  definition "Tainting_m \<equiv> new_configured_list_SecurityInvariant SINVAR_LIB_TaintingTrusted \<lparr>
        node_properties = tainiting_host_attributes \<rparr> ''user-data''"
end
lemma "wf_list_graph policy" by eval

ML_val\<open>
visualize_graph @{context} @{term "[]::string SecurityInvariant list"} @{term "policy"};
\<close>

context begin
  private definition "A_host_attributes \<equiv>
                [''A'' \<mapsto> Member,
                 ''A_encrypter'' \<mapsto> Member,
                 ''A_channel'' \<mapsto> Member
                 ]"
  private lemma "dom A_host_attributes \<subseteq> set (nodesL policy)"
    by(simp add: A_host_attributes_def policy_def)
  definition "SystemA_m \<equiv> new_configured_list_SecurityInvariant
                                  SINVAR_LIB_SubnetsInGW
                                    \<lparr> node_properties = A_host_attributes \<rparr> ''sys-A''"
end

context begin
  private definition "B_host_attributes \<equiv>
                [''B'' \<mapsto> Member,
                 ''B_encrypter'' \<mapsto> Member,
                 ''B_channel'' \<mapsto> Member
                 ]"
  private lemma "dom B_host_attributes \<subseteq> set (nodesL policy)"
    by(simp add: B_host_attributes_def policy_def)
  definition "SystemB_m \<equiv> new_configured_list_SecurityInvariant
                                  SINVAR_LIB_SubnetsInGW
                                    \<lparr> node_properties = B_host_attributes \<rparr> ''sys-B''"
end

context begin
  private definition "C_host_attributes \<equiv>
                [(''C_channel_in'', SystemBoundaryInput),
                 (''C_decrypter'', SystemComponent),
                 (''C'', SystemComponent),
                 (''C_encrypter'', SystemComponent),
                 (''C_channel_out'', SystemBoundaryOutput)
                 ]"
  private lemma "dom (map_of C_host_attributes) \<subseteq> set (nodesL policy)"
    by(simp add: C_host_attributes_def policy_def)
  definition "SystemC_m \<equiv> new_meta_system_boundary C_host_attributes ''sys-C''"
end

definition "invariants \<equiv> [Tainting_m, SystemA_m, SystemB_m] @ SystemC_m"

lemma "all_security_requirements_fulfilled invariants policy" by eval
ML\<open>
visualize_graph @{context} @{term "invariants"} @{term "policy"};
\<close>

value[code] "implc_get_offending_flows invariants (policy\<lparr> edgesL := edgesL policy\<rparr>)"
ML\<open>
visualize_graph @{context} @{term "invariants"} @{term "(policy\<lparr> edgesL := edgesL policy\<rparr>)"};
\<close>

definition make_policy :: "('a SecurityInvariant) list \<Rightarrow> 'a list \<Rightarrow> 'a list_graph" where
  "make_policy sinvars Vs \<equiv> generate_valid_topology sinvars \<lparr>nodesL = Vs, edgesL = List.product Vs Vs \<rparr>"

value[code] "make_policy invariants (nodesL policy)"

text\<open>visualizing all flows which may not end at the adversary. I.e. things which are prohibited.\<close>
ML_val\<open>
visualize_edges @{context} @{term "edgesL policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]",
     @{term "[(e1, e2) \<leftarrow>  List.product  (nodesL policy) (nodesL policy).
     ((e1,e2) \<notin> set (edgesL policy)) \<and> ((e1,e2) \<notin> set (edgesL (make_policy invariants (nodesL policy)))) \<and> (e2 = ''Adversary'') \<and> (e1 \<noteq> ''Adversary'')]"})] "";
\<close>

ML_val\<open>
visualize_edges @{context} @{term "edgesL policy"}
    [("edge [dir=\"arrow\", style=dashed, color=\"#FF8822\", constraint=false]",
     @{term "[e \<leftarrow> edgesL (make_policy invariants (nodesL policy)).
                e \<notin> set (edgesL policy)]"})] "";
\<close>

end


(* Title: IND_CCA2.thy
  Author: Andreas Lochbihler, ETH Zurich *)

theory IND_CCA2 imports
  CryptHOL.Computational_Model
  CryptHOL.Negligible
  CryptHOL.Environment_Functor
begin

locale pk_enc =
  fixes key_gen :: "security \<Rightarrow> ('ekey \<times> 'dkey) spmf" \<comment> \<open>probabilistic\<close>
  and encrypt :: "security \<Rightarrow> 'ekey \<Rightarrow> 'plain \<Rightarrow> 'cipher spmf"  \<comment> \<open>probabilistic\<close>
  and decrypt :: "security \<Rightarrow> 'dkey \<Rightarrow> 'cipher \<Rightarrow> 'plain option" \<comment> \<open>deterministic, but not used\<close>
  and valid_plain :: "security \<Rightarrow> 'plain \<Rightarrow> bool" \<comment> \<open>checks whether a plain text is valid, i.e., has the right format\<close>

subsection \<open>The IND-CCA2 game for public-key encryption\<close>

text \<open>
  We model an IND-CCA2 security game in the multi-user setting as described in
  \cite{BellareBoldyrevaMicali2000EUROCRYPT}.
\<close>

locale ind_cca2 = pk_enc +
  constrains key_gen :: "security \<Rightarrow> ('ekey \<times> 'dkey) spmf"
  and encrypt :: "security \<Rightarrow> 'ekey \<Rightarrow> 'plain \<Rightarrow> 'cipher spmf"
  and decrypt :: "security \<Rightarrow> 'dkey \<Rightarrow> 'cipher \<Rightarrow> 'plain option"
  and valid_plain :: "security \<Rightarrow> 'plain \<Rightarrow> bool"
begin

type_synonym ('ekey', 'dkey', 'cipher') state_oracle = "('ekey' \<times> 'dkey' \<times> 'cipher' list) option"

fun decrypt_oracle
  :: "security \<Rightarrow> ('ekey, 'dkey, 'cipher) state_oracle \<Rightarrow> 'cipher
  \<Rightarrow> ('plain option \<times> ('ekey, 'dkey, 'cipher) state_oracle) spmf"
where
  "decrypt_oracle \<eta> None cipher = return_spmf (None, None)"
| "decrypt_oracle \<eta> (Some (ekey, dkey, cstars)) cipher = return_spmf
   (if cipher \<in> set cstars then None else decrypt \<eta> dkey cipher, Some (ekey, dkey, cstars))"

fun ekey_oracle
  :: "security \<Rightarrow> ('ekey, 'dkey, 'cipher) state_oracle \<Rightarrow> unit \<Rightarrow> ('ekey \<times> ('ekey, 'dkey, 'cipher) state_oracle) spmf"
where
  "ekey_oracle \<eta> None _ = do {
      (ekey, dkey) \<leftarrow> key_gen \<eta>;
      return_spmf (ekey, Some (ekey, dkey, []))
    }"
| "ekey_oracle \<eta> (Some (ekey, rest)) _ = return_spmf (ekey, Some (ekey, rest))"

lemma ekey_oracle_conv:
  "ekey_oracle \<eta> \<sigma> x =
  (case \<sigma> of None \<Rightarrow> map_spmf (\<lambda>(ekey, dkey). (ekey, Some (ekey, dkey, []))) (key_gen \<eta>)
   | Some (ekey, rest) \<Rightarrow> return_spmf (ekey, Some (ekey, rest)))"
by(cases \<sigma>)(auto simp add: map_spmf_conv_bind_spmf split_def)

context notes bind_spmf_cong[fundef_cong] begin
function encrypt_oracle
  :: "bool \<Rightarrow> security \<Rightarrow> ('ekey, 'dkey, 'cipher) state_oracle \<Rightarrow> 'plain \<times> 'plain
  \<Rightarrow> ('cipher \<times> ('ekey, 'dkey, 'cipher) state_oracle) spmf"
where
  "encrypt_oracle b \<eta> None m01 = do { (_, \<sigma>) \<leftarrow> ekey_oracle \<eta> None (); encrypt_oracle b \<eta> \<sigma> m01 }"
| "encrypt_oracle b \<eta> (Some (ekey, dkey, cstars)) (m0, m1) =
  (if valid_plain \<eta> m0 \<and> valid_plain \<eta> m1 then do {
     let pb = (if b then m0 else m1);
     cstar \<leftarrow> encrypt \<eta> ekey pb;
     return_spmf (cstar, Some (ekey, dkey, cstar # cstars))
   } else return_pmf None)"
by pat_completeness auto
termination by(relation "Wellfounded.measure (\<lambda>(b, \<eta>, \<sigma>, m01). case \<sigma> of None \<Rightarrow> 1 | _ \<Rightarrow> 0)") auto
end

subsubsection \<open>Single-user setting\<close>

type_synonym ('plain', 'cipher') call\<^sub>1 = "unit + 'cipher' + 'plain' \<times> 'plain'"
type_synonym ('ekey', 'plain', 'cipher') ret\<^sub>1 = "'ekey' + 'plain' option + 'cipher'"

definition oracle\<^sub>1 :: "bool \<Rightarrow> security
  \<Rightarrow> (('ekey, 'dkey, 'cipher) state_oracle, ('plain, 'cipher) call\<^sub>1, ('ekey, 'plain, 'cipher) ret\<^sub>1) oracle'"
where "oracle\<^sub>1 b \<eta> = ekey_oracle \<eta> \<oplus>\<^sub>O (decrypt_oracle \<eta> \<oplus>\<^sub>O encrypt_oracle b \<eta>)"

lemma oracle\<^sub>1_simps [simp]:
  "oracle\<^sub>1 b \<eta> s (Inl x) = map_spmf (apfst Inl) (ekey_oracle \<eta> s x)"
  "oracle\<^sub>1 b \<eta> s (Inr (Inl y)) = map_spmf (apfst (Inr \<circ> Inl)) (decrypt_oracle \<eta> s y)"
  "oracle\<^sub>1 b \<eta> s (Inr (Inr z)) = map_spmf (apfst (Inr \<circ> Inr)) (encrypt_oracle b \<eta> s z)"
by(simp_all add: oracle\<^sub>1_def spmf.map_comp apfst_compose o_def)

type_synonym ('ekey', 'plain', 'cipher') adversary\<^sub>1' =
  "(bool, ('plain', 'cipher') call\<^sub>1, ('ekey', 'plain', 'cipher') ret\<^sub>1) gpv"
type_synonym ('ekey', 'plain', 'cipher') adversary\<^sub>1 =
  "security \<Rightarrow> ('ekey', 'plain', 'cipher') adversary\<^sub>1'"

definition ind_cca2\<^sub>1 :: "('ekey, 'plain, 'cipher) adversary\<^sub>1 \<Rightarrow> security \<Rightarrow> bool spmf"
where
  "ind_cca2\<^sub>1 \<A> \<eta> = TRY do {
    b \<leftarrow> coin_spmf;
    (guess, s) \<leftarrow> exec_gpv (oracle\<^sub>1 b \<eta>) (\<A> \<eta>) None;
    return_spmf (guess = b)
  } ELSE coin_spmf"

definition advantage\<^sub>1 :: "('ekey, 'plain, 'cipher) adversary\<^sub>1 \<Rightarrow> advantage"
where "advantage\<^sub>1 \<A> \<eta> = \<bar>spmf (ind_cca2\<^sub>1 \<A> \<eta>) True - 1/2\<bar>"

lemma advantage\<^sub>1_nonneg: "advantage\<^sub>1 \<A> \<eta> \<ge> 0" by(simp add: advantage\<^sub>1_def)

abbreviation secure_for\<^sub>1 :: "('ekey, 'plain, 'cipher) adversary\<^sub>1 \<Rightarrow> bool"
where "secure_for\<^sub>1 \<A> \<equiv> negligible (advantage\<^sub>1 \<A>)"

definition ibounded_by\<^sub>1' :: "('ekey, 'plain, 'cipher) adversary\<^sub>1' \<Rightarrow> nat \<Rightarrow> bool"
where "ibounded_by\<^sub>1' \<A> q = interaction_any_bounded_by \<A> q"

abbreviation ibounded_by\<^sub>1 :: "('ekey, 'plain, 'cipher) adversary\<^sub>1 \<Rightarrow> (security \<Rightarrow> nat) \<Rightarrow> bool"
where "ibounded_by\<^sub>1 \<equiv> rel_envir ibounded_by\<^sub>1'"

definition lossless\<^sub>1' :: "('ekey, 'plain, 'cipher) adversary\<^sub>1' \<Rightarrow> bool"
where "lossless\<^sub>1' \<A> = lossless_gpv \<I>_full \<A>"

abbreviation lossless\<^sub>1 :: "('ekey, 'plain, 'cipher) adversary\<^sub>1 \<Rightarrow> bool"
where "lossless\<^sub>1 \<equiv> pred_envir lossless\<^sub>1'"

lemma lossless_decrypt_oracle [simp]: "lossless_spmf (decrypt_oracle \<eta> \<sigma> cipher)"
by(cases "(\<eta>, \<sigma>, cipher)" rule: decrypt_oracle.cases) simp_all

lemma lossless_ekey_oracle [simp]:
  "lossless_spmf (ekey_oracle \<eta> \<sigma> x) \<longleftrightarrow> (\<sigma> = None \<longrightarrow> lossless_spmf (key_gen \<eta>))"
by(cases "(\<eta>, \<sigma>, x)" rule: ekey_oracle.cases)(auto)

lemma lossless_encrypt_oracle [simp]:
  "\<lbrakk> \<sigma> = None \<Longrightarrow> lossless_spmf (key_gen \<eta>);
    \<And>ekey m. valid_plain \<eta> m \<Longrightarrow> lossless_spmf (encrypt \<eta> ekey m) \<rbrakk>
  \<Longrightarrow> lossless_spmf (encrypt_oracle b \<eta> \<sigma> (m0, m1)) \<longleftrightarrow> valid_plain \<eta> m0 \<and> valid_plain \<eta> m1"
apply(cases "(b, \<eta>, \<sigma>, (m0, m1))" rule: encrypt_oracle.cases)
apply(auto simp add: split_beta dest: lossless_spmfD_set_spmf_nonempty split: if_split_asm)
done

subsubsection \<open>Multi-user setting\<close>

definition oracle\<^sub>n :: "bool \<Rightarrow> security
   \<Rightarrow> ('i \<Rightarrow> ('ekey, 'dkey, 'cipher) state_oracle, 'i \<times> ('plain, 'cipher) call\<^sub>1, ('ekey, 'plain, 'cipher) ret\<^sub>1) oracle'"
where "oracle\<^sub>n b \<eta> = family_oracle (\<lambda>_. oracle\<^sub>1 b \<eta>)"

lemma oracle\<^sub>n_apply [simp]:
  "oracle\<^sub>n b \<eta> s (i, x) = map_spmf (apsnd (fun_upd s i)) (oracle\<^sub>1 b \<eta> (s i) x)"
by(simp add: oracle\<^sub>n_def)

type_synonym ('i, 'ekey', 'plain', 'cipher') adversary\<^sub>n' =
  "(bool, 'i \<times> ('plain', 'cipher') call\<^sub>1, ('ekey', 'plain', 'cipher') ret\<^sub>1) gpv"
type_synonym ('i, 'ekey', 'plain', 'cipher') adversary\<^sub>n =
  "security \<Rightarrow> ('i, 'ekey', 'plain', 'cipher') adversary\<^sub>n'"

definition ind_cca2\<^sub>n :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n \<Rightarrow> security \<Rightarrow> bool spmf"
where
  "ind_cca2\<^sub>n \<A> \<eta> = TRY do {
    b \<leftarrow> coin_spmf;
    (guess, \<sigma>) \<leftarrow> exec_gpv (oracle\<^sub>n b \<eta>) (\<A> \<eta>) (\<lambda>_. None);
    return_spmf (guess = b)
  } ELSE coin_spmf"

definition advantage\<^sub>n :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n \<Rightarrow> advantage"
where "advantage\<^sub>n \<A> \<eta> = \<bar>spmf (ind_cca2\<^sub>n \<A> \<eta>) True - 1/2\<bar>"

lemma advantage\<^sub>n_nonneg: "advantage\<^sub>n \<A> \<eta> \<ge> 0" by(simp add: advantage\<^sub>n_def)

abbreviation secure_for\<^sub>n :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n \<Rightarrow> bool"
where "secure_for\<^sub>n \<A> \<equiv> negligible (advantage\<^sub>n \<A>)"

definition ibounded_by\<^sub>n' :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n' \<Rightarrow> nat \<Rightarrow> bool"
where "ibounded_by\<^sub>n' \<A> q = interaction_any_bounded_by \<A> q"

abbreviation ibounded_by\<^sub>n :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n \<Rightarrow> (security \<Rightarrow> nat) \<Rightarrow> bool"
where "ibounded_by\<^sub>n \<equiv> rel_envir ibounded_by\<^sub>n'"

definition lossless\<^sub>n' :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n' \<Rightarrow> bool"
where "lossless\<^sub>n' \<A> = lossless_gpv \<I>_full \<A>"

abbreviation lossless\<^sub>n :: "('i, 'ekey, 'plain, 'cipher) adversary\<^sub>n \<Rightarrow> bool"
where "lossless\<^sub>n \<equiv> pred_envir lossless\<^sub>n'"

definition cipher_queries :: "('i \<Rightarrow> ('ekey, 'dkey, 'cipher) state_oracle) \<Rightarrow> 'cipher set"
where "cipher_queries ose = (\<Union>(_, _, ciphers)\<in>ran ose. set ciphers)"

lemma cipher_queriesI:
  "\<lbrakk> ose n = Some (ek, dk, ciphers); x \<in> set ciphers \<rbrakk> \<Longrightarrow> x \<in> cipher_queries ose"
by(auto simp add: cipher_queries_def ran_def)

lemma cipher_queriesE:
  assumes "x \<in> cipher_queries ose"
  obtains (cipher_queries) n ek dk ciphers where "ose n = Some (ek, dk, ciphers)" "x \<in> set ciphers"
using assms by(auto simp add: cipher_queries_def ran_def)

lemma cipher_queries_updE:
  assumes "x \<in> cipher_queries (ose(n \<mapsto> (ek, dk, ciphers)))"
  obtains (old) "x \<in> cipher_queries ose" "x \<notin> set ciphers" | (new) "x \<in> set ciphers"
using assms by(cases "x \<in> set ciphers")(fastforce elim!: cipher_queriesE split: if_split_asm intro: cipher_queriesI)+

lemma cipher_queries_empty [simp]: "cipher_queries Map.empty = {}"
by(simp add: cipher_queries_def)

end

end


theory Refine_Intersection
imports Refine_Unions
begin

consts i_inter::"interface \<Rightarrow> interface \<Rightarrow> interface"
hide_const (open) Impl_Uv_Set.inter_rel

definition inter_rel_internal: "inter_rel AA BB = {((a, b), A \<inter> B)|a b A B. (a, A) \<in> AA \<and> (b, B) \<in> BB}"
lemma inter_rel_def: "\<langle>AA, BB\<rangle>inter_rel = {((a, b), A \<inter> B)|a b A B. (a, A) \<in> AA \<and> (b, B) \<in> BB}"
  by (auto simp: inter_rel_internal relAPP_def)
lemmas [autoref_rel_intf] = REL_INTFI[of inter_rel i_inter]

lemma inter_rel_br: "\<langle>(br a I), (br b J)\<rangle>inter_rel = br (\<lambda>(x, y). a x \<inter> b y) (\<lambda>x. I (fst x) \<and> J (snd x))"
  by (auto simp: inter_rel_def br_def)

definition mk_inter::"'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where [simp]: "mk_inter \<equiv> \<lambda>X Y. X \<inter> Y"

definition mk_inter_coll::"'a set \<Rightarrow> 'a set \<Rightarrow> 'a set"
where [simp]: "mk_inter_coll \<equiv> \<lambda>X Y. X \<inter> Y"

context includes autoref_syntax begin

lemma inter_plane_clw_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>xs sctni. map (\<lambda>x. (x, sctni)) xs, mk_inter_coll) \<in> clw_rel A \<rightarrow> B \<rightarrow> clw_rel (\<langle>A,B\<rangle>inter_rel)"
  using assms
  by (fastforce
      intro!: nres_relI RETURN_SPEC_refine brI
      dest!: brD
      elim!: single_valued_as_brE
      simp: RETURN_RES_refine_iff inter_rel_br Union_rel_br lw_rel_def)

lemma inter_plane_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>x sctn. (x, sctn), mk_inter) \<in> A \<rightarrow> B \<rightarrow> \<langle>A,B\<rangle>inter_rel"
  using assms
  by (fastforce
      intro!: nres_relI RETURN_SPEC_refine brI
      dest!: brD
      elim!: single_valued_as_brE
      simp: RETURN_RES_refine_iff inter_rel_br Union_rel_br lw_rel_def)

definition unintersect::"'a set \<Rightarrow> 'a set nres"
  where [refine_vcg_def]: "unintersect X = SPEC (\<lambda>R. X \<subseteq> R)"

definition unintersect_coll::"'a set \<Rightarrow> 'a set nres"
  where [refine_vcg_def]: "unintersect_coll X = SPEC (\<lambda>R. X \<subseteq> R)"

definition unintersect2::"'a set \<Rightarrow> 'a set nres"
  where [refine_vcg_def]: "unintersect2 X = SPEC (\<lambda>R. X \<subseteq> R)"

definition unintersect_coll2::"'a set \<Rightarrow> 'a set nres"
  where [refine_vcg_def]: "unintersect_coll2 X = SPEC (\<lambda>R. X \<subseteq> R)"

lemma unintersect_clw_impl[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>xs. RETURN ((map fst) xs), unintersect_coll) \<in> clw_rel (\<langle>A,B\<rangle>inter_rel) \<rightarrow> \<langle>clw_rel A\<rangle>nres_rel"
  using assms
  by (auto intro!: nres_relI RETURN_SPEC_refine elim!: single_valued_as_brE
      simp: unintersect_coll_def inter_rel_br Union_rel_br lw_rel_def)
    (auto simp: br_def)

lemma unintersect_impl[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>x. RETURN (fst x), unintersect) \<in> (\<langle>A,B\<rangle>inter_rel) \<rightarrow> \<langle>A\<rangle>nres_rel"
  using assms
  by (auto intro!: nres_relI RETURN_SPEC_refine elim!: single_valued_as_brE
      simp: unintersect_def inter_rel_br Union_rel_br lw_rel_def)
    (auto simp: br_def)

lemma unintersect_clw2_impl[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>xs. RETURN ((map snd) xs), unintersect_coll2) \<in> clw_rel (\<langle>A,B\<rangle>inter_rel) \<rightarrow> \<langle>clw_rel B\<rangle>nres_rel"
  using assms
  by (auto intro!: nres_relI RETURN_SPEC_refine elim!: single_valued_as_brE
      simp: unintersect_coll2_def inter_rel_br Union_rel_br lw_rel_def)
    (auto simp: br_def)

lemma unintersect2_impl[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued B"
  shows "(\<lambda>x. RETURN (snd x), unintersect2) \<in> (\<langle>A,B\<rangle>inter_rel) \<rightarrow> \<langle>B\<rangle>nres_rel"
  using assms
  by (auto intro!: nres_relI RETURN_SPEC_refine elim!: single_valued_as_brE
      simp: unintersect2_def inter_rel_br Union_rel_br lw_rel_def)
    (auto simp: br_def)

definition get_inter::"'a set \<Rightarrow> ('a set \<times> 'a set) nres"
  where [refine_vcg_def]: "get_inter X = SPEC (\<lambda>(Y, Z). X = Y \<inter> Z)"

lemma get_inter_autoref[autoref_rules]:
  "(\<lambda>x. RETURN x, get_inter) \<in> \<langle>X,S\<rangle>inter_rel \<rightarrow> \<langle>X \<times>\<^sub>r S\<rangle>nres_rel"
  by (force simp: get_inter_def inter_rel_def nres_rel_def intro!: RETURN_SPEC_refine)

definition split_by_inter::"'a set \<Rightarrow> ('a set \<times> 'a set) nres"
  where [refine_vcg_def]: "split_by_inter X = SPEC (\<lambda>(Y, YS). X = Y \<union> YS)"

context includes autoref_syntax begin
lemma split_by_inter_appr_plane_autoref[autoref_rules]:
  assumes "PREFER single_valued A"
  assumes "PREFER single_valued S"
  assumes "(xs, X) \<in> clw_rel (\<langle>A,S\<rangle>inter_rel)"
  shows
    "(let (a, b) = List.partition (\<lambda>(_, sctn). sctn = snd (hd xs)) xs in RETURN (a, b),
    split_by_inter $ X) \<in>
    \<langle>clw_rel (\<langle>A, S\<rangle>inter_rel) \<times>\<^sub>r clw_rel (\<langle>A, S\<rangle>inter_rel)\<rangle>nres_rel"
  using assms
  by (fastforce simp: Let_def split_by_inter_def split_beta'
      lw_rel_def Union_rel_br inter_rel_br ex_br_conj_iff Id_br[where 'a="'a sctn"]
      elim!: single_valued_as_brE
      intro!: nres_relI RETURN_SPEC_refine
      dest!: brD)

end

end


(* Strengthened observation setup, customized for post confidentiality *)
theory Post_Observation_Setup_ISSUER
  imports Post_Intro
begin

subsection \<open>Confidentiality for a secret issuer node\<close>

text \<open>\label{sec:post-issuer}
We verify that a group of users of a given node \<open>i\<close>
can learn nothing about the updates to the content of a post
\<open>PID\<close> located at that node beyond the existence of an update
unless one of them is the admin or the owner of \<open>PID\<close>,
or becomes friends with the owner,
or \<open>PID\<close> is marked as public. This is formulated as a BD Security
property and is proved by unwinding.

See \<^cite>\<open>"cosmedis-SandP2017"\<close> for more details.
\<close>

subsubsection \<open>Observation setup\<close>

(* *)
type_synonym obs = "act * out"

(* The observers are an arbitrary, but fixed set of users *)
locale Fixed_UIDs = fixes UIDs :: "userID set"
(* The secret is PID: *)
locale Fixed_PID = fixes PID :: "postID"

locale ObservationSetup_ISSUER = Fixed_UIDs + Fixed_PID
begin

(*  *)
fun \<gamma> :: "(state,act,out) trans \<Rightarrow> bool" where
"\<gamma> (Trans _ a _ _) \<longleftrightarrow>
   (\<exists> uid. userOfA a = Some uid \<and> uid \<in> UIDs)
   \<or>
   (\<exists>ca. a = COMact ca)
   \<or>
   (\<exists>uid p. a = Sact (sSys uid p))"

(* Note: the passwords don't really have to be purged (since identity theft is not
considered in the first place); however, purging passwords looks more sane. *)

(* Purging the password in starting actions: *)
fun sPurge :: "sActt \<Rightarrow> sActt" where
"sPurge (sSys uid pwd) = sSys uid emptyPass"

(* Purging communicating actions: user-password information is removed.
  Note: comReceivePost is not affected by the purging, in that post content
  is not removed; this only happens on the receiving end.
  (Also, nothing to purge in comSendPost either -- the output will be purged here, since
   only the output contains an actual post.)

  Note: server-password info is not purged --todo: discuss this.  *)
fun comPurge :: "comActt \<Rightarrow> comActt" where
 "comPurge (comSendServerReq uID p aID reqInfo) = comSendServerReq uID emptyPass aID reqInfo"
|"comPurge (comConnectClient uID p aID sp) = comConnectClient uID emptyPass aID sp"
|"comPurge (comConnectServer aID sp) = comConnectServer aID sp"
|"comPurge (comSendPost uID p aID pID) = comSendPost uID emptyPass aID pID"
|"comPurge (comSendCreateOFriend uID p aID uID') = comSendCreateOFriend uID emptyPass aID uID'"
|"comPurge (comSendDeleteOFriend uID p aID uID') = comSendDeleteOFriend uID emptyPass aID uID'"
|"comPurge ca = ca"

(* Purging outputs: post content for PID
  is removed from the post sending outputs
  (Again, server-password info is not purged.)   *)
fun outPurge :: "out \<Rightarrow> out" where
 "outPurge (O_sendPost (aID, sp, pID, pst, uID, vs)) =
  (let pst' = (if pID = PID then emptyPost else pst)
   in O_sendPost (aID, sp, pID, pst', uID, vs))"
|"outPurge ou = ou"

fun g :: "(state,act,out)trans \<Rightarrow> obs" where
 "g (Trans _ (Sact sa) ou _) = (Sact (sPurge sa), outPurge ou)"
|"g (Trans _ (COMact ca) ou _) = (COMact (comPurge ca), outPurge ou)"
|"g (Trans _ a ou _) = (a,ou)"

lemma comPurge_simps:
  "comPurge ca = comSendServerReq uID p aID reqInfo \<longleftrightarrow> (\<exists>p'. ca = comSendServerReq uID p' aID reqInfo \<and> p = emptyPass)"
  "comPurge ca = comReceiveClientReq aID reqInfo \<longleftrightarrow> ca = comReceiveClientReq aID reqInfo"
  "comPurge ca = comConnectClient uID p aID sp \<longleftrightarrow> (\<exists>p'. ca = comConnectClient uID p' aID sp \<and> p = emptyPass)"
  "comPurge ca = comConnectServer aID sp \<longleftrightarrow> ca = comConnectServer aID sp"
  "comPurge ca = comReceivePost aID sp nID nt uID v \<longleftrightarrow> ca = comReceivePost aID sp nID nt uID v"
  "comPurge ca = comSendPost uID p aID nID \<longleftrightarrow> (\<exists>p'. ca = comSendPost uID p' aID nID \<and> p = emptyPass)"
  "comPurge ca = comSendCreateOFriend uID p aID uID' \<longleftrightarrow> (\<exists>p'. ca = comSendCreateOFriend uID p' aID uID' \<and> p = emptyPass)"
  "comPurge ca = comReceiveCreateOFriend aID cp uID uID' \<longleftrightarrow> ca = comReceiveCreateOFriend aID cp uID uID'"
  "comPurge ca = comSendDeleteOFriend uID p aID uID' \<longleftrightarrow> (\<exists>p'. ca = comSendDeleteOFriend uID p' aID uID' \<and> p = emptyPass)"
  "comPurge ca = comReceiveDeleteOFriend aID cp uID uID' \<longleftrightarrow> ca = comReceiveDeleteOFriend aID cp uID uID'"
by (cases ca; auto)+

lemma outPurge_simps[simp]:
  "outPurge ou = outErr \<longleftrightarrow> ou = outErr"
  "outPurge ou = outOK \<longleftrightarrow> ou = outOK"
  "outPurge ou = O_sendServerReq ossr \<longleftrightarrow> ou = O_sendServerReq ossr"
  "outPurge ou = O_connectClient occ \<longleftrightarrow> ou = O_connectClient occ"
  "outPurge ou = O_sendPost (aid, sp, pid, pst', uid, vs) \<longleftrightarrow> (\<exists>pst.
     ou = O_sendPost (aid, sp, pid, pst, uid, vs) \<and>
     pst' = (if pid = PID then emptyPost else pst))"
  "outPurge ou = O_sendCreateOFriend oscf \<longleftrightarrow> ou = O_sendCreateOFriend oscf"
  "outPurge ou = O_sendDeleteOFriend osdf \<longleftrightarrow> ou = O_sendDeleteOFriend osdf"
by (cases ou; auto simp: ObservationSetup_ISSUER.outPurge.simps)+

lemma g_simps:
  "g (Trans s a ou s') = (COMact (comSendServerReq uID p aID reqInfo), O_sendServerReq ossr)
\<longleftrightarrow> (\<exists>p'. a = COMact (comSendServerReq uID p' aID reqInfo) \<and> p = emptyPass \<and> ou = O_sendServerReq ossr)"
  "g (Trans s a ou s') = (COMact (comReceiveClientReq aID reqInfo), outOK)
\<longleftrightarrow> a = COMact (comReceiveClientReq aID reqInfo) \<and> ou = outOK"
  "g (Trans s a ou s') = (COMact (comConnectClient uID p aID sp), O_connectClient occ)
\<longleftrightarrow> (\<exists>p'. a = COMact (comConnectClient uID p' aID sp) \<and> p = emptyPass \<and> ou = O_connectClient occ)"
  "g (Trans s a ou s') = (COMact (comConnectServer aID sp), outOK)
\<longleftrightarrow> a = COMact (comConnectServer aID sp) \<and> ou = outOK"
  "g (Trans s a ou s') = (COMact (comReceivePost aID sp nID nt uID v), outOK)
\<longleftrightarrow> a = COMact (comReceivePost aID sp nID nt uID v) \<and> ou = outOK"
  "g (Trans s a ou s') = (COMact (comSendPost uID p aID nID), O_sendPost (aid, sp, pid, pst', uid, vs))
\<longleftrightarrow> (\<exists>pst p'. a = COMact (comSendPost uID p' aID nID) \<and> p = emptyPass \<and> ou = O_sendPost (aid, sp, pid, pst, uid, vs) \<and> pst' = (if pid = PID then emptyPost else pst))"
  "g (Trans s a ou s') = (COMact (comSendCreateOFriend uID p aID uID'), O_sendCreateOFriend (aid, sp, uid, uid'))
\<longleftrightarrow> (\<exists>p'. a = (COMact (comSendCreateOFriend uID p' aID uID')) \<and> p = emptyPass \<and> ou = O_sendCreateOFriend (aid, sp, uid, uid'))"
  "g (Trans s a ou s') = (COMact (comReceiveCreateOFriend aID cp uID uID'), outOK)
\<longleftrightarrow> a = COMact (comReceiveCreateOFriend aID cp uID uID') \<and> ou = outOK"
  "g (Trans s a ou s') = (COMact (comSendDeleteOFriend uID p aID uID'), O_sendDeleteOFriend (aid, sp, uid, uid'))
\<longleftrightarrow> (\<exists>p'. a = COMact (comSendDeleteOFriend uID p' aID uID') \<and> p = emptyPass \<and> ou = O_sendDeleteOFriend (aid, sp, uid, uid'))"
  "g (Trans s a ou s') = (COMact (comReceiveDeleteOFriend aID cp uID uID'), outOK)
\<longleftrightarrow> a = COMact (comReceiveDeleteOFriend aID cp uID uID') \<and> ou = outOK"
by (cases a; auto simp: comPurge_simps)+

end

end