(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory UserOp_IF
imports Syscall_IF "Access.ADT_AC"
begin

context begin interpretation Arch . (*FIXME: arch_split*)

text \<open>
  This theory defines an enhanced @{term do_user_op} function for the
  automaton used for the information flow proofs. This enhanced model of
  user behaviour is a less abstract representation than the original one;
  eventually we should probably extend the original one to match up with
  this one and remove the duplication.
\<close>

definition ptable_lift_s where
  "ptable_lift_s s \<equiv>  ptable_lift (cur_thread s) s"

definition ptable_rights_s where
  "ptable_rights_s s \<equiv>  ptable_rights (cur_thread s) s"

(* FIXME: move to ADT_AI.thy *)
definition
  ptable_attrs :: "obj_ref \<Rightarrow> 'z state \<Rightarrow> word32 \<Rightarrow> vm_attributes" where
 "ptable_attrs tcb s \<equiv> \<lambda>addr.
  case_option {} (fst o snd o snd)
     (get_page_info (\<lambda>obj. get_arch_obj (kheap s obj))
        (get_pd_of_thread (kheap s) (arch_state s) tcb) addr)"

definition
  ptable_attrs_s :: "'z state \<Rightarrow> word32 \<Rightarrow> vm_attributes" where
 "ptable_attrs_s s \<equiv> ptable_attrs (cur_thread s) s"

definition ptable_xn_s where
  "ptable_xn_s s \<equiv>  \<lambda>addr. XNever \<in> ptable_attrs_s s addr"

definition getExMonitor :: "exclusive_monitors machine_monad" where
  "getExMonitor \<equiv> gets exclusive_state"

definition setExMonitor :: "exclusive_monitors \<Rightarrow> unit machine_monad" where
  "setExMonitor es \<equiv> modify (\<lambda>ms. ms\<lparr>exclusive_state := es\<rparr>)"

definition
  "compl (A::'a set) \<equiv> - A"

definition do_user_op_if
where
  "do_user_op_if uop tc =
   do
      \<comment> \<open>Get the page rights of each address (ReadOnly, ReadWrite, None, etc).\<close>
      pr \<leftarrow> gets ptable_rights_s;

      \<comment> \<open>Fetch the 'execute never' bits of the current thread's page mappings.\<close>
      pxn \<leftarrow> gets (\<lambda>s x. pr x \<noteq> {} \<and> ptable_xn_s s x);

      \<comment> \<open>Get the mapping from virtual to physical addresses.\<close>
      pl \<leftarrow> gets (\<lambda>s. restrict_map (ptable_lift_s s) {x. pr x \<noteq> {}});

      allow_read \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowRead \<in> pr x};
      allow_write \<leftarrow> return  {y. EX x. pl x = Some y \<and> AllowWrite \<in> pr x};

      \<comment> \<open>Get the current thread.\<close>
      t \<leftarrow> gets cur_thread;

      \<comment> \<open>Generate user memory by throwing away anything from global
         memory that the user doesn't have access to. (The user must
         have both (1) a mapping to the page; (2) that mapping has the
         AllowRead right.\<close>
      um \<leftarrow> gets (\<lambda>s. (user_mem s) \<circ> ptrFromPAddr);
      dm \<leftarrow> gets (\<lambda>s. (device_mem s) \<circ> ptrFromPAddr);
      ds \<leftarrow> gets (device_state \<circ> machine_state);

      es \<leftarrow> do_machine_op getExMonitor;

      \<comment> \<open>Non-deterministically execute one of the user's operations.\<close>
      u \<leftarrow> return (uop t pl pr pxn (tc, um|`allow_read, (ds \<circ> ptrFromPAddr)|` allow_read, es));
      assert (u \<noteq> {});
      (e,(tc',um',ds',es')) \<leftarrow> select u;

      \<comment> \<open>Update the changes the user made to memory into our model.
         We ignore changes that took place where they didn't have
         write permissions. (uop shouldn't be doing that --- if it is,
         uop isn't correctly modelling real hardware.)\<close>
      do_machine_op (user_memory_update
          (((um' |` allow_write) \<circ> addrFromPPtr) |` (-(dom ds))));

      do_machine_op (device_memory_update
          (((ds' |` allow_write) \<circ> addrFromPPtr) |` (dom ds)));

      \<comment> \<open>Update exclusive monitor state used by the thread.\<close>
      do_machine_op (setExMonitor es');

      return (e,tc')
   od"

(* Assumptions:
 * User is deterministic based on an address being mapped with no rights or not mapped at all.
 * We implicitly assume that if you have any rights you must have at least read rights.
*)

lemma dmo_user_memory_update_reads_respects_g:
   "reads_respects_g aag l \<top> (do_machine_op (user_memory_update um))"
   apply(clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
   apply(clarsimp simp: do_machine_op_def user_memory_update_def gets_def select_f_def
                        get_def bind_def in_monad)
   apply(clarsimp simp: reads_equiv_g_def globals_equiv_def split: option.splits)
   apply(subgoal_tac "reads_respects aag l \<top> (do_machine_op (user_memory_update um))")
    apply(fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad
                    do_machine_op_def user_memory_update_def select_f_def
                    idle_equiv_def)
   apply(rule use_spec_ev)
   apply (simp add: user_memory_update_def)
   apply(rule do_machine_op_spec_reads_respects)
    apply(simp add: equiv_valid_def2)
    apply(rule modify_ev2)
    apply(fastforce intro: equiv_forI elim: equiv_forE split: option.splits)
   apply (wp | simp)+
   done

lemma requiv_get_pd_of_thread_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag (cur_thread s);
     pd_ref \<noteq> arm_global_pd (arch_state s);
     pd_ref' \<noteq> arm_global_pd (arch_state s');
     get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) = pd_ref;
     get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') = pd_ref' \<rbrakk>
   \<Longrightarrow> pd_ref = pd_ref'"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag (cur_thread s)")
   apply (clarsimp simp: get_pd_of_thread_eq)
  apply (simp add: reads_lrefl)
  done

lemma requiv_get_pt_entry_eq:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag pt \<rbrakk>
   \<Longrightarrow> get_pt_entry (\<lambda>obj. get_arch_obj (kheap s obj)) pt x
       = get_pt_entry (\<lambda>obj. get_arch_obj (kheap s' obj)) pt x"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag pt")
   apply (simp add: get_pt_entry_def split: option.splits)
  apply (simp add: reads_lrefl)
  done

lemma requiv_get_pt_info_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag pt \<rbrakk>
   \<Longrightarrow> get_pt_info (\<lambda>obj. get_arch_obj (kheap s obj)) pt x
       = get_pt_info (\<lambda>obj. get_arch_obj (kheap s' obj)) pt x"
  apply (simp add: get_pt_info_def)
  apply (subst requiv_get_pt_entry_eq, simp+)
  done

lemma requiv_get_pd_entry_eq:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag pd \<rbrakk>
   \<Longrightarrow> get_pd_entry (\<lambda>obj. get_arch_obj (kheap s obj)) pd x
       = get_pd_entry (\<lambda>obj. get_arch_obj (kheap s' obj)) pd x"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag pd")
   apply (simp add: get_pd_entry_def split: option.splits)
  apply (simp add: reads_lrefl)
  done

lemma requiv_get_page_info_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; is_subject aag pd;
     x \<notin> kernel_mappings \<rbrakk>
   \<Longrightarrow> get_page_info (\<lambda>obj. get_arch_obj (kheap s obj)) pd x
       = get_page_info (\<lambda>obj. get_arch_obj (kheap s' obj)) pd x"
  apply (simp add: get_page_info_def)
  apply (subst requiv_get_pd_entry_eq[symmetric], simp+)
  apply (clarsimp split: option.splits pde.splits)
  apply (frule pt_in_pd_same_agent, fastforce+)
  apply (rule requiv_get_pt_info_eq, simp+)
  done

lemma requiv_pd_of_thread_global_pd:
  "\<lbrakk> reads_equiv aag s s'; is_subject aag (cur_thread s); invs s; pas_refined aag s;
     get_pd_of_thread (kheap s) (arch_state s) (cur_thread s) = arm_global_pd (arch_state s) \<rbrakk>
   \<Longrightarrow> get_pd_of_thread (kheap s') (arch_state s') (cur_thread s') = arm_global_pd (arch_state s')"
  apply (erule reads_equivE)
  apply (erule equiv_forE)
  apply (subgoal_tac "aag_can_read aag (cur_thread s)")
   prefer 2
   apply (simp add: reads_lrefl)
  apply (clarsimp simp: get_pd_of_thread_def2
                  split: option.splits kernel_object.splits cap.splits arch_cap.splits)
  apply (rename_tac tcb word word' p apool)
  apply (subgoal_tac "aag_can_read_asid aag word'")
   apply (subgoal_tac "s \<turnstile> ArchObjectCap (PageDirectoryCap word (Some word'))")
    apply (clarsimp simp: equiv_asids_def equiv_asid_def valid_cap_def)
    apply (drule_tac x=word' in spec)
    apply (clarsimp simp: word_gt_0 typ_at_eq_kheap_obj)
    apply (drule invs_valid_global_refs)
    apply (drule_tac ptr="((cur_thread s), tcb_cnode_index 1)" in valid_global_refsD2[rotated])
     apply (subst caps_of_state_tcb_cap_cases)
       apply (simp add: get_tcb_def)
      apply (simp add: dom_tcb_cap_cases[simplified])
     apply simp
    apply (simp add: cap_range_def global_refs_def)

   apply (cut_tac s=s and t="cur_thread s" and tcb=tcb in objs_valid_tcb_vtable)
     apply (fastforce simp: invs_valid_objs get_tcb_def)+
  apply (subgoal_tac "(pasObjectAbs aag (cur_thread s), Control, pasASIDAbs aag word')
                          \<in> state_asids_to_policy aag s")
   apply (frule pas_refined_Control_into_is_subject_asid)
    apply (fastforce simp: pas_refined_def)
   apply simp
  apply (cut_tac aag=aag and ptr="(cur_thread s, tcb_cnode_index 1)" in sata_asid)
    prefer 3
    apply simp
   apply (subst caps_of_state_tcb_cap_cases)
     apply (simp add: get_tcb_def)
    apply (simp add: dom_tcb_cap_cases[simplified])+
  done

lemma requiv_ptable_rights_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s' \<rbrakk>
   \<Longrightarrow> ptable_rights_s s = ptable_rights_s s'"
  apply (simp add: ptable_rights_s_def)
  apply (rule ext)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_rights_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def)+)[4]
   apply clarsimp
   apply (frule_tac r=ba in some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def)+)[4]

  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s)
                 = arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_rights_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]

  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s')
                 = arm_global_pd (arch_state s')")
  apply (drule reads_equiv_sym)
  apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]

  apply (simp add: ptable_rights_def)
  apply (frule requiv_get_pd_of_thread_eq)
        apply (fastforce+)[6]
  apply (frule pd_of_thread_same_agent, simp+)
  apply (subst requiv_get_page_info_eq, simp+)
  done

lemma requiv_ptable_attrs_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
   \<Longrightarrow> ptable_attrs_s s x = ptable_attrs_s s' x"
  apply (simp add: ptable_attrs_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]

  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s)
                 = arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_attrs_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]

  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s')
                 = arm_global_pd (arch_state s')")
  apply (drule reads_equiv_sym)
  apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]

  apply (simp add: ptable_attrs_def)
  apply (frule requiv_get_pd_of_thread_eq, simp+)[1]
  apply (frule pd_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)[1]
  done

lemma requiv_ptable_lift_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s'; invs s;
     invs s'; is_subject aag (cur_thread s); ptable_rights_s s x \<noteq> {} \<rbrakk>
   \<Longrightarrow> ptable_lift_s s x = ptable_lift_s s' x"
  apply (simp add: ptable_lift_s_def ptable_rights_s_def)
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule some_get_page_info_kmapsD)
       apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                              vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]
   apply clarsimp
   apply (frule some_get_page_info_kmapsD)
      apply ((fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def ptable_rights_def)+)[4]

  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) (cur_thread s)
                 = arm_global_pd (arch_state s)")
   apply (frule requiv_pd_of_thread_global_pd)
       apply (fastforce+)[4]
   apply (clarsimp simp: ptable_lift_def split: option.splits)
   apply (rule conjI)
    apply clarsimp
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (rule conjI)
    apply (frule get_page_info_gpd_kmaps[rotated, rotated])
      apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]
   apply clarsimp
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply ((fastforce simp: invs_valid_global_objs invs_arch_state)+)[3]

  apply (case_tac "get_pd_of_thread (kheap s') (arch_state s') (cur_thread s')
                 = arm_global_pd (arch_state s')")
  apply (drule reads_equiv_sym)
  apply (frule requiv_pd_of_thread_global_pd)
       apply ((fastforce simp: reads_equiv_def)+)[5]

  apply (simp add: ptable_lift_def)
  apply (frule requiv_get_pd_of_thread_eq, simp+)[1]
  apply (frule pd_of_thread_same_agent, simp+)[1]
  apply (subst requiv_get_page_info_eq, simp+)[1]
  done

lemma requiv_ptable_xn_eq:
  "\<lbrakk> reads_equiv aag s s'; pas_refined aag s; pas_refined aag s';
     is_subject aag (cur_thread s); invs s; invs s'; ptable_rights_s s x \<noteq> {} \<rbrakk>
   \<Longrightarrow> ptable_xn_s s x = ptable_xn_s s' x"
  by (simp add: ptable_xn_s_def requiv_ptable_attrs_eq)

lemma mask_shift_le:
 "z \<le> y \<Longrightarrow> (x::'a:: len word) && ~~ mask z >> y = x >> y"
  proof -
   assume le: "z \<le> y"
   have shifttwice: "\<And>(x::'a:: len word). x >> y = x >> z >> y - z"
    by (simp add: shiftr_shiftr le)
   show ?thesis
    apply (subst shifttwice)
    apply simp
    apply (simp add: shiftr_shiftr le)
   done
  qed

lemma data_at_obj_range:
  "\<lbrakk>data_at sz ptr s;pspace_aligned s;valid_objs s \<rbrakk>
    \<Longrightarrow> ptr + (offset && mask (pageBitsForSize sz)) \<in> obj_range ptr (ArchObj (DataPage dev sz))"
  apply (clarsimp simp: data_at_def)
  apply (elim disjE)
   apply (clarsimp simp: obj_at_def)
   apply (drule(2) ptr_in_obj_range)
   apply (clarsimp simp: obj_bits_def obj_range_def)
   apply fastforce
  apply (clarsimp simp: obj_at_def)
  apply (drule(2) ptr_in_obj_range)
  apply (clarsimp simp: obj_bits_def obj_range_def)
  apply fastforce
  done

lemma obj_range_data_for_cong:
  "obj_range ptr (ArchObj (DataPage dev sz'))
  = obj_range ptr (ArchObj (DataPage False sz'))"
  by (simp add: obj_range_def)

lemma data_at_disjoint_equiv:
  "\<lbrakk>ptr' \<noteq> ptr;data_at sz' ptr' s; data_at sz ptr s; valid_objs s; pspace_aligned s;
    pspace_distinct s; ptr' \<in> obj_range ptr (ArchObj (DataPage dev sz)) \<rbrakk>
  \<Longrightarrow> False"
  apply (frule(2) data_at_obj_range[where offset = 0,simplified])
  apply (clarsimp simp: data_at_def obj_at_def)
  apply (elim disjE)
    apply (clarsimp dest!: spec simp: obj_at_def pspace_distinct_def'
      ,erule impE,erule conjI2[OF conjI2],(fastforce+)[2]
      ,fastforce cong: obj_range_data_for_cong)+
  done

lemma data_at_aligned:
  "\<lbrakk>data_at sz base s;pspace_aligned s\<rbrakk> \<Longrightarrow> is_aligned base (pageBitsForSize sz)"
  apply (clarsimp simp: data_at_def)
  apply (elim disjE)
  apply (clarsimp simp: obj_at_def
                 split: kernel_object.split_asm if_split_asm arch_kernel_obj.split_asm
                 dest!: pspace_alignedD)+
  done

lemma ptrFromPAddr_mask_simp:
 "(ptrFromPAddr z && ~~ mask (pageBitsForSize l)) =
   (ptrFromPAddr (z && ~~ mask (pageBitsForSize l)))"
  apply (simp add: ptrFromPAddr_def field_simps)
  apply (subst mask_out_add_aligned[OF is_aligned_physMappingOffset])
  apply simp
  done

lemma pageBitsForSize_le_t24:
  "pageBitsForSize sz \<le> 24"
  by (cases sz, simp_all)

lemma data_at_same_size:
  assumes dat_sz': "data_at sz' (ptrFromPAddr base) s"
      and dat_sz: "data_at sz (ptrFromPAddr (base + (x && mask (pageBitsForSize sz')))
                                            && ~~ mask (pageBitsForSize sz)) s"
      and vs: "pspace_distinct s" "pspace_aligned s" "valid_objs s"
  shows "sz' = sz"
  proof -
    from dat_sz' and dat_sz
    have trivial:
      "sz' \<noteq> sz
       \<Longrightarrow> (ptrFromPAddr (base + (x && mask (pageBitsForSize sz'))) && ~~ mask (pageBitsForSize sz))
           \<noteq> (ptrFromPAddr base)"
    apply (simp add: data_at_def obj_at_def)
    apply (rule ccontr)
    apply (auto)
    done
    have sz_equiv: "(pageBitsForSize sz = pageBitsForSize sz') = (sz' = sz)"
    by (clarsimp simp: pageBitsForSize_def split: vmpage_size.splits)
  show ?thesis
  apply (rule sz_equiv[THEN iffD1])
  apply (rule ccontr)
  apply (drule neq_iff[THEN iffD1])
  using dat_sz' dat_sz vs
  apply (cut_tac trivial) prefer 2
   apply (fastforce simp: sz_equiv)
  apply (frule(1) data_at_aligned)
  apply (elim disjE)
   apply (erule(5) data_at_disjoint_equiv)
   apply (unfold obj_range_def)
   apply (rule mask_in_range[THEN iffD1])
    apply (simp add: obj_bits_def)+
   apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
   apply (rule arg_cong[where f = ptrFromPAddr])
   apply (drule is_aligned_ptrFromPAddrD[OF _ pageBitsForSize_le_t24])
     apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
      apply simp
     apply (fastforce simp: pbfs_less_wb[unfolded word_bits_def,simplified])
   apply (simp add: is_aligned_neg_mask_eq)
  apply (drule not_sym)
  apply (erule(5) data_at_disjoint_equiv)
  apply (unfold obj_range_def)
  apply (rule mask_in_range[THEN iffD1])
   apply (simp add: obj_bits_def is_aligned_neg_mask)+
  apply (simp add: mask_lower_twice ptrFromPAddr_mask_simp)
  apply (rule arg_cong[where f = ptrFromPAddr])
  apply (drule is_aligned_ptrFromPAddrD[OF _ pageBitsForSize_le_t24])
  apply (subst mask_lower_twice[symmetric])
   apply (erule less_imp_le_nat)
  apply (rule sym)
  apply (subst mask_lower_twice[symmetric])
   apply (erule less_imp_le_nat)
  apply (rule arg_cong[where f = "\<lambda>x. x && ~~ mask z" for z])
  apply (subst neg_mask_add_aligned[OF _ and_mask_less'])
    apply simp
   apply (fastforce simp: pbfs_less_wb[unfolded word_bits_def,simplified])
  apply simp
  done
qed

lemma valid_pdpt_align_ptD:
  "\<lbrakk>kheap s ptr = Some (ArchObj (PageTable pt));valid_pdpt_objs s; pt a = entry\<rbrakk>
   \<Longrightarrow> is_aligned a (pte_range_sz entry)"
  apply (drule(1) valid_pdpt_objs_ptD)
  apply (clarsimp simp: entries_align_def)
  done

lemma valid_pdpt_align_pdD:
  "\<lbrakk>kheap s ptr = Some (ArchObj (PageDirectory pd));valid_pdpt_objs s; pd a = entry\<rbrakk>
   \<Longrightarrow> is_aligned a (pde_range_sz entry)"
  apply (drule(1) valid_pdpt_objs_pdD)
  apply (clarsimp simp: entries_align_def)
  done

lemma valid_vspace_objsD2:
  "\<lbrakk>(\<exists>\<rhd> p) s; ko_at (ArchObj ao) p s;
     valid_vspace_objs s\<rbrakk>
    \<Longrightarrow> valid_vspace_obj ao s"
  by (clarsimp simp: valid_vspace_objsD)

lemma ptable_lift_data_consistant:
  assumes vs: "valid_state s"
          and vpdpt: "valid_pdpt_objs s"
          and pt_lift: "ptable_lift t s x = Some ptr"
          and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
          and misc: "get_pd_of_thread (kheap s) (arch_state s) t
                 \<noteq> arm_global_pd (arch_state s)" "x \<notin> kernel_mappings"
  shows "ptable_lift t s (x && ~~ mask (pageBitsForSize sz)) =
         Some (ptr && ~~ mask (pageBitsForSize sz))"
  proof -
   have aligned_stuff:
   "\<lbrakk>is_aligned (ucast ((x >> 12) && mask 8) :: word8) 4\<rbrakk> \<Longrightarrow>
    (x && ~~ mask 16 >> 12) = x >> 12"
    apply (simp add: is_aligned_mask)
    apply word_bitwise
    apply (simp add: mask_def)
    done
   have aligned_stuff':
   "\<lbrakk>is_aligned ((ucast (x >> 20)):: 12 word) 4\<rbrakk> \<Longrightarrow>
   (x && ~~ mask 24 >> 20) = x >> 20"
    apply (simp add: is_aligned_mask)
    apply word_bitwise
    apply (simp add: mask_def)
    done
   have vs': "valid_objs s \<and> valid_vspace_objs s \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs
    by (simp add: valid_state_def valid_pspace_def)
   have x_less_kb: "x < kernel_base"
    using misc
    by (simp add: kernel_mappings_def) (* FIXME: any rules exists already ? *)

  thus ?thesis
  using pt_lift dat vs'
  apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits)
  apply (clarsimp simp: get_page_info_def split: option.splits)
  apply (rename_tac base sz' attrs rights pde)
  apply (case_tac pde,simp_all)
    apply (clarsimp simp: get_pd_entry_def split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_info_def get_arch_obj_def
                          get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr mw pd pt)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply (simp add:)
    apply (drule bspec)
    apply (rule Compl_iff[THEN iffD2])
    apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def a_type_def)
    apply (case_tac "pt (ucast ((x >> 12) && mask 8))",simp_all)
     apply (frule valid_vspace_objsD2[
                           where p = "ptrFromPAddr p" for p,rotated,unfolded obj_at_def,simplified],
            simp)
      apply (rule exI)
      apply (erule vs_lookup_step)
       apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def pd_shifting
         pd_shifting_dual obj_at_def)
       apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
       apply (rule context_conjI,simp)
      apply (erule vs_refs_pdI)
       apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
      apply (intro allI impI)
      apply (simp add: nth_shiftr)
      apply (rule bang_big[simplified])
      apply (simp add: word_size)
     apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
     apply (simp add: )
     apply (drule_tac x = "(ucast ((x >> 12) && mask 8))" in spec)
      apply (frule data_at_same_size[where sz = sz and sz' = ARMLargePage,rotated,simplified],
        clarsimp+)
     apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                           get_arch_obj_def entries_align_def aligned_stuff mask_AND_NOT_mask
                    dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 16,simplified])
     apply (simp add: neg_mask_add_aligned[OF _ and_mask_less'] is_aligned_neg_mask_eq)
    apply (frule valid_vspace_objsD2[
                           where p = "ptrFromPAddr p" for p,rotated,unfolded obj_at_def,simplified],
           simp)
     apply (rule exI)
     apply (erule vs_lookup_step)
      apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def pd_shifting
        pd_shifting_dual obj_at_def)
      apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
      apply (rule context_conjI,simp)
     apply (erule vs_refs_pdI)
      apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
     apply (intro allI impI)
     apply (simp add: nth_shiftr)
     apply (rule bang_big[simplified])
     apply (simp add: word_size)
    apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
    apply (simp add: )
    apply (drule_tac x = "(ucast ((x >> 12) && mask 8))" in spec)
    apply (frule data_at_same_size[where sz = sz and sz' = ARMSmallPage,rotated,simplified],
        clarsimp+)
    apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                          neg_mask_add_aligned[OF _ and_mask_less']
                          is_aligned_neg_mask_eq  get_arch_obj_def entries_align_def
                          mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 12,simplified])
   apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                  split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr mw pd caprights)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply (simp add: )
    apply (drule bspec)
    apply (rule Compl_iff[THEN iffD2])
    apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def)
   apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
   apply (frule data_at_same_size[where sz = sz and sz' = ARMSection,rotated,simplified],
        clarsimp+)
   apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                         neg_mask_add_aligned[OF _ and_mask_less']
                         is_aligned_neg_mask_eq  get_arch_obj_def entries_align_def
                         mask_AND_NOT_mask
                  dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 20,simplified])
  apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                 split: arch_kernel_obj.split_asm option.splits)
  apply (clarsimp simp: get_pt_entry_def
                 split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
  apply (rename_tac pd_base vmattr rights pd)
  apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
  apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
  apply (simp add: )
  apply (drule bspec)
  apply (rule Compl_iff[THEN iffD2])
  apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
  apply (clarsimp simp: valid_pde_def obj_at_def)
  apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
  apply (frule data_at_same_size[where sz = sz and sz' = ARMSuperSection,rotated,simplified],
        clarsimp+)
    apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                          neg_mask_add_aligned[OF _ and_mask_less']
                          is_aligned_neg_mask_eq  get_arch_obj_def entries_align_def
                          aligned_stuff' mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 24,simplified])
  done
qed

lemma ptable_rights_data_consistant:
  assumes vs: "valid_state s"
          and vpdpt: "valid_pdpt_objs s"
          and pt_lift: "ptable_lift t s x = Some ptr"
          and dat: "data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s"
          and misc: "get_pd_of_thread (kheap s) (arch_state s) t
                 \<noteq> arm_global_pd (arch_state s)" "x \<notin> kernel_mappings"
  shows "ptable_rights t s (x && ~~ mask (pageBitsForSize sz)) = ptable_rights t s x"
  proof -
   have aligned_stuff:
   "\<lbrakk>is_aligned (ucast ((x >> 12) && mask 8) :: word8) 4\<rbrakk> \<Longrightarrow>
    (x && ~~ mask 16 >> 12) = x >> 12"
    apply (simp add: is_aligned_mask)
    apply word_bitwise
    apply (simp add: mask_def)
    done
   have aligned_stuff':
   "\<lbrakk>is_aligned ((ucast (x >> 20)):: 12 word) 4\<rbrakk> \<Longrightarrow>
   (x && ~~ mask 24 >> 20) = x >> 20"
    apply (simp add: is_aligned_mask)
    apply word_bitwise
    apply (simp add: mask_def)
    done
   have vs': "valid_objs s \<and> valid_vspace_objs s \<and> pspace_distinct s \<and> pspace_aligned s"
    using vs
    by (simp add: valid_state_def valid_pspace_def)
   have x_less_kb: "x < kernel_base"
    using misc
    by (simp add: kernel_mappings_def) (* FIXME: any rules exists already ? *)

  thus ?thesis
  using pt_lift dat vs'
  apply (clarsimp simp: ptable_rights_def ptable_lift_def split: option.splits)
  apply (clarsimp simp: get_page_info_def split: option.splits)
  apply (rename_tac base sz' attrs rights pde)
  apply (case_tac pde,simp_all)
    apply (clarsimp simp: get_pd_entry_def split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_info_def get_arch_obj_def
                          get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr mw pd pt)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply (simp add: )
    apply (drule bspec)
    apply (rule Compl_iff[THEN iffD2])
    apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def a_type_def)
    apply (case_tac "pt (ucast ((x >> 12) && mask 8))",simp_all)
     apply (frule valid_vspace_objsD2[
                           where p = "ptrFromPAddr p" for p,rotated,unfolded obj_at_def,simplified],
            simp)
      apply (rule exI)
      apply (erule vs_lookup_step)
       apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def pd_shifting
         pd_shifting_dual obj_at_def)
       apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
       apply (rule context_conjI,simp)
      apply (erule vs_refs_pdI)
       apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
      apply (intro allI impI)
      apply (simp add: nth_shiftr)
      apply (rule bang_big[simplified])
      apply (simp add: word_size)
     apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
     apply (simp add: )
     apply (drule_tac x = "(ucast ((x >> 12) && mask 8))" in spec)
     apply (frule data_at_same_size[where sz = sz and sz' = ARMLargePage,rotated,simplified],
        clarsimp+)
     apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                           get_arch_obj_def entries_align_def aligned_stuff mask_AND_NOT_mask
                    dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 16,simplified])
    apply (frule valid_vspace_objsD2[
                           where p = "ptrFromPAddr p" for p,rotated,unfolded obj_at_def,simplified],
           simp)
     apply (rule exI)
     apply (erule vs_lookup_step)
      apply (simp add: vs_lookup1_def lookup_pd_slot_def Let_def pd_shifting
        pd_shifting_dual obj_at_def)
      apply (rule_tac x = "VSRef (x>>20) (Some APageDirectory)" in exI)
      apply (rule context_conjI,simp)
     apply (erule vs_refs_pdI)
      apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
     apply (intro allI impI)
     apply (simp add: nth_shiftr)
     apply (rule bang_big[simplified])
     apply (simp add: word_size)
    apply (frule(1) valid_pdpt_align_ptD[OF _ vpdpt])
    apply (simp add: )
    apply (drule_tac x = "(ucast ((x >> 12) && mask 8))" in spec)
    apply (frule data_at_same_size[where sz = sz and sz' = ARMSmallPage,rotated,simplified],
        clarsimp+)
    apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                          neg_mask_add_aligned[OF _ and_mask_less']
                          is_aligned_neg_mask_eq  get_arch_obj_def entries_align_def
                          mask_AND_NOT_mask
                          dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 12,simplified])
   apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                  split: arch_kernel_obj.split_asm option.splits)
    apply (clarsimp simp: get_pt_entry_def
                   split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
    apply (rename_tac pd_base vmattr mw pd caprights)
    apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
    apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
    apply (simp add: )
    apply (drule bspec)
    apply (rule Compl_iff[THEN iffD2])
    apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
    apply (clarsimp simp: valid_pde_def obj_at_def)
   apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
   apply (frule data_at_same_size[where sz = sz and sz' = ARMSection,rotated,simplified],
        clarsimp+)
  apply (clarsimp simp: get_pd_entry_def get_arch_obj_def
                 split: arch_kernel_obj.split_asm option.splits)
  apply (clarsimp simp: get_pt_entry_def
                 split: option.splits arch_kernel_obj.split_asm kernel_object.splits)
  apply (rename_tac pd_base vmattr rights pd)
  apply (cut_tac get_pd_of_thread_reachable[OF misc(1)])
  apply (frule(1) valid_vspace_objsD2[rotated,unfolded obj_at_def,simplified],simp)
  apply (simp add: )
  apply (drule bspec)
  apply (rule Compl_iff[THEN iffD2])
  apply (rule kernel_mappings_kernel_mapping_slots[OF misc(2)])
  apply (clarsimp simp: valid_pde_def obj_at_def)
  apply (frule(1) valid_pdpt_align_pdD[OF _ vpdpt])
  apply (frule data_at_same_size[where sz = sz and sz' = ARMSuperSection,rotated,simplified],
        clarsimp+)
    apply (clarsimp simp: mask_shift_le get_pt_info_def get_pt_entry_def
                          neg_mask_add_aligned[OF _ and_mask_less']
                          is_aligned_neg_mask_eq  get_arch_obj_def entries_align_def
                          aligned_stuff' mask_AND_NOT_mask
                   dest!: data_at_aligned is_aligned_ptrFromPAddrD[where a = 24,simplified])
  done
qed

lemma user_op_access_data_at:
  "\<lbrakk> invs s; valid_pdpt_objs s;pas_refined aag s; is_subject aag tcb;
     ptable_lift tcb s x = Some ptr;
     data_at sz ((ptrFromPAddr ptr) && ~~ mask (pageBitsForSize sz)) s;
     auth \<in> vspace_cap_rights_to_auth (ptable_rights tcb s x) \<rbrakk>
   \<Longrightarrow> (pasObjectAbs aag tcb,
        auth,
        pasObjectAbs aag (ptrFromPAddr (ptr && ~~ mask (pageBitsForSize sz)))) \<in> pasPolicy aag"
  apply (case_tac "x \<in> kernel_mappings")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule some_get_page_info_kmapsD)
      apply (fastforce simp: invs_valid_global_pd_mappings invs_equal_kernel_mappings
                             vspace_cap_rights_to_auth_def)+

  apply (case_tac "get_pd_of_thread (kheap s) (arch_state s) tcb
                 = arm_global_pd (arch_state s)")
   apply (clarsimp simp: ptable_lift_def ptable_rights_def split: option.splits)
   apply (frule get_page_info_gpd_kmaps[rotated, rotated])
     apply (fastforce simp: invs_valid_global_objs invs_arch_state)+
  apply (frule(3) ptable_lift_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (frule (3) ptable_rights_data_consistant[rotated 2])
    apply fastforce
   apply fastforce
  apply (erule(3) user_op_access)
  apply simp
  done

lemma user_frame_at_equiv:
  "\<lbrakk>typ_at (AArch (AUserData sz)) p s ; equiv_for P kheap s s'; P p  \<rbrakk>
  \<Longrightarrow> typ_at (AArch (AUserData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma device_frame_at_equiv:
  "\<lbrakk>typ_at (AArch (ADeviceData sz)) p s ; equiv_for P kheap s s'; P p  \<rbrakk>
  \<Longrightarrow> typ_at (AArch (ADeviceData sz)) p s'"
  by (clarsimp simp: equiv_for_def obj_at_def)

lemma typ_at_user_data_at:
  "typ_at (AArch (AUserData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma typ_at_device_data_at:
  "typ_at (AArch (ADeviceData sz)) p s \<Longrightarrow> data_at sz p s"
  by (simp add: data_at_def)

lemma equiv_symmetric:
  "equiv_for a b c d = equiv_for a b d c"
  by (auto simp: equiv_for_def)

lemma requiv_device_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s;
     invs s'; valid_pdpt_objs s; valid_pdpt_objs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s'
     \<rbrakk>
   \<Longrightarrow> device_mem s (ptrFromPAddr y) = device_mem s' (ptrFromPAddr y)"
  apply (simp add: device_mem_def)
  apply (rule conjI)
   apply (erule reads_equivE)
     apply (clarsimp simp: in_device_frame_def)
     apply (rule exI)
     apply (rule device_frame_at_equiv)
       apply assumption+
     apply (erule_tac f="underlying_memory" in equiv_forE)
     apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                               vspace_cap_rights_to_auth_def
              | intro typ_at_device_data_at)+
     apply (rule reads_read)
     apply (fastforce simp: ptrFromPAddr_mask_simp)
    apply clarsimp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
    apply (erule reads_equivE)
    apply (clarsimp simp: in_device_frame_def)
    apply (rule exI)
    apply (rule device_frame_at_equiv)
      apply assumption+
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply (erule equiv_symmetric[THEN iffD1])
    apply (frule_tac auth=Read in user_op_access_data_at[where s = s'])
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                              vspace_cap_rights_to_auth_def
             | intro typ_at_device_data_at)+
    apply (rule reads_read)
    apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma requiv_user_mem_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s;
     invs s'; valid_pdpt_objs s; valid_pdpt_objs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s'
     \<rbrakk>
   \<Longrightarrow> user_mem s (ptrFromPAddr y) = user_mem s' (ptrFromPAddr y)"
  apply (simp add: user_mem_def)
  apply (rule conjI)
    apply clarsimp
    apply (rule context_conjI')
     apply (erule reads_equivE)
     apply (clarsimp simp: in_user_frame_def)
     apply (rule exI)
     apply (rule user_frame_at_equiv)
       apply assumption+
     apply (erule_tac f="underlying_memory" in equiv_forE)
     apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                               vspace_cap_rights_to_auth_def
              | intro typ_at_user_data_at)+
     apply (rule reads_read)
     apply (fastforce simp: ptrFromPAddr_mask_simp)
    apply clarsimp
    apply (subgoal_tac "aag_can_read aag (ptrFromPAddr y)")
     apply (erule reads_equivE)
     apply clarsimp
     apply (erule_tac f="underlying_memory" in equiv_forE)
     apply simp
    apply (frule_tac auth=Read in user_op_access)
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                               vspace_cap_rights_to_auth_def)+
    apply (rule reads_read)
    apply simp
  apply (frule requiv_ptable_rights_eq, fastforce+)
  apply (frule requiv_ptable_lift_eq, fastforce+)
  apply (clarsimp simp: globals_equiv_def)
  apply (erule notE)
    apply (erule reads_equivE)
    apply (clarsimp simp: in_user_frame_def)
    apply (rule exI)
    apply (rule user_frame_at_equiv)
      apply assumption+
    apply (erule_tac f="underlying_memory" in equiv_forE)
    apply (erule equiv_symmetric[THEN iffD1])
    apply (frule_tac auth=Read in user_op_access_data_at[where s = s'])
       apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                              vspace_cap_rights_to_auth_def
             | intro typ_at_user_data_at)+
    apply (rule reads_read)
    apply (fastforce simp: ptrFromPAddr_mask_simp)
  done

lemma ptable_rights_imp_frameD:
  "\<lbrakk>ptable_lift t s x = Some y;valid_state s;ptable_rights t s x \<noteq> {}\<rbrakk> \<Longrightarrow>
         \<exists>sz. data_at sz (ptrFromPAddr y && ~~ mask (pageBitsForSize sz)) s"
  apply (subst(asm) addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (drule ptable_rights_imp_frame)
     apply simp+
   apply (rule addrFromPPtr_ptrFromPAddr_id[symmetric])
  apply (auto simp: in_user_frame_def in_device_frame_def
             dest!: spec typ_at_user_data_at typ_at_device_data_at)
  done

lemma requiv_user_device_eq:
  "\<lbrakk> reads_equiv aag s s'; globals_equiv s s'; invs s;
     invs s'; valid_pdpt_objs s; valid_pdpt_objs s';
     is_subject aag (cur_thread s); AllowRead \<in> ptable_rights_s s x;
     ptable_lift_s s x = Some y; pas_refined aag s; pas_refined aag s'
     \<rbrakk>
   \<Longrightarrow> device_state (machine_state s) (ptrFromPAddr y) =
          device_state (machine_state s') (ptrFromPAddr y)"
  apply (simp add: ptable_lift_s_def)
  apply (frule ptable_rights_imp_frameD)
    apply fastforce
   apply (fastforce simp: ptable_rights_s_def)
  apply (erule reads_equivE)
  apply clarsimp
  apply (erule_tac f="device_state" in equiv_forD)
  apply (frule_tac auth=Read in user_op_access_data_at[where s = s])
        apply ((fastforce simp: ptable_lift_s_def ptable_rights_s_def
                                vspace_cap_rights_to_auth_def
               | intro typ_at_user_data_at)+)[6]
  apply (rule reads_read)
    apply (frule_tac auth=Read in user_op_access)
        apply (fastforce simp: ptable_lift_s_def ptable_rights_s_def
                               vspace_cap_rights_to_auth_def)+
  done

lemma gets_ev''':
  "equiv_valid_inv I A (\<lambda>s. P s \<and> (\<forall> t. I s t \<and> A s t \<and> P t \<longrightarrow> f s = f t)) (gets f)"
  apply (simp add: equiv_valid_def2)
  apply (auto simp: equiv_valid_2_def in_monad)
  done

lemma spec_equiv_valid_add_asm:
  "((P st) \<Longrightarrow> spec_equiv_valid_inv st I A P f) \<Longrightarrow> spec_equiv_valid_inv st I A P f"
  apply(clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
  done

lemma spec_equiv_valid_add_rel:
  "\<lbrakk>spec_equiv_valid_inv st I A (P and I st) f; \<And>s. I s s\<rbrakk> \<Longrightarrow> spec_equiv_valid_inv st I A P f"
  apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
  done

lemma spec_equiv_valid_add_rel':
  "\<lbrakk>spec_equiv_valid_inv st I A (P and A st) f; \<And>s. A s s\<rbrakk> \<Longrightarrow> spec_equiv_valid_inv st I A P f"
  apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def)
  done

lemma reads_equiv_g_refl:
  "reads_equiv_g aag s s"
  apply (rule reads_equiv_gI)
   apply (rule reads_equiv_refl)
  apply (rule globals_equiv_refl)
  done

definition context_matches_state where
  "context_matches_state pl pr pxn um ds es s \<equiv>
      pl = ptable_lift_s s |` {x. pr x \<noteq> {}} \<and>
      pr = ptable_rights_s s \<and>
      pxn = (\<lambda>x. pr x \<noteq> {} \<and> ptable_xn_s s x) \<and>
      um = (user_mem s \<circ> ptrFromPAddr) |` {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x} \<and>
      ds = (device_state (machine_state s) \<circ> ptrFromPAddr)
                         |` {y. \<exists>x. pl x = Some y \<and> AllowRead \<in> pr x} \<and>
      es = exclusive_state (machine_state s)"

(* FIXME - move - duplicated in Schedule_IF *)
lemma dmo_ev:
  "(\<And>s s'. equiv_valid (\<lambda>ms ms'. I (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
                   (\<lambda>ms ms'. A (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
                   (\<lambda>ms ms'. B (s\<lparr>machine_state := ms\<rparr>) (s'\<lparr>machine_state := ms'\<rparr>))
          (K (P s \<and> P s')) f)
    \<Longrightarrow> equiv_valid I A B P (do_machine_op f)"
  apply (clarsimp simp: do_machine_op_def bind_def equiv_valid_def2 equiv_valid_2_def gets_def
                        get_def select_f_def modify_def put_def return_def split_def)
  apply atomize
  apply (erule_tac x=s in allE)
  apply (erule_tac x=t in allE)
  apply simp
  apply (erule_tac x="machine_state s" in allE)
  apply (erule_tac x="machine_state t" in allE)
  apply fastforce
  done

(* FIXME - move - duplicated in Schedule_IF *)
lemma ev_modify:
  "(\<And> s t. \<lbrakk>P s; P t; A s t; I s t\<rbrakk> \<Longrightarrow> (I (f s) (f t)) \<and> (B (f s) (f t)))
   \<Longrightarrow> equiv_valid I A B P (modify f)"
  apply (clarsimp simp add: equiv_valid_def2 equiv_valid_2_def simpler_modify_def)
  done

lemma dmo_setExMonitor_reads_respects_g:
  "reads_respects_g aag l \<top> (do_machine_op (setExMonitor es))"
  apply (simp add: setExMonitor_def)
  apply (wp dmo_ev ev_modify)
  apply (clarsimp simp: reads_equiv_g_def)
  apply (clarsimp simp: reads_equiv_def affects_equiv_def states_equiv_for_def equiv_for_def
                        equiv_asids_def equiv_asid_def globals_equiv_def idle_equiv_def
                 split: if_splits)
  done

lemma dmo_getExMonitor_reads_respects_g:
  "reads_respects_g aag l (\<lambda>s. cur_thread s \<noteq> idle_thread s) (do_machine_op getExMonitor)"
  apply (simp add: getExMonitor_def)
  apply (wp dmo_ev gets_ev'')
  apply (clarsimp simp: reads_equiv_g_def globals_equiv_def)
  done

lemma getExMonitor_wp[wp]:
  "\<lbrace>\<lambda>ms. P (exclusive_state ms) ms\<rbrace> getExMonitor \<lbrace>P\<rbrace>"
  by (simp add: getExMonitor_def | wp)+

lemma map_add_eq:
  "\<lbrakk>ms x = ms' x\<rbrakk> \<Longrightarrow> (ms ++ um) x = (ms' ++ um) x"
  by (clarsimp simp: map_add_def split: option.splits)

lemma dmo_device_state_update_reads_respects_g:
   "reads_respects_g aag l (\<lambda>s. dom um \<subseteq> device_region s) (do_machine_op (device_memory_update um))"
   apply (clarsimp simp: equiv_valid_def2 equiv_valid_2_def)
   apply (clarsimp simp: do_machine_op_def device_memory_update_def gets_def select_f_def
                        get_def bind_def in_monad)
   apply (clarsimp simp: reads_equiv_g_def globals_equiv_def split: option.splits)
   apply (subgoal_tac "reads_respects aag l \<top> (do_machine_op (device_memory_update um))")
    apply (fastforce simp: equiv_valid_def2 equiv_valid_2_def in_monad
                          do_machine_op_def device_memory_update_def select_f_def
                          idle_equiv_def)
   apply (rule use_spec_ev)
   apply (simp add: device_memory_update_def)
   apply (rule do_machine_op_spec_reads_respects)
    apply (simp add: equiv_valid_def2)
    apply (rule modify_ev2)
     apply (fastforce intro: map_add_eq equiv_forI elim: equiv_forE split: option.splits)
   apply (wp | simp)+
   done

lemma spec_equiv_valid_inv_gets:
  assumes proj_retain: "\<And>t. \<lbrakk>P st; P t; I st t; A st t\<rbrakk> \<Longrightarrow> proj (f st) = proj (f t)"
      and spec_eqv_valid: "spec_equiv_valid_inv st I A P (g (proj (f st)))"
  shows "spec_equiv_valid_inv st I A
           P (do r \<leftarrow> gets f; g (proj r) od)"
   apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def
     gets_def get_def bind_def return_def)
   apply (frule(3) proj_retain)
   apply (cut_tac spec_eqv_valid)
   apply (clarsimp simp: spec_equiv_valid_def equiv_valid_2_def
     gets_def get_def bind_def return_def)
   apply (drule spec)+
   apply (erule impE)
    apply fastforce
   apply fastforce
   done

lemmas spec_equiv_valid_inv_gets_more =
   spec_equiv_valid_inv_gets[where proj = "\<lambda>x. (proj x,projsnd x)"
     and g = "\<lambda>z. g (fst z) (snd z)"  for proj and projsnd and g,simplified]

lemmas spec_equiv_valid_inv_gets_triple =
   spec_equiv_valid_inv_gets_more[where projsnd = "\<lambda>x. (p (projsnd x) , p' (projsnd x))"
     and g = "\<lambda>a z. g a (fst z) (snd z)"  for projsnd and p and p' and g,simplified]

lemma restrict_eq_imp_dom_eq:
  "a |` r =  b|` r \<Longrightarrow> dom a \<inter> r = dom b \<inter> r"
  apply (clarsimp simp: set_eq_iff restrict_map_def)
  apply (drule_tac x = x in fun_cong)
  apply fastforce
  done

lemma restrict_map_eq_same_domain:
  "\<lbrakk>\<And>x. x\<in> dom a \<Longrightarrow> b x = c x\<rbrakk> \<Longrightarrow> a |` dom b = a |` dom c"
  apply (rule ext)
  apply (clarsimp simp: restrict_map_def)
  apply (intro conjI impI)
   apply fastforce
  apply (rule ccontr)
  apply (drule not_sym)
  apply fastforce
  done

lemma restrict_map_eq_same_domain_compl:
  "\<lbrakk>\<And>x. x\<in> dom a \<Longrightarrow> b x = c x\<rbrakk> \<Longrightarrow> a |` (- dom b) = a |` (- dom c)"
  apply (rule ext)
  apply (clarsimp simp: restrict_map_def)
  apply (intro conjI impI)
   apply fastforce
  apply (rule ccontr)
  apply (drule not_sym)
  apply fastforce
  done

lemma do_user_op_reads_respects_g:
  notes split_paired_All[simp del]
  shows
   "( \<forall>pl pr pxn tc um es ds s. P tc s \<and> context_matches_state pl pr pxn um ds es s
                           \<longrightarrow> (\<exists>x. uop (cur_thread s) pl pr pxn (tc, um, ds , es) = {x}))
   \<Longrightarrow> reads_respects_g aag l (pas_refined aag and invs and valid_pdpt_objs
                               and is_subject aag \<circ> cur_thread
                               and (\<lambda>s. cur_thread s \<noteq> idle_thread s) and P tc)
                (do_user_op_if uop tc)"
  apply (simp add: do_user_op_if_def)
  apply (rule use_spec_ev)
  apply (rule spec_equiv_valid_add_asm)
  apply (rule spec_equiv_valid_add_rel[OF _ reads_equiv_g_refl])
  apply (rule spec_equiv_valid_add_rel'[OF _ affects_equiv_refl])
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
    apply (clarsimp simp: reads_equiv_g_def)
    apply (rule requiv_ptable_rights_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
   apply (rule ext)
   apply (clarsimp simp: reads_equiv_g_def)
   apply (case_tac "ptable_rights_s st x = {}", simp)
    apply simp
    apply (rule requiv_ptable_xn_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
    apply (subst expand_restrict_map_eq,clarsimp)
    apply (clarsimp simp: reads_equiv_g_def)
    apply (rule requiv_ptable_lift_eq,simp+)[1]
  apply (rule spec_equiv_valid_inv_gets[where proj=id,simplified])
    apply (clarsimp simp: reads_equiv_g_def)
    apply (rule requiv_cur_thread_eq,fastforce)
  apply (rule spec_equiv_valid_inv_gets_more
    [where proj = "\<lambda>m. dom m \<inter> cw" and projsnd = "\<lambda>m. m|` cr" for cr and cw])
    apply (rule context_conjI')
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: reads_equiv_g_def restrict_map_def)
    apply (rule requiv_user_mem_eq)
      apply simp+
    apply fastforce
  apply (rule spec_equiv_valid_inv_gets[where proj = "\<lambda>x. ()",simplified])
  apply (rule spec_equiv_valid_inv_gets_more[where proj = "\<lambda>m. (m \<circ> ptrFromPAddr)|` cr" for cr])
   apply (rule conjI)
    apply (subst expand_restrict_map_eq)
    apply (clarsimp simp: restrict_map_def reads_equiv_g_def)
    apply (rule requiv_user_device_eq)
       apply simp+
    apply (clarsimp simp: globals_equiv_def reads_equiv_g_def)

  apply (rule spec_equiv_valid_guard_imp)
   apply (wp dmo_user_memory_update_reads_respects_g dmo_device_state_update_reads_respects_g
     dmo_setExMonitor_reads_respects_g dmo_device_state_update_reads_respects_g
     select_ev select_wp dmo_getExMonitor_reads_respects_g | wpc)+
   apply (wp dmo_wp)
   apply clarsimp
   apply (rule conjI)
    apply clarsimp
    apply (drule spec)+
    apply (erule impE)
    prefer 2
     apply assumption
    apply (clarsimp simp: context_matches_state_def comp_def  reads_equiv_g_def globals_equiv_def)
  apply (clarsimp simp: reads_equiv_g_def globals_equiv_def)
  done
end

end


(*  Title:      HOL/Auth/n_german_lemma_inv__58_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

(*header{*The n_german Protocol Case Study*}*)

theory n_german_lemma_inv__58_on_rules imports n_german_lemma_on_inv__58
begin
section{*All lemmas on causal relation between inv__58*}
lemma lemma_inv__58_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(\<exists> p__Inv0 p__Inv2. p__Inv0\<le>N\<and>p__Inv2\<le>N\<and>p__Inv0~=p__Inv2\<and>f=inv__58  p__Inv0 p__Inv2)"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_SendGntE N i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)\<or>
    (\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> i d. i\<le>N\<and>d\<le>N\<and>r=n_Store  i d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_StoreVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqSVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__0Vsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendReqE__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendReqE__part__1Vsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqS N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqSVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvReqE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvReqEVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__0  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__0Vsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInv__part__1  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInv__part__1Vsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendInvAckVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvInvAck  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvInvAckVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntSVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_SendGntE N i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_SendGntEVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntS  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntSVsinv__58) done
    }

    moreover {
      assume d1: "(\<exists> i. i\<le>N\<and>r=n_RecvGntE  i)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_RecvGntEVsinv__58) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


(*  Title:      HOL/Auth/n_g2kAbsAfter_lemma_inv__52_on_rules.thy
    Author:     Yongjian Li and Kaiqiang Duan, State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
    Copyright    2016 State Key Lab of Computer Science, Institute of Software, Chinese Academy of Sciences
*)

header{*The n_g2kAbsAfter Protocol Case Study*}

theory n_g2kAbsAfter_lemma_inv__52_on_rules imports n_g2kAbsAfter_lemma_on_inv__52
begin
section{*All lemmas on causal relation between inv__52*}
lemma lemma_inv__52_on_rules:
  assumes b1: "r \<in> rules N" and b2: "(f=inv__52  )"
  shows "invHoldForRule s f r (invariants N)"
  proof -
  have c1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)\<or>
    (\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)\<or>
    (r=n_n_SendReqS_j1  )\<or>
    (r=n_n_SendReqEI_i1  )\<or>
    (r=n_n_SendReqES_i1  )\<or>
    (r=n_n_RecvReq_i1  )\<or>
    (r=n_n_SendInvE_i1  )\<or>
    (r=n_n_SendInvS_i1  )\<or>
    (r=n_n_SendInvAck_i1  )\<or>
    (r=n_n_RecvInvAck_i1  )\<or>
    (r=n_n_SendGntS_i1  )\<or>
    (r=n_n_SendGntE_i1  )\<or>
    (r=n_n_RecvGntS_i1  )\<or>
    (r=n_n_RecvGntE_i1  )\<or>
    (r=n_n_ASendReqIS_j1  )\<or>
    (r=n_n_ASendReqSE_j1  )\<or>
    (r=n_n_ASendReqEI_i1  )\<or>
    (r=n_n_ASendReqES_i1  )\<or>
    (r=n_n_SendReqEE_i1  )\<or>
    (r=n_n_ARecvReq_i1  )\<or>
    (r=n_n_ASendInvE_i1  )\<or>
    (r=n_n_ASendInvS_i1  )\<or>
    (r=n_n_ASendInvAck_i1  )\<or>
    (r=n_n_ARecvInvAck_i1  )\<or>
    (r=n_n_ASendGntS_i1  )\<or>
    (r=n_n_ASendGntE_i1  )\<or>
    (r=n_n_ARecvGntS_i1  )\<or>
    (r=n_n_ARecvGntE_i1  )"
  apply (cut_tac b1, auto) done
    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_Store_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_Store_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(\<exists> d. d\<le>N\<and>r=n_n_AStore_i1  d)"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_AStore_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqS_j1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEI_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqES_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_RecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvReq_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendInvAck_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_RecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvInvAck_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendGntE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_RecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_RecvGntE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqIS_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqIS_j1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqSE_j1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqSE_j1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqEI_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqEI_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendReqES_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendReqES_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_SendReqEE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_SendReqEE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvReq_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvReq_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendInvAck_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvInvAck_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvInvAck_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ASendGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ASendGntE_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntS_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntS_i1Vsinv__52) done
    }

    moreover {
      assume d1: "(r=n_n_ARecvGntE_i1  )"
      have "invHoldForRule s f r (invariants N)"
      apply (cut_tac b2 d1, metis n_n_ARecvGntE_i1Vsinv__52) done
    }

  ultimately show "invHoldForRule s f r (invariants N)"
  by satx
qed

end


theory Analyze_Synology_Diskstation
imports iptables_Ln_tuned_parsed (*2014 firewall dump*)
  "../../Primitive_Matchers/Parser"
  "../../Primitive_Matchers/Parser6"
begin

section\<open>Example: Synology Diskstation 2014\<close>
text\<open>We analyze a dump of a NAS. The dump was created 2014. Unfortunately, we don't have an
      @{text "iptables-save"} dump from that time and have to rely on the @{text "iptables -L -n"}
      dump. This dump was translated by our legacy python importer.\<close>

text\<open>we removed the established,related rule\<close>
  definition "example_ruleset == firewall_chains(''INPUT'' \<mapsto>
    remove1 (Rule (MatchAnd (Match (Src (IpAddrNetmask 0 0)))
            (MatchAnd (Match (Dst (IpAddrNetmask 0 0)))
            (MatchAnd (Match (Prot (ProtoAny)))
            (Match (Extra (''state RELATED,ESTABLISHED'')))))) (action.Accept)) (the (firewall_chains ''INPUT'')))"

text\<open>Infix pretty-printing for @{const MatchAnd} and @{const MatchNot}.\<close>
abbreviation MatchAndInfix :: "'a match_expr \<Rightarrow> 'a match_expr \<Rightarrow> 'a match_expr" (infixr "MATCHAND" 65) where
  "MatchAndInfix m1 m2 \<equiv> MatchAnd m1 m2"
abbreviation MatchNotPrefix :: "'a match_expr \<Rightarrow> 'a match_expr" ("\<not> \<langle>_\<rangle>" 66) where
  "MatchNotPrefix m \<equiv> MatchNot m"
(*abbreviation MatchPrefix :: "'a \<Rightarrow> 'a match_expr" ("\<lozenge> _" 67) where (*This is too slow*)
  "MatchPrefix m \<equiv> Match m"*)
(*This syntax can be pretty confusing when mixing it with other theories. Do not use outside this example!*)

lemma "unfold_ruleset_INPUT action.Accept example_ruleset =
 [Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04''))
   action.Drop,
  Rule (\<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (Extra ''Prot icmp'') MATCHAND Match (Extra ''icmptype 8 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x04 limit: avg 1/sec burst 5'')\<rangle> MATCHAND
        \<not> \<langle>Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02 limit: avg 10000/sec burst 100'')\<rangle> MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp flags:0x17/0x02''))
   action.Drop,
  Rule (Match (Prot (Proto TCP)) MATCHAND Match (Extra ''tcp dpt:22'')) action.Drop,
  Rule (Match (Prot (Proto TCP)) MATCHAND Match (Extra ''multiport dports 21,873,5005,5006,80,548,111,2049,892''))
   action.Drop,
  Rule (Match (Prot (Proto UDP)) MATCHAND Match (Extra ''multiport dports 123,111,2049,892,5353'')) action.Drop,
  Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192, 168, 0, 0)) 16))) action.Accept, Rule MatchAny action.Drop,
  Rule MatchAny action.Accept, Rule MatchAny action.Accept]
  " by eval

  lemma "good_ruleset (unfold_ruleset_INPUT action.Accept example_ruleset)" by eval
  lemma "simple_ruleset (unfold_ruleset_INPUT action.Accept example_ruleset)" by eval

  text\<open>packets from the local LAN are allowed (@{const in_doubt_allow})\<close>
  lemma "approximating_bigstep_fun (common_matcher, in_doubt_allow)
    \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'', p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (8,8,8,8),
         p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {TCP_SYN}, p_payload='''', p_tag_ctstate = CT_New\<rparr>
        (unfold_ruleset_INPUT action.Accept example_ruleset)
        Undecided = Decision FinalAllow" by eval

  text\<open>However, they might also be rate-limited, ... (we don't know about icmp)\<close>
  lemma "approximating_bigstep_fun (common_matcher, in_doubt_deny)
    \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'', p_src = ipv4addr_of_dotdecimal (192,168,2,45), p_dst= ipv4addr_of_dotdecimal (8,8,8,8),
         p_proto=TCP, p_sport=2065, p_dport=80, p_tcp_flags = {TCP_SYN}, p_payload='''', p_tag_ctstate = CT_New\<rparr>
        (unfold_ruleset_INPUT action.Accept example_ruleset)
        Undecided = Decision FinalDeny" by eval

  text\<open>But we can guarantee that packets from the outside are blocked!\<close>
  lemma "approximating_bigstep_fun (common_matcher, in_doubt_allow)
    \<lparr>p_iiface = ''eth0'', p_oiface = ''eth1'', p_src = ipv4addr_of_dotdecimal (8,8,8,8), p_dst= 0, p_proto=TCP, p_sport=2065, p_dport=80,
     p_tcp_flags = {TCP_SYN}, p_payload='''', p_tag_ctstate = CT_New\<rparr>
        (unfold_ruleset_INPUT action.Accept example_ruleset)
        Undecided = Decision FinalDeny" by eval

text\<open>in doubt allow closure\<close>
lemma upper: "upper_closure (unfold_ruleset_INPUT action.Accept example_ruleset) =
  [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192, 168, 0, 0)) 16))) action.Accept,
   Rule MatchAny action.Drop]" by eval

text\<open>in doubt deny closure\<close>
lemma lower: "lower_closure (unfold_ruleset_INPUT action.Accept example_ruleset) =
 [Rule MatchAny action.Drop]" by eval

text\<open>upper closure\<close>
lemma "rmshadow (common_matcher, in_doubt_allow) (upper_closure (unfold_ruleset_INPUT action.Accept example_ruleset)) UNIV =
  [Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192, 168, 0, 0)) 16))) action.Accept, Rule MatchAny action.Drop]"
(*<*)apply(subst upper)
apply(subst rmshadow.simps)
apply(simp del: rmshadow.simps)
apply(simp add: Matching_Ternary.matches_def)
apply(intro conjI impI)
 apply(rule_tac x="undefined\<lparr>p_iiface := ''eth0'', p_oiface := ''eth1'',
                   p_src := ipv4addr_of_dotdecimal (8,8,8,8), p_dst := 0,
                   p_proto := TCP, p_sport:=2065, p_dport:=80\<rparr>" in exI)
 apply(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_alt mask_def; fail)
apply(thin_tac "\<exists>p. x p" for x)
apply(rule_tac x="undefined\<lparr>p_iiface := ''eth0'', p_oiface := ''eth1'',
                            p_src := ipv4addr_of_dotdecimal (192,168,8,8), p_dst:= 0,
                            p_proto:=TCP, p_sport:=2065, p_dport:=80\<rparr> " in exI)
apply(simp add: ipv4addr_of_dotdecimal.simps ipv4addr_of_nat_def ipset_from_cidr_alt mask_def; fail)
done(*>*)

text\<open>lower closure\<close>
lemma "rmshadow (common_matcher, in_doubt_deny) (lower_closure (unfold_ruleset_INPUT action.Accept example_ruleset)) UNIV =
  [Rule MatchAny action.Drop]"
apply(subst lower)
apply(subst rmshadow.simps)
apply(simp del: rmshadow.simps)
apply(simp add: Matching_Ternary.matches_def)
done

lemma "check_simple_fw_preconditions (upper_closure (unfold_ruleset_INPUT action.Accept example_ruleset))" by eval

value[code] "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (unfold_ruleset_INPUT action.Accept example_ruleset)))"
lemma "map simple_rule_ipv4_toString (to_simple_firewall (upper_closure (unfold_ruleset_INPUT action.Accept example_ruleset))) =
  [''ACCEPT     all  --  192.168.0.0/16            0.0.0.0/0    '',
   ''DROP     all  --  0.0.0.0/0            0.0.0.0/0    '']" by eval (*will break when simple_rule_ipv4_toString is changed*)

lemma "check_simple_fw_preconditions (lower_closure (unfold_ruleset_INPUT action.Accept example_ruleset))" by eval
value[code] "map simple_rule_ipv4_toString (to_simple_firewall (lower_closure (unfold_ruleset_INPUT action.Accept example_ruleset)))"

lemma "length (unfold_ruleset_INPUT action.Accept example_ruleset) = 19" by eval
text\<open>Wow, normalization has exponential(?) blowup here.\<close>
lemma "length (normalize_rules_dnf (unfold_ruleset_INPUT action.Accept example_ruleset)) = 259" by eval

section\<open>Synology Diskstation 2015\<close>
text\<open>This is a snapshot from 2015, available as @{text "iptables-save"} format. The firewall definition
      and structure has changed with various firmware updates to the device.
      Also, the new parser also parses ports and interfaces\<close>

parse_iptables_save ds2015_fw="iptables-save"

thm ds2015_fw_def
thm ds2015_fw_INPUT_default_policy_def

text\<open>this time, we don't removed the established,related rule\<close>

value[code] "unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw)"
lemma "unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw) =
[Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth1'')) MATCHAND Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth1'')) MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})))
   action.Drop,
  Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})) MATCHAND
           Match (Extra ''-m limit --limit 10000/sec --limit-burst 100'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth1'')) MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})))
   action.Drop,
  Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})) MATCHAND
           Match (Extra ''-m limit --limit 10000/sec --limit-burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth0'')) MATCHAND Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8''))
   action.Drop,
  Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})) MATCHAND
           Match (Extra ''-m limit --limit 10000/sec --limit-burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth0'')) MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})))
   action.Drop,
  Rule (\<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth1'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})) MATCHAND
           Match (Extra ''-m limit --limit 10000/sec --limit-burst 100'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto ICMP)) MATCHAND Match (Extra ''-m icmp --icmp-type 8 -m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_RST})) MATCHAND Match (Extra ''-m limit --limit 1/sec'')\<rangle> MATCHAND
        \<not> \<langle>Match (IIface (Iface ''eth0'')) MATCHAND
           Match (Prot (Proto TCP)) MATCHAND
           Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})) MATCHAND
           Match (Extra ''-m limit --limit 10000/sec --limit-burst 100'')\<rangle> MATCHAND
        Match (IIface (Iface ''eth0'')) MATCHAND
        Match (Prot (Proto TCP)) MATCHAND Match (L4_Flags (TCP_Flags {TCP_FIN, TCP_SYN, TCP_RST, TCP_ACK} {TCP_SYN})))
   action.Drop,
  Rule (Match (IIface (Iface ''lo''))) action.Accept, Rule (Match (CT_State {CT_Related, CT_Established})) action.Accept,
  Rule (Match (IIface (Iface ''eth0'')) MATCHAND Match (Prot (Proto TCP)) MATCHAND Match (Dst_Ports (L4Ports TCP [(0x16, 0x16)]))) action.Drop,
  Rule (Match (IIface (Iface ''eth0'')) MATCHAND
        Match (Prot (Proto TCP)) MATCHAND
        Match (Dst_Ports (L4Ports TCP
                [(0x15, 0x15), (0x369, 0x369), (0x138D, 0x138D), (0x138E, 0x138E), (0x50, 0x50), (0x224, 0x224), (0x6F, 0x6F), (0x37C, 0x37C),
                 (0x801, 0x801)])))
   action.Drop,
  Rule (Match (IIface (Iface ''eth0'')) MATCHAND
        Match (Prot (Proto UDP)) MATCHAND Match (Dst_Ports (L4Ports UDP [(0x7B, 0x7B), (0x6F, 0x6F), (0x37C, 0x37C), (0x801, 0x801), (0x14E9, 0x14E9)])))
   action.Drop,
  Rule (Match (Src (IpAddrNetmask (ipv4addr_of_dotdecimal (192, 168, 0, 0)) 16)) MATCHAND Match (IIface (Iface ''eth0''))) action.Accept,
  Rule (Match (IIface (Iface ''eth0''))) action.Drop, Rule MatchAny action.Accept]" by eval

value[code] "map common_primitive_rule_toString (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw))"

value[code] "(upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw))))"

value[code] "optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw))))"

value[code] "upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw)))"

lemma "check_simple_fw_preconditions (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw))))))" by eval

value[code] "map simple_rule_ipv4_toString (to_simple_firewall
              (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw)))))))"
lemma "simple_fw_valid (to_simple_firewall
              (upper_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw)))))))" by eval
lemma "simple_fw_valid (to_simple_firewall
              (lower_closure (optimize_matches abstract_for_simple_firewall (upper_closure (packet_assume_new (unfold_ruleset_INPUT ds2015_fw_INPUT_default_policy (map_of ds2015_fw)))))))" by eval

parse_iptables_save ds2015_2_fw="iptables-save_jun_2015_cleanup"
text\<open>In 2015 there was also an update and a cleanup of the ruleset.
The following should be fulfilled:
Port 80 globally blocked (fulfilled, only reachable by localhost).
Port 22 globally blocked (not fulfilled, error in the ruleset).
Port 8080 only reachable from 192.168.0.0/24 and localhost (fulfilled).
\<close>

value[code] "unfold_ruleset_INPUT ds2015_2_fw_INPUT_default_policy (map_of ds2015_2_fw)"

lemma "access_matrix_pretty_ipv4 parts_connection_ssh
        (to_simple_firewall_without_interfaces ipassmt_generic_ipv4 None
          (unfold_ruleset_INPUT ds2015_2_fw_INPUT_default_policy (map_of ds2015_2_fw))) =
  ([(''0.0.0.0'', ''{0.0.0.0 .. 255.255.255.255}'')
   ],
   [(''0.0.0.0'', ''0.0.0.0'')])" by eval

lemma "access_matrix_pretty_ipv4 parts_connection_http
        (to_simple_firewall_without_interfaces ipassmt_generic_ipv4 None
          (unfold_ruleset_INPUT ds2015_2_fw_INPUT_default_policy (map_of ds2015_2_fw))) =
  ([(''0.0.0.0'', ''{0.0.0.0 .. 126.255.255.255} u {128.0.0.0 .. 255.255.255.255}''),
    (''127.0.0.0'', ''{127.0.0.0 .. 127.255.255.255}'')
   ],
   [(''127.0.0.0'', ''0.0.0.0''),
    (''127.0.0.0'', ''127.0.0.0'')])" by eval

lemma "access_matrix_pretty_ipv4 (mk_parts_connection_TCP 10000 8080)
        (to_simple_firewall_without_interfaces ipassmt_generic_ipv4 None
          (unfold_ruleset_INPUT ds2015_2_fw_INPUT_default_policy (map_of ds2015_2_fw))) =
  ([(''127.0.0.0'', ''{127.0.0.0 .. 127.255.255.255} u {192.168.0.0 .. 192.168.255.255}''),
    (''0.0.0.0'', ''{0.0.0.0 .. 126.255.255.255} u {128.0.0.0 .. 192.167.255.255} u {192.169.0.0 .. 255.255.255.255}'')
   ],
   [(''127.0.0.0'', ''127.0.0.0''),
    (''127.0.0.0'', ''0.0.0.0'')])" by eval

text\<open>The 2016 version with IPv6 is very interesting.
 Some source ports for UDP are just allowed.
 Is this a typo? The original structure with the @{const Return}s is very complicated.
 Here is what is actually dropped and accepted:\<close>
parse_ip6tables_save ds_2016_ipv6 = "ip6tables-save_jul_2016" (*5s*)

lemma "map simple_rule_ipv6_toString
              (to_simple_firewall (upper_closure
                (optimize_matches abstract_for_simple_firewall
                  (upper_closure (packet_assume_new
                    (unfold_ruleset_FORWARD ds_2016_ipv6_FORWARD_default_policy
                      (map_of ds_2016_ipv6))))))) =
[ ''ACCEPT     all  --  ::/0            ::/0 in: lo   '',
  ''ACCEPT     ipv6-icmp  --  fe80::/10            ::/0    '',
  ''DROP     tcp  --  ::/0            ::/0    dports: 21'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 873'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 631'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 515'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 3260:3262'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 22:23'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 548'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 3493'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 3306'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 67:68'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 123'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 514'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 161'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 19999'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 5353'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 67:68'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 123'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 514'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 161'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 19999'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 5353'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 67:68'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 123'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 514'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 161'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 19999'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 5353'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 67:68'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 123'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 514'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 161'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 19999'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 5353'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 111'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 892'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 2049'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 111'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 892'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 2049'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 111'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 892'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 2049'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 111'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 892'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 2049'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 111'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 892'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 2049'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 0:79'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 81:442'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 444:9024'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 9041:50000'',
  ''DROP     tcp  --  ::/0            ::/0    dports: 50003:65535'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0   sports: 0:5001 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5003 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0   sports: 5005:65000 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0   sports: 65002:65535 dports: 65002:65535'',
  (*The following eth0 rules are shadowed*)
  ''DROP     tcp  --  ::/0            ::/0 in: eth0   dports: 0:79'',
  ''DROP     tcp  --  ::/0            ::/0 in: eth0   dports: 81:442'',
  ''DROP     tcp  --  ::/0            ::/0 in: eth0   dports: 444:9024'',
  ''DROP     tcp  --  ::/0            ::/0 in: eth0   dports: 9041:50000'',
  ''DROP     tcp  --  ::/0            ::/0 in: eth0   dports: 50003:65535'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 0:5001 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 0:5001 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 0:5001 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 0:5001 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 0:5001 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5003 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5003 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5003 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5003 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5003 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5005:65000 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5005:65000 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5005:65000 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5005:65000 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 5005:65000 dports: 65002:65535'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 65002:65535 dports: 0:1899'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 65002:65535 dports: 1901:5001'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 65002:65535 dports: 5003'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 65002:65535 dports: 5005:65000'',
  ''DROP     udp  --  ::/0            ::/0 in: eth0  sports: 65002:65535 dports: 65002:65535'',
  ''ACCEPT     all  --  ::/0            ::/0    '']"
by eval (*50s*)

end