Require Import Bool Arith List Omega ListSet.
Require Import Recdef Morphisms.
Require Import Program.Tactics.
Require Import Relation_Operators.
Require FMapList.
Require FMapFacts.
Require Import Classical.
Require Import Coq.Classes.RelationClasses.
Require Import OrderedType OrderedTypeEx DecidableType.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Sorting.Permutation.
Import ListNotations.
Require Import SImpECommon.

(*******************************************************************************
*
* SYNTAX
*
*******************************************************************************)

Section Syntax.
  Definition enclave : Type := nat.
  Inductive mode : Type :=
  | Normal : mode
  | Encl : enclave -> mode.

  Inductive exp : Type :=
  | Enat : nat -> exp
  | Evar : var -> exp
  | Eadd : exp -> exp -> exp
  | Eloc : location -> exp
  | Ederef : exp -> exp
  | Elambda : mode -> com -> exp

  with com : Type :=
  | Cskip : com
  | Cassign : var -> exp -> com
  | Cdeclassify : var -> exp -> com
  | Cupdate : exp -> exp -> com
  | Coutput : exp -> sec_level -> com
  | Ccall : exp -> com
  | Cenclave : enclave -> com -> com
  | Cseq : list com -> com
  | Cif : exp -> com -> com -> com
  | Cwhile : exp -> com -> com.

  Inductive val : Type :=
  | Vlambda : mode -> com -> val
  | Vnat : nat -> val
  | Vloc : location -> val.

  Function forall_subexp (e: exp) (P: exp -> Prop) : Prop :=
    P e /\
    match e with
    | Eadd e1 e2 => forall_subexp e1 P /\ forall_subexp e2 P
    | Ederef e' => forall_subexp e' P
    | Elambda _ c => forall_subexp' c P
    | _ => True
    end
  with forall_subexp' (c: com) (P: exp -> Prop) : Prop :=
    match c with
    | Cassign _ e => forall_subexp e P
    | Cdeclassify _ e => forall_subexp e P
    | Cupdate e1 e2 => forall_subexp e1 P /\ forall_subexp e2 P
    | Ccall e => forall_subexp e P
    | Cenclave _ c' => forall_subexp' c' P
    | Cseq cs => fold_left (fun acc c => forall_subexp' c P /\ acc) cs True
    | Cif e c1 c2 =>
      forall_subexp e P /\ forall_subexp' c1 P /\ forall_subexp' c2 P
    | Cwhile e c' => forall_subexp e P /\ forall_subexp' c' P
    | _ => True
    end.

  Definition exp_novars (e: exp) : Prop :=
    forall_subexp e (fun e =>
                       match e with
                       | Evar _ => False
                       | _ => True
                       end).

End Syntax.

Section Induction.
  Variable P : com -> Type.
  Variable P0: exp -> Type.

  Inductive Forall' (Q : com -> Type) : list com -> Type :=
  | Forall_nil' : Forall' Q nil
  | Forall_cons' : forall x l, Q x -> Forall' Q l -> Forall' Q (x::l).

  Hypothesis Enat_case : forall n, P0 (Enat n).
  Hypothesis Evar_case : forall x, P0 (Evar x).
  Hypothesis Eadd_case : forall e1 e2,
      P0 e1 -> P0 e2 -> P0 (Eadd e1 e2).
  Hypothesis Eloc_case : forall l, P0 (Eloc l).
  Hypothesis Ederef_case : forall e,
      P0 e -> P0 (Ederef e).
  Hypothesis Elambda_case : forall md c,
      P c -> P0 (Elambda md c).

  Hypothesis Cskip_case : P Cskip.
  Hypothesis Cassign_case : forall x e,
      P0 e -> P (Cassign x e).
  Hypothesis Cdeclassify_case : forall x e,
      P0 e -> P (Cdeclassify x e).
  Hypothesis Cupdate_case : forall e1 e2,
      P0 e1 -> P0 e2 -> P (Cupdate e1 e2).
  Hypothesis Coutput_case : forall e sl,
      P0 e -> P (Coutput e sl).
  Hypothesis Ccall_case : forall e,
      P0 e -> P (Ccall e).
  Hypothesis Cenclave_case : forall enc c,
      P c -> P (Cenclave enc c).
  Hypothesis Cseq_case : forall coms,
      Forall' P coms -> P (Cseq coms).
  Hypothesis Cif_case : forall e c1 c2,
      P0 e -> P c1 -> P c2 -> P (Cif e c1 c2).
  Hypothesis Cwhile_case : forall e c,
      P0 e -> P c -> P (Cwhile e c).

  Fixpoint com_rect' (c: com) : P c :=
    match c with
    | Cskip => Cskip_case
    | Cassign x e => Cassign_case x e (exp_rect' e)
    | Cdeclassify x e => Cdeclassify_case x e (exp_rect' e)
    | Cupdate e1 e2 => Cupdate_case e1 e2 (exp_rect' e1) (exp_rect' e2)
    | Coutput e sl => Coutput_case e sl (exp_rect' e)
    | Ccall e => Ccall_case e (exp_rect' e)
    | Cenclave enc c => Cenclave_case enc c (com_rect' c)
    | Cseq coms =>
      Cseq_case coms
                ((fix com_list_rect (coms: list com) : Forall' P coms :=
                    match coms with
                    | [] => Forall_nil' P
                    | h :: t => Forall_cons' P h t (com_rect' h) (com_list_rect t)
                    end) coms)
    | Cif e c1 c2 =>
      Cif_case e c1 c2 (exp_rect' e) (com_rect' c1) (com_rect' c2)
    | Cwhile e c => Cwhile_case e c (exp_rect' e) (com_rect' c)
    end

  with
  exp_rect' (e: exp) : P0 e :=
    match e with
    | Enat n => Enat_case n
    | Evar x => Evar_case x
    | Eadd e1 e2 => Eadd_case e1 e2 (exp_rect' e1) (exp_rect' e2)
    | Eloc l => Eloc_case l
    | Ederef e => Ederef_case e (exp_rect' e)
    | Elambda md c => Elambda_case md c (com_rect' c)
    end.

End Induction.

Section Decidability.

  Ltac auto_decide :=
    try match goal with
        | [x : nat, y : nat |- _] => destruct (Nat.eq_dec x y)
        | [x : var, y : var |- _] => destruct (Nat.eq_dec x y)
        | [x : enclave, y : enclave |- _] => destruct (Nat.eq_dec x y)
        | [x : location, y : location |- _] => destruct (Nat.eq_dec x y)
        | _ => idtac
        end; [left; now subst | right; congruence].

   Ltac easy_dec :=
     subst; auto; right; congruence.

  Lemma mode_decidable : forall m1 m2 : mode, {m1 = m2} + {m1 <> m2}.
  Proof.
    intros; destruct m1; destruct m2; try (right; discriminate).
    - left; auto.
    - destruct (Nat.eq_dec e e0); [left; now subst | right; congruence].
  Qed.

   Lemma exp_decidable : forall (e1 e2 : exp), {e1 = e2} + {e1 <> e2}.
  Proof.
    intro.
    induction e1 using exp_rect' with
    (P := fun c1 =>
            forall c2, {c1 = c2} + {c1 <> c2}); intros.
    1-6: destruct e2; try (right; discriminate).
    7-14,16: destruct c2; try (right; discriminate).
    1-2, 4: auto_decide.
    - destruct IHe1_1 with e2_1; destruct IHe1_2 with e2_2; easy_dec.
    - destruct IHe1 with e2; easy_dec.
    - destruct IHe1 with c0; destruct (mode_decidable md m); easy_dec.
    - auto.
    - destruct IHe1 with e; subst; [auto_decide | right; congruence].
    - destruct IHe1 with e; subst; [auto_decide | right; congruence].
    - destruct IHe1_1 with e; destruct IHe1_2 with e0; easy_dec.
    - destruct s; destruct sl; destruct IHe1 with e; easy_dec.
    - destruct IHe1 with e; easy_dec.
    - destruct IHe1 with c2; subst; [auto_decide | right; congruence].
    - generalize l; induction coms; intros; destruct l0; try (right; discriminate); auto.
      inversion X; subst.
      destruct X0 with c; try (right; congruence).
      apply IHcoms with (l := l0) in X1.
      destruct X1; subst.
      + left; inversion e0; subst; auto.
      + right; congruence.
    - destruct IHe1 with e; destruct IHe0 with c2; easy_dec.
    - destruct c0; try (right; discriminate).
      destruct IHe1 with e; destruct IHe0 with c0_1; destruct IHe2 with c0_2; easy_dec.
  Qed.

  Lemma com_decidable : forall (c1 c2 : com), {c1 = c2} + {c1 <> c2}.
  Proof.
    intro.
    induction c1 using com_rect' with
    (P0 := fun e1 =>
             forall e2, {e1 = e2} + {e1 <> e2}); intros.
    1-2, 4-6: destruct e2; try (right; discriminate).
    7-16: destruct c2; try (right; discriminate).
    1-3: auto_decide.
    - destruct IHc1 with e2; easy_dec.
    - destruct IHc1 with c; destruct (mode_decidable md m); easy_dec.
    - destruct e0; try (right; discriminate);
        destruct IHc1 with e0_1; destruct IHc0 with e0_2; easy_dec.
    - auto.
    - destruct IHc1 with e0; subst; [auto_decide | right; congruence].
    - destruct IHc1 with e0; subst; [auto_decide | right; congruence].
    - destruct IHc1 with e; destruct IHc0 with e0; easy_dec.
    - destruct s; destruct sl; destruct IHc1 with e0; easy_dec.
    - destruct IHc1 with e0; easy_dec.
    - destruct IHc1 with c2; subst; [auto_decide | right; congruence].
    - generalize l; induction coms; intros; destruct l0; try (right; discriminate); auto.
      inversion X; subst.
      destruct X0 with c; try (right; congruence).
      apply IHcoms with (l := l0) in X1.
      destruct X1; subst.
      + left; inversion e0; subst; auto.
      + right; congruence.
    - destruct IHc1_1 with e0; destruct IHc1_2 with c2_1; destruct IHc1_3 with c2_2; easy_dec.
    - destruct IHc1 with e0; destruct IHc0 with c2; easy_dec.
  Qed.

  Lemma val_decidable : forall (v1 v2 : val), {v1 = v2} + {v1 <> v2}.
  Proof.
    intro.
    induction v1; intros; destruct v2; try (right; discriminate); try auto_decide.
    destruct (mode_decidable m m0); destruct (com_decidable c c0); easy_dec.
  Qed.

  Lemma prog_decidable : forall p1 p2 : (com + exp), {p1 = p2} + {p1 <> p2}.
  Proof.
    intros; destruct p1; destruct p2; try (right; discriminate);
      [destruct (com_decidable c c0) | destruct (exp_decidable e e0)]; easy_dec.
  Qed.

  Lemma mode_prog_decidable : forall ep1 ep2 : (mode * (com + exp)), {ep1 = ep2} + {ep1 <> ep2}.
  Proof.
    intros; destruct ep1, ep2; destruct (mode_decidable m m0); destruct (prog_decidable s s0);
      easy_dec.
  Qed.

End Decidability.

(*******************************************************************************
*
* ENCLAVE EQUIVALENCE
*
*******************************************************************************)

Section Enclave_Equiv.
  Fixpoint chi (c : com) : set (mode * (com + exp)) :=
  let chi_exp :=
      (fix chi_exp (e : exp) : set (mode * (com + exp)) :=
         match e with
         | Eadd e1 e2 => set_union mode_prog_decidable (chi_exp e1) (chi_exp e2)
         | Ederef e1 => chi_exp e1
         | Elambda Normal c => chi c
         | Elambda m _ => set_add mode_prog_decidable (m, inr e) nil
         | _ => nil
         end)

  in
  match c with
  | Cassign _ e => chi_exp e
  | Cdeclassify _ e => chi_exp e
  | Cupdate e1 e2 => set_union mode_prog_decidable (chi_exp e1) (chi_exp e2)
  | Coutput e _ => chi_exp e
  | Ccall e => chi_exp e
  | Cenclave enc c1 => set_add mode_prog_decidable (Encl enc, inl c1) nil
  | Cseq c_lst => fold_left (fun acc elt => set_union mode_prog_decidable (chi elt) acc) c_lst nil
  | Cif e c1 c2 => set_union mode_prog_decidable (chi_exp e)
                            (set_union mode_prog_decidable (chi c1) (chi c2))
  | _ => nil
  end.

  Definition enc_equiv (c1 c2 : com) := chi c1 = chi c2 -> Prop.

End Enclave_Equiv.

(*******************************************************************************
*
* SEMANTICS
*
*******************************************************************************)

Section Semantics.
  Definition reg : Type := register val.
  Definition reg_init : reg := fun x => Vnat 0.
  Definition mem : Type := memory val.
  Definition loc_mode : Type := location -> mode.

  Inductive event : Type :=
  | Decl : exp -> mem -> event
  | Mem : mem -> event
  | Out : sec_level -> val -> event
  | Update : mem -> location -> val -> event
  | Assign : reg -> var -> val -> event
  | ANonEnc : com -> event
  | AEnc : forall c c' : com, enc_equiv c c'-> event
  | Emp: event.
  Definition trace : Type := list event.
  (* Adding empty to the front of a trace doesn't change it *)
  Axiom emp_eq : forall t,
      Emp :: t = t.

  Definition mode_access_ok (md: mode) (d: loc_mode) (l: location) :=
    let lmd := d l in
    match lmd with
    | Normal => True
    | Encl _ => md = lmd
    end.

  Definition econfig : Type := exp * reg * mem.
  Definition ecfg_exp (ecfg: econfig) : exp :=
    match ecfg with (e, _, _) => e end.
  Definition ecfg_reg (ecfg: econfig) : reg :=
    match ecfg with (_, r, _) => r end.
  Definition ecfg_update_exp (ecfg: econfig) (e: exp) : econfig :=
    match ecfg with (_, r, m) => (e, r, m) end.
  Definition esemantics : Type := mode -> loc_mode -> econfig -> val -> Prop.

  Inductive estep : esemantics :=
  | Estep_nat : forall md d ecfg n,
      ecfg_exp ecfg = Enat n ->
      estep md d ecfg (Vnat n)
  | Estep_loc : forall md d ecfg l,
      ecfg_exp ecfg = Eloc l ->
      estep md d ecfg (Vloc l)
  | Estep_lambda : forall md d ecfg c,
      ecfg_exp ecfg = Elambda md c ->
      estep md d ecfg (Vlambda md c)
  | Estep_var : forall md d ecfg x v,
      ecfg_exp ecfg = Evar x ->
      ecfg_reg ecfg x = v ->
      estep md d ecfg v
  | Estep_add : forall md d ecfg e1 e2 n1 n2,
      ecfg_exp ecfg = Eadd e1 e2 ->
      estep md d (ecfg_update_exp ecfg e1) (Vnat n1) ->
      estep md d (ecfg_update_exp ecfg e2) (Vnat n2) ->
      estep md d ecfg (Vnat (n1 + n2))
  | Estep_deref : forall md d ecfg e r m l v,
      ecfg = (Ederef e, r, m) ->
      estep md d (e, r, m) (Vloc l) ->
      m l = v ->
      mode_access_ok md d l ->
      estep md d ecfg v.
  Hint Constructors estep.

  (* Semantics for commands. *)
  Definition cconfig : Type := com * reg * mem              .
  Definition cterm : Type := reg * mem              .
  Definition ccfg_com (ccfg: cconfig) : com :=
    match ccfg with (c, _, _) => c end.
  Definition ccfg_reg (ccfg: cconfig) : reg :=
    match ccfg with (_, r, _) => r end.
  Definition ccfg_mem (ccfg: cconfig) : mem :=
    match ccfg with (_, _, m) => m end.
  Definition ccfg_update_mem (ccfg: cconfig) (l: location) (v: val) : mem :=
    fun loc => if loc =? l then v
               else (ccfg_mem ccfg) loc.
  Definition ccfg_update_reg (ccfg: cconfig) (x: var) (v: val) : reg :=
    fun var => if var =? x then v
               else (ccfg_reg ccfg) var.
  Definition ccfg_to_ecfg (e: exp) (ccfg : cconfig) : econfig :=
    (e, (ccfg_reg ccfg), (ccfg_mem ccfg)).
  Definition ccfg_update_com (c: com) (ccfg : cconfig) : cconfig :=
    (c, (ccfg_reg ccfg), (ccfg_mem ccfg)).
  Definition csemantics : Type := mode -> loc_mode -> cconfig -> cterm -> trace -> Prop.

  Inductive cstep : csemantics :=
  | Cstep_skip : forall md d ccfg,
      ccfg_com ccfg = Cskip ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  | Cstep_assign : forall md d ccfg x e v r',
      ccfg_com ccfg = Cassign x e ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      r' = ccfg_update_reg ccfg x v ->
      cstep md d ccfg (r', ccfg_mem ccfg) [Assign (ccfg_reg ccfg) x v]
  | Cstep_declassify : forall md d ccfg x e v r',
      ccfg_com ccfg = Cdeclassify x e ->
      exp_novars e ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      r' = ccfg_update_reg ccfg x v ->
      cstep md d ccfg (r', ccfg_mem ccfg) [Decl e (ccfg_mem ccfg)]
  | Cstep_update : forall md d ccfg e1 e2 l v m',
      ccfg_com ccfg = Cupdate e1 e2 ->
      estep md d (ccfg_to_ecfg e1 ccfg) (Vloc l) ->
      estep md d (ccfg_to_ecfg e2 ccfg) v ->
      m' = ccfg_update_mem ccfg l v ->
      cstep md d ccfg (ccfg_reg ccfg, m') [Update (ccfg_mem ccfg) l v]
  | Cstep_output : forall md d ccfg e sl v,
      ccfg_com ccfg = Coutput e sl ->
      estep md d (ccfg_to_ecfg e ccfg) v ->
      sl = L \/ sl = H ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) [Mem (ccfg_mem ccfg); Out sl v]
  | Cstep_call : forall md d ccfg e c r' m' tr,
      ccfg_com ccfg = Ccall e ->
      estep md d (ccfg_to_ecfg e ccfg) (Vlambda md c) ->
      cstep md d (ccfg_update_com c ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_enclave : forall md d ccfg enc c r' m' tr,
    md = Normal ->
    ccfg_com ccfg = Cenclave enc c ->
    cstep (Encl enc) d (c, ccfg_reg ccfg, ccfg_mem ccfg) (r', m') tr ->
    cstep md d ccfg (r', m') tr
  | Cstep_seq_nil : forall md d ccfg,
      ccfg_com ccfg = Cseq [] ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  | Cstep_seq_hd : forall md d ccfg hd tl r m tr r' m' tr' t,
      ccfg_com ccfg = Cseq (hd::tl) ->
      cstep md d (ccfg_update_com hd ccfg) (r, m) tr ->
      cstep md d (Cseq tl, r, m) (r', m') tr' ->
      t = tr ++ tr' ->
      cstep md d ccfg (r', m') t
  | Cstep_if : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com ccfg = Cif e c1 c2 ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 1) ->
      cstep md d (ccfg_update_com c1 ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_else : forall md d ccfg e c1 c2 r' m' tr,
      ccfg_com ccfg = Cif e c1 c2 ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 0) ->
      cstep md d (ccfg_update_com c2 ccfg) (r', m') tr ->
      cstep md d ccfg (r', m') tr
  | Cstep_while_t : forall md d ccfg e c r m tr r' m' tr',
      ccfg_com ccfg = Cwhile e c ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 1) ->
      cstep md d (ccfg_update_com c ccfg) (r, m) tr ->
      cstep md d (Cwhile e c,r,m) (r', m') tr' ->
      cstep md d ccfg (r', m') (tr++tr')
  | Cstep_while_f : forall md d ccfg e c,
      ccfg_com ccfg = Cwhile e c ->
      estep md d (ccfg_to_ecfg e ccfg) (Vnat 0) ->
      cstep md d ccfg (ccfg_reg ccfg, ccfg_mem ccfg) []
  .
  Hint Constructors cstep.

  Inductive cstep_n_chaos : csemantics :=
  | Nchaos_cstep : forall md d ccfg cterm t,
      cstep md d ccfg cterm t -> cstep_n_chaos md d ccfg cterm t
  | Nchaos_chaos : forall d ccfg cterm c' t' (HEncEq : enc_equiv (ccfg_com ccfg) c'),
      cstep Normal d (c', ccfg_reg ccfg, ccfg_mem ccfg) cterm t' ->
      cstep_n_chaos Normal d ccfg cterm
                    (Mem (ccfg_mem ccfg) :: AEnc (ccfg_com ccfg) c' HEncEq :: t').
End Semantics.

(*******************************************************************************
*
* TYPING
*
*******************************************************************************)

Section Typing.

  Inductive ref_type : Set :=
  | Mut
  | Immut.

  Inductive base_type : Type :=
  | Tnat : base_type
  | Tref : type -> mode -> ref_type -> base_type
  | Tlambda (G: var -> option type) (p: sec_level) (md: mode) (G': var -> option type) : base_type

  with type : Type :=
       | Typ : base_type -> sec_level -> type.

  Definition context : Type := var -> option type.
  Parameter Loc_Contxt : location -> option (type * ref_type).

  Lemma var_in_dom_dec : forall (G : context) x, {exists t, G x = Some t} + {G x = None}.
  Proof.
    intros. destruct G. simpl.
    left; now exists t. right; auto.
  Qed.

  Lemma loc_in_dom_dec : forall l, {exists t rt, Loc_Contxt l = Some (t, rt)}
                                     + {Loc_Contxt l = None}.
  Proof.
    intros. simpl. destruct (Loc_Contxt l). destruct p.
    left; exists t; exists r; auto. right; auto.
  Qed.

  Definition forall_loc (P: location -> type -> ref_type -> Prop) : Prop :=
    forall l t rt, Loc_Contxt l = Some (t, rt) -> P l t rt.

  Definition forall_dom (G: context) (P: var -> type -> Prop) : Prop :=
       forall x t, G x = Some t -> P x t.

  Inductive type_le : type -> type -> Prop :=
  | Type_le : forall s1 s2 p1 p2,
      base_type_le s1 s2 ->
      sec_level_le p1 p2 ->
      type_le (Typ s1 p1) (Typ s2 p2)

  with base_type_le : base_type -> base_type -> Prop :=
  | Base_type_le_refl : forall s, base_type_le s s
  | Base_type_le_lambda : forall G1 G1' G2 G2' p1 p2 md,
      sec_level_le p2 p1 ->
      context_le G2 G1 ->
      context_le G1' G2' ->
      base_type_le (Tlambda G1 p1 md G1')
                   (Tlambda G2 p2 md G2')

  with context_le : context -> context -> Prop :=
  (* for right now, let's not assume that the domains are equal *)
  | Context_le : forall G1 G2,
      (forall x t,
          G1 x = Some t ->
          (* G2 must either not use the variable or have a greater type *)
          (G2 x = None \/ exists t', G2 x = Some t' /\ type_le t t')) ->
      (forall x t',
          G2 x = Some t' -> exists t, G1 x = Some t /\ type_le t t') ->
      context_le G1 G2.

  Lemma context_le_refl : forall G, context_le G G.
  Proof.
    intros. apply Context_le. intros. right; exists t; destruct t; auto.
    split; auto. apply Type_le. apply Base_type_le_refl. apply sec_level_le_refl.
    intros; exists t'; split; auto; destruct t'; auto.
    apply Type_le. apply Base_type_le_refl. apply sec_level_le_refl.
  Qed.

  Definition is_var_low_context (G: context) : Prop :=
    forall_dom G (fun _ t => let (_, p) := t in p = L).

  Function loc_in_exp (e: exp) (l: location) : Prop :=
    match e with
    | Eloc l' => l = l'
    | Ederef e' => loc_in_exp e' l
    | Eadd e1 e2 => loc_in_exp e1 l \/ loc_in_exp e2 l
    | _ => False
    end.

  Definition exp_locs_immutable (e: exp) :=
    forall_subexp e (fun e =>
                       match e with
                       | Eloc n => set_In n (immutable_locs g0)
                       | _ => True
                       end).

  Axiom Loc_Contxt_wt : forall d,
    forall_loc (fun l t _ =>
                  let (_, p) := t in
                  (p = H -> d l <> Normal)).

  Inductive val_type : mode -> context -> loc_mode -> val -> type -> Prop :=
  | VTnat: forall md g d n q,
      val_type md g d (Vnat n) (Typ Tnat q)
  | VTloc: forall md g d l md' t rt q,
      d l = md' ->
      Loc_Contxt l = Some (t, rt) ->
      val_type md g d (Vloc l) (Typ (Tref t md' rt) q)
  | VTlambda : forall md g d c p g' g'' q md0,
      com_type p md g' d c g'' ->
      val_type md0 g d (Vlambda md c) (Typ (Tlambda g' p md g'') q)
  | VTvar : forall md g d x r bt p v,
      g x = Some (Typ bt p) ->
      r x = v ->
      val_type md g d v (Typ bt p)
  | VTmem : forall md g d md' p rt q m l v bt,
      m l = v ->
      val_type md g d (Vloc l) (Typ (Tref (Typ bt p) md' rt) q) ->
      val_type md g d v (Typ bt (sec_level_join p q))
  | VTbinop : forall md g d n1 n2 p q op,
      val_type md g d (Vnat n1) (Typ Tnat p) ->
      val_type md g d (Vnat n2) (Typ Tnat q) ->
      val_type md g d (Vnat (op n1 n2)) (Typ Tnat (sec_level_join p q))

  with exp_type : mode -> context -> loc_mode -> exp -> type -> Prop :=
  | ETnat : forall md g d n,
      exp_type md g d (Enat n) (Typ Tnat (L))
  | ETvar : forall md g d x t,
      g x = Some t ->
      exp_type md g d (Evar x) t
  | ETloc : forall md g d l md' t rt,
      d l = md' ->
      Loc_Contxt l = Some (t, rt) ->
      exp_type md g d (Eloc l) (Typ (Tref t md' rt) (L))
  | ETderef : forall md g d e md' s p rt q,
      exp_type md g d e (Typ (Tref (Typ s p) md' rt) q) ->
      md' = Normal \/ md' = md ->
      exp_type md g d (Ederef e) (Typ s (sec_level_join p q))
  | ETlambda : forall md g d c p g' g'',
      com_type p md g' d c g''->
      exp_type md g d (Elambda md c) (Typ (Tlambda g' p md g'') (L))
  | ETadd : forall md g d e1 e2 p q,
      exp_type md g d e1 (Typ Tnat p) ->
      exp_type md g d e2 (Typ Tnat q) ->
      exp_type md g d (Eadd e1 e2) (Typ Tnat (sec_level_join p q))

  with com_type : sec_level -> mode -> context -> loc_mode -> com -> context -> Prop :=
  | CTskip : forall pc md g d,
      com_type pc md g d Cskip g
  | CTassign : forall pc md g d x e s p q vc',
      exp_type md g d e (Typ s p) ->
      q = sec_level_join p pc ->
      sec_level_le q (L) \/ md <> Normal ->
      vc' = (fun y => if y =? x then Some (Typ s q) else g y) ->
      com_type pc md g d (Cassign x e) (vc')
  | CTdeclassify : forall md g d x e s p vc',
      exp_type md g d e (Typ s p) ->
      exp_novars e ->
      exp_locs_immutable e ->
      vc' = (fun y => if y =? x then Some (Typ s (L)) else g y) ->
      com_type (L) md g d (Cdeclassify x e) (vc')
  | CToutput : forall pc md g d e l s p,
      exp_type md g d e (Typ s p) ->
      sec_level_le (sec_level_join p pc) l ->
      com_type pc md g d (Coutput e l) g
  | CTupdate : forall pc md g d e1 e2 s p md' q p',
      exp_type md g d e1 (Typ (Tref (Typ s p) md' Mut) q) ->
      exp_type md g d e2 (Typ s p') ->
      sec_level_le (sec_level_join (sec_level_join p' q) pc) p ->
      md' = Normal \/ md' = md ->
      com_type pc md g d (Cupdate e1 e2) g
  | Tifelse : forall pc md g d e c1 c2 pc' p g',
      com_type pc' md g d c1 g' ->
      com_type pc' md g d c2 g' ->
      exp_type md g d e (Typ Tnat p) ->
      sec_level_le (sec_level_join pc p) pc' ->
      sec_level_le p (L) \/ md <> Normal ->
      com_type pc md g d (Cif e c1 c2) g'
  | Tenclave : forall pc g d c i c' g',
      c = Cenclave i c' ->
      com_type pc (Encl i) g d c' g' ->
      is_var_low_context g' ->
      com_type pc Normal g d c g'
  | Twhile : forall pc md g d c e p pc',
      exp_type md g d e (Typ Tnat p) ->
      com_type pc' md g d c g ->
      sec_level_le (sec_level_join pc p) pc' ->
      sec_level_le p L \/ md <> Normal ->
      com_type pc md g d (Cwhile e c) g
  | Tseq : forall pc md g d c rest g' gn,
      com_type pc md g d c g' ->
      com_type pc md g' d (Cseq rest) gn ->
      com_type pc md g d (Cseq (c :: rest)) gn
  | Tseqnil : forall pc md g d,
      com_type pc md g d (Cseq []) g
  | Tcall : forall pc md G d e Gm Gp Gout q p,
      exp_type md G d e (Typ (Tlambda Gm p md Gp) q) ->
      sec_level_le (sec_level_join pc q) p ->
      context_le G Gm ->
      context_le Gp Gout ->
      forall_dom G (fun x t => (Gp x = None) -> Gout x = Some t) ->
      com_type pc md G d (Ccall e) Gout.

  Axiom subsumption : forall pc1 pc2 md d G1 G1' G2 G2' c,
      com_type pc1 md G1 d c G1' ->
      sec_level_le pc2 pc1 ->
      context_le G2 G1 ->
      context_le G1' G2' ->
      com_type pc2 md G2 d c G2'.

  Hint Constructors exp_type.
  Hint Constructors val_type.
  Hint Constructors com_type.
End Typing.

Section Initial_State.
  Parameter minit : mem.

  Definition meminit_wf minit d := forall l,
      match minit l with
      | Vlambda md c => exists Gm p Gp q rt,
                        Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) /\
                        com_type p md Gm d c Gp
      | Vloc l => False
      | Vnat n => exists q rt, Loc_Contxt l = Some (Typ (Tnat) q, rt)
      end.

  Axiom wf_minit : forall d, meminit_wf minit d.

  Axiom Initial_State : forall d r' m',
      exists c md tr, cstep md d (c,reg_init,minit) (r',m') tr.
End Initial_State.

Section Axioms.
  (* These next four axioms follow from the statement of initial state above *)
  Axiom No_Pointers : forall (m: mem) l l', m l <> Vloc l'.

  Axiom Reg_Exp_Lambda : forall (r : reg) d x md c G Gm Gp p q,
      r x = Vlambda md c /\ G x = Some (Typ (Tlambda Gm p md Gp) q)
      <-> exists md', exp_type md' G d (Elambda md c)
                                 (Typ (Tlambda Gm p md Gp) L).

  Axiom Reg_Exp_Loc : forall (r : reg) d x l G s p md' rt q,
      r x = Vloc l /\ G x = Some (Typ (Tref (Typ s p) md' rt) q) <->
      exists md,
        exp_type md G d (Eloc l) (Typ (Tref (Typ s p) md' rt) L) /\ d l = md'.

  Axiom Mem_Exp_Lambda : forall (m : mem) d l md c G Gm Gp p q rt,
      m l = Vlambda md c /\ Loc_Contxt l = Some (Typ (Tlambda Gm p md Gp) q, rt) <->
      minit l = Vlambda md c \/
      (exists md',
          exp_type md' G d (Elambda md c) (Typ (Tlambda Gm p md Gp) L)).
End Axioms.


(* ------------------------------------------------------- *)
(** #

#
        The double time redundancy (DTR) transformation
#
#
-   Properties of memory block sub-part called rhsPar

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(*Add LoadPath "..\..\Common\".
        Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\". *)
Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".

Require Import dtrTransform.

Set Implicit Arguments.

(* ##################################################################### *)
(** Properties of sub-circuit of Memory Block called rhsPar w/o Glitches *)
(* ##################################################################### *)

(* State before/after for both cycles w/o errors *)
Lemma step_rhs: forall si_I sav_I rol_I fai_I rO_I sav2_I t rhs2,
                step rhsPar {si_I,{{{ sav_I, rol_I},fai_I},{rO_I,sav2_I}}} t rhs2
             -> let rNew:= if ((beq_buset_t sav2_I (~?))&&(beq_buset_t si_I (~0))&&(beq_buset_t rO_I (~0))) then (~0)
                           else if (beq_buset_t sav2_I (~?))  then (~?)
                           else if (beq_buset_t sav2_I (~1)) then si_I
                           else rO_I in
                t= {{ {{sav_I,rol_I}, fai_I}, si_I}, rNew} /\ rhs2 = rhsPar.
Proof.
introv H.
assert ( F:  fstep rhsPar {si_I, {sav_I, rol_I, fai_I, {rO_I, sav2_I}}}  =
             Some ({{ {{sav_I,rol_I}, fai_I}, si_I},
                      if ((beq_buset_t sav2_I (~?))&&(beq_buset_t si_I (~0))
                      &&(beq_buset_t rO_I (~0))) then (~0)
                      else if (beq_buset_t sav2_I (~?))  then (~?)
                      else if (beq_buset_t sav2_I (~1)) then si_I
                      else rO_I},rhsPar)) by
(Destruct_s sav2_I; destruct x; cbn; Destruct_s sav_I;  Destruct_s rol_I;
Destruct_s fai_I; Destruct_s si_I; Destruct_s rO_I;
destruct x; destruct x0; destruct x1 ; destruct x2; destruct x3;
vm_compute; try easy).
eapply fstep_imp_detstep in F; Simpl.
Qed.


Require Import compcert.common.AST.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.common.Values.
Require Import compcert.lib.Coqlib.
Require Import compcert.lib.Integers.
Require Import compcert.lib.Maps.
Require Import Seccompconf.

Set Implicit Arguments.

Inductive alu_safe : Type :=
  | Aaddimm: int -> alu_safe
  | Asubimm: int -> alu_safe
  | Amulimm: int -> alu_safe
  | Aandimm: int -> alu_safe
  | Aorimm: int -> alu_safe
  | Axorimm: int -> alu_safe
  | Aadd: alu_safe
  | Asub: alu_safe
  | Amul: alu_safe
  | Aand: alu_safe
  | Aor: alu_safe
  | Axor: alu_safe
  | Aneg: alu_safe
  .

Inductive alu_div : Type :=
  | Adivimm: int -> alu_div
  | Amodimm: int -> alu_div
  | Adiv: alu_div
  | Amod: alu_div
  .

Inductive alu_shift : Type :=
  | Alshimm: int -> alu_shift
  | Arshimm: int -> alu_shift
  | Alsh: alu_shift
  | Arsh: alu_shift
  .

Inductive condition : Type :=
  | Jgtimm: int -> condition
  | Jgeimm: int -> condition
  | Jeqimm: int -> condition
  | Jsetimm: int -> condition
  | Jgt: condition
  | Jge: condition
  | Jeq: condition
  | Jset: condition
  .

Inductive instruction : Type :=
  | Salu_safe: alu_safe -> instruction
      (** A <- arithmetic *)
  | Salu_div: alu_div -> instruction
      (** A <- arithmetic *)
  | Salu_shift: alu_shift -> instruction
      (** A <- arithmetic *)
  | Sld_w_abs: int -> instruction
      (** A <- seccomp_bpf_load(k), access struct seccomp_data *)
  | Sld_w_len: instruction
      (** A <- sizeof(struct seccomp_data) *)
  | Sldx_w_len: instruction
      (** X <- sizeof(struct seccomp_data) *)
  | Sld_imm: int -> instruction
      (** A <- k *)
  | Sldx_imm: int -> instruction
      (** X <- k *)
  | Sld_mem: int -> instruction
      (** A <- [k] *)
  | Sldx_mem: int -> instruction
      (** X <- [k] *)
  | Sst: int -> instruction
      (** [k] <- A *)
  | Sstx: int -> instruction
      (** [k] <- X *)
  | Sjmp_ja: int -> instruction
  | Sjmp_jc: condition -> byte -> byte -> instruction
  | Smisc_tax: instruction
      (** X <- A *)
  | Smisc_txa: instruction
      (** A <- X *)
  | Sret_k: int -> instruction
      (** ret k **)
  | Sret_a: instruction
      (** ret A **)
  .

Definition code := list instruction.

Section PROGRAM.

Definition function := code.

Definition fundef := AST.fundef function.

Definition program := AST.program fundef unit.

End PROGRAM.

Section SEMANTICS.

Definition genv := Genv.t fundef unit.

Inductive state : Type :=
  | State:
    forall (a: int)              (**r accumulator *)
           (x: int)              (**r index register *)
           (sm: ZMap.t val)      (**r scratch memory *)
           (f: function)         (**r current function *)
           (c: code)             (**r current program point *)
           (p: block)            (**r input packet *)
           (m: mem),             (**r memory state *)
    state
  | Callstate:
    forall (fd: fundef)          (**r calling function *)
           (p: block)            (**r input packet *)
           (m: mem),             (**r memory state *)
    state
  | Returnstate:
    forall (v: int)              (**r local return value *)
           (m: mem),             (**r memory state *)
    state
  .

Definition eval_alu_safe (op: alu_safe) (a: int) (x: int): int :=
  match op with
  | Aaddimm k => Int.add a k
  | Asubimm k => Int.sub a k
  | Amulimm k => Int.mul a k
  | Aandimm k => Int.and a k
  | Aorimm k => Int.or a k
  | Axorimm k => Int.xor a k
  | Aadd => Int.add a x
  | Asub => Int.sub a x
  | Amul => Int.mul a x
  | Aand => Int.and a x
  | Aor => Int.or a x
  | Axor => Int.xor a x
  | Aneg => Int.neg a
  end.

Definition eval_alu_div (op: alu_div) (a: int) (x: int): int :=
  match op with
  | Adivimm k => Int.divu a k
  | Amodimm k => Int.modu a k
  | Adiv => Int.divu a x
  | Amod => Int.modu a x
  end.

Definition eval_alu_shift (op: alu_shift) (a: int) (x: int): int :=
  match op with
  | Alshimm k => Int.shl a k
  | Arshimm k => Int.shru a k
  | Alsh => Int.shl a x
  | Arsh => Int.shru a x
  end.

Definition eval_cond (cond: condition) (a: int) (x: int): bool :=
  match cond with
  | Jsetimm k => negb (Int.eq (Int.and a k) Int.zero)
    (* A & k *)
  | Jgtimm k => Int.cmpu Cgt a k
    (* A > k *)
  | Jgeimm k => Int.cmpu Cge a k
    (* A >= k *)
  | Jeqimm k => Int.eq a k
    (* A == k *)
  | Jset => negb (Int.eq (Int.and a x) Int.zero)
    (* A & X *)
  | Jgt => Int.cmpu Cgt a x
    (* A > X *)
  | Jge => Int.cmpu Cge a x
    (* A >= X *)
  | Jeq => Int.eq a x
    (* A == X *)
  end.

Inductive step (ge: genv) : state -> trace -> state -> Prop :=
  | exec_Salu_safe:
      forall op a x sm f b p m,
      let a' := eval_alu_safe op a x in
      step ge (State a x sm f (Salu_safe op :: b) p m)
        E0 (State a' x sm f b p m)
  (* NB: could return 0 for div by zero *)
  | exec_Salu_div:
      forall op a x sm f b p m,
      let a' := eval_alu_div op a x in
      step ge (State a x sm f (Salu_div op :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Salu_shift:
      forall op a x sm f b p m,
      let a' := eval_alu_shift op a x in
      step ge (State a x sm f (Salu_shift op :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sjmp_ja:
      forall a x sm f k b p m,
      let off := Int.unsigned k in
      off < (list_length_z b) ->
      step ge (State a x sm f (Sjmp_ja k :: b) p m)
        E0 (State a x sm f (skipn (nat_of_Z off) b) p m)
  | exec_Sjmp_jc:
      forall cond jt jf a x sm f b p m,
      let off := Byte.unsigned (if (eval_cond cond a x) then jt else jf) in
      off < (list_length_z b) ->
      step ge (State a x sm f (Sjmp_jc cond jt jf :: b) p m)
        E0 (State a x sm f (skipn (nat_of_Z off) b) p m)
  | exec_Sld_w_abs:
      forall a a' k x sm f b p m,
      let off := Int.unsigned k in
      off < sizeof_seccomp_data ->
      off mod 4 = 0 ->
      Mem.load Mint32 m p off = Some (Vint a') ->
      step ge (State a x sm f (Sld_w_abs k :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sld_w_len:
      forall a x sm f b p m,
      let a' := Int.repr sizeof_seccomp_data in
      step ge (State a x sm f (Sld_w_len :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Sldx_w_len:
      forall a x sm f b p m,
      let x' := Int.repr sizeof_seccomp_data in
      step ge (State a x sm f (Sldx_w_len :: b) p m)
        E0 (State a x' sm f b p m)
  | exec_Sld_imm:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sld_imm k :: b) p m)
        E0 (State k x sm f b p m)
  | exec_Sldx_imm:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sldx_imm k :: b) p m)
        E0 (State a k sm f b p m)
  | exec_Sld_mem:
      forall a a' k x sm f b p m,
      let idx := Int.unsigned k in
      idx < seccomp_memwords ->
      ZMap.get idx sm = Vint a' ->
      step ge (State a x sm f (Sld_mem k :: b) p m)
        E0 (State a' x sm f b p m)
  | exec_Smisc_tax:
      forall a x sm f b p m,
      step ge (State a x sm f (Smisc_tax :: b) p m)
        E0 (State a a sm f b p m)
  | exec_Smisc_txa:
      forall a x sm f b p m,
      step ge (State a x sm f (Smisc_txa :: b) p m)
        E0 (State x x sm f b p m)
  | exec_Sret_a:
      forall a x sm f b p m,
      step ge (State a x sm f (Sret_a :: b) p m)
        E0 (Returnstate a m)
  | exec_Sret_k:
      forall a x sm f k b p m,
      step ge (State a x sm f (Sret_k k :: b) p m)
        E0 (Returnstate k m)
  | exec_call:
      forall f p m,
      step ge (Callstate (Internal f) p m)
        E0 (State Int.zero Int.zero (ZMap.init Vundef) f f p m)
  .

Inductive initial_state (p: program): state -> Prop :=
  | initial_state_intro: forall b fd m0 m1 m2 pkt,
    let ge := Genv.globalenv p in
    Genv.init_mem p = Some m0 ->
    Genv.find_symbol ge p.(prog_main) = Some b ->
    Genv.find_funct_ptr ge b = Some fd ->
    Mem.alloc m0 0 sizeof_seccomp_data = (m1, pkt) ->
    Mem.storebytes m1 pkt 0 (Memdata.inj_bytes seccomp_data) = Some m2 ->
    initial_state p (Callstate fd pkt m2).

Inductive final_state: state -> int -> Prop :=
  | final_state_intro: forall v m,
      final_state (Returnstate v m) v.

End SEMANTICS.


(*
 * © 2020 XXX.
 *
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List.

From SPICY Require Import
     MyPrelude
     Maps
     ChMaps
     Messages
     ModelCheck
     Keys
     Automation
     Tactics
     Simulation
     AdversaryUniverse

     ModelCheck.UniverseEqAutomation
     ModelCheck.ProtocolAutomation
     ModelCheck.SafeProtocol
     ModelCheck.ProtocolFunctions
.

From SPICY Require IdealWorld RealWorld.

Import IdealWorld.IdealNotations
       RealWorld.RealWorldNotations
       SimulationAutomation.

From Frap Require Import Sets.

Module Foo <: Sets.EMPTY.
End Foo.
Module Export SN := Sets.SetNotations(Foo).

Set Implicit Arguments.

Open Scope protocol_scope.

Module SecureDNSProtocol.

  (* Start with two users, as that is the minimum for any interesting protocol *)
  Notation USR1 := 0.
  Notation USR2 := 1.
  Notation USR3 := 2.

  Parameter names : NatMap.t nat.

  Section IW.
    Import IdealWorld.

    (* Set up initial communication channels so each user can talk directly to the other *)
    Notation pCH12 := 0.
    Notation pCH21 := 1.
    Notation pCH23 := 2.
    Notation pCH32 := 3.
    Notation CH12  := (# pCH12).
    Notation CH21  := (# pCH21).
    Notation CH23  := (# pCH23).
    Notation CH32  := (# pCH32).

    (* This is the initial channel vector, each channel should be represented and start with
     * no messages.
     *)
    Notation empty_chs := (#0 #+ (CH12, []) #+ (CH21, []) #+ (CH23, []) #+ (CH32, [])).

    Notation PERMS1 := ($0 $+ (pCH12, writer) $+ (pCH21, reader)).
    Notation PERMS2 := ($0 $+ (pCH12, reader) $+ (pCH21, writer) $+ (pCH23, writer) $+ (pCH32, reader)).
    Notation PERMS3 := ($0 $+ (pCH23, reader) $+ (pCH32, writer)).

    Fixpoint idealServer (n : nat) {t} (r : << t >>) (c : cmd t) : cmd t :=
      match n with
      | 0   => @Return t r
      | S i => (r' <- c ; idealServer i r' c)
      end.

    (* Fill in the users' protocol specifications here, adding additional users as needed.
     * Note that all users must return an element of the same type, and that type needs to
     * be one of: ...
     *)
    Notation ideal_users :=
      [
        (* Authorative DNS Server Specification *)
        mkiUsr USR1 PERMS1
               (
                 @idealServer 1 (Base Nat) 1
                              (
                                m <- @Recv Nat CH21
                                ; let ip := match names $? extractContent m with
                                            | None   => 0
                                            | Some a => a
                                            end
                                  in
                                  _ <- Send (Content ip) CH12
                                ; @Return (Base Nat) ip
                              )
               )
        ;

      (* Secure DNS Cache Specification *)
      mkiUsr USR2 PERMS2
             (
               req <- @Recv Nat CH32
               ; _ <- Send (Content (extractContent req)) CH21
               ; ip1 <- @Recv Nat CH12
               ; _ <- Send (Content (extractContent ip1)) CH23
               ; @Return (Base Nat) (extractContent ip1)
             )
        ;

      (* DNS Client Specification *)
      mkiUsr USR3 PERMS3
             (
               _ <- Send (Content 0) CH32
               ; ip1 <- @Recv Nat CH23
               ; @Return (Base Nat) (extractContent ip1)
             )
      ].

    (* This is where the entire specification universe gets assembled.  It is unlikely anything
     * will need to change here.
     *)
    Definition ideal_univ_start :=
      mkiU empty_chs ideal_users.

  End IW.

  Section RW.
    Import RealWorld.

    (* Key management needs to be bootstrapped.  Since all honest users must only send signed
     * messages, we need some way of initially distributing signing keys in order to be able
     * to begin secure communication.  This is analagous in the real world where we need to
     * have some sort of trust relationship in order to distribute trusted keys.
     *
     * Here, each user has a public asymmetric signing key.
     *)
    Notation KID1 := 0.
    Notation KID2 := 1.
    Notation KID3 := 2.
    Notation KID4 := 3.
    Notation KID5 := 4.
    Notation KID6 := 5.

    Notation KEYS := [ skey KID1 ; ekey KID2 ; skey KID3 ; ekey KID4 ; skey KID5 ; ekey KID6 ].

    Notation KEYS1 := ($0 $+ (KID1, true) $+ (KID2, true) $+ (KID3, false) $+ (KID4, false)).
    Notation KEYS2 := ($0 $+ (KID1, false) $+ (KID2, false)
                        $+ (KID3, true) $+ (KID4, true)
                        $+ (KID5, false) $+ (KID6, false)).
    Notation KEYS3 := ($0 $+ (KID3, false) $+ (KID4, false) $+ (KID5, true) $+ (KID6, true)).

    Fixpoint realServer (n : nat) {t} (r : << t >>) (c : user_cmd t) : user_cmd t :=
      match n with
      | 0   => @Return t r
      | S i => (r' <- c ; realServer i r' c)
      end.

    Notation real_users :=
      [
        (* Authoritative DNS server implementation *)
        MkRUserSpec USR1 KEYS1
                    (
                      @realServer 1 (Base Nat) 1
                                  ( c <- @Recv Nat (SignedEncrypted KID3 KID2 true)
                                    ; m <- Decrypt c
                                    ; let ip := match names $? (extractContent m) with
                                                | None   => 0
                                                | Some a => a
                                                end
                                      in ipC <- SignEncrypt KID1 KID4 USR2 (message.Content ip)
                                    ; _ <- Send USR2 ipC
                                    ; @Return (Base Nat) ip
                                  )
                    )
        ;

      (* Secure DNS Cache implementation *)
      MkRUserSpec USR2 KEYS2
                  (
                    reqc <- @Recv Nat (SignedEncrypted KID5 KID4 true)
                    ; req <- Decrypt reqc
                    ; c1 <- SignEncrypt KID3 KID2 USR1 (message.Content (extractContent req))
                    ; _ <- Send USR1 c1
                    ; hostC <- @Recv Nat (SignedEncrypted KID1 KID4 true)
                    ; host <- Decrypt hostC
                    ; c2 <- SignEncrypt KID3 KID6 USR3 (message.Content (extractContent host))
                    ; _ <- Send USR3 c2
                    ; @Return (Base Nat) (extractContent host)
                  )
        ;

      (* DNS Client implementation *)
      MkRUserSpec USR3 KEYS3
                  (
                    c <- SignEncrypt KID5 KID4 USR2 (message.Content 0)
                    ; _ <- Send USR2 c
                    ; hostC <- @Recv Nat (SignedEncrypted KID3 KID6 true)
                    ; host <- Decrypt hostC
                    ; @Return (Base Nat) (extractContent host)
                  )
      ].

    (* Here is where we put the implementation universe together.  Like above, it is
     * unlikely anything will need to change here.
     *)
    Definition real_univ_start :=
      mkrU (mkKeys KEYS) real_users.
  End RW.

  (* These are here to help the proof automation.  Don't change. *)
  #[export] Hint Unfold
       real_univ_start
       ideal_univ_start
    : user_build.

  #[export] Hint Extern 0 (IdealWorld.lstep_universe _ _ _) =>
    progress(autounfold with user_build; simpl) : core.

End SecureDNSProtocol.


(*
	coqtop -R ../../../kami/Kami Kami -R $PWD BK
*)

Require Import Bool String List Arith.
Require Import Kami.
Require Import Lib.Indexer Lib.Struct.
Require Import Bsvtokami.
Require Import MiniRiscvMMode.
Require Import Kami.Duplicate.

Require Import FunctionalExtensionality.

Set Implicit Arguments.

Definition spec := ProcMMode'modules (mkMiniRiscvMMode "spec" ($$(natToWord 1 0))%kami ($$ (natToWord 1 0))%kami ($$ (natToWord 1 0))%kami).
Definition impl := ProcMMode'modules (mkMiniRiscvMMode "impl" ($$(natToWord 1 0))%kami ($$ (natToWord 1 0))%kami ($$ (natToWord 1 0))%kami).

Check spec.
Check impl.

Compute (map (fun reg => (attrName reg)) (getRegInits (spec))).

Hint Unfold spec impl: ModuleDefs.

Definition spec_impl_ruleMap (_: RegsT): string -> option string :=
  fun regname => Some regname.

Compute 1.

Lemma spec_ModEquiv:
  ModPhoasWf spec.
Proof. kequiv. Qed.
Hint Resolve spec_ModEquiv.

Compute 2.

Lemma impl_ModEquiv:
  ModPhoasWf impl.
Proof. kequiv. Qed.
Hint Resolve impl_ModEquiv.

Compute 3.

Require Import Kami.Wf.
Require Import Lib.Reflection.
Require Import Lib.StringEq.

Definition Is_true (b : bool) :=
  match b with
  | true => True
  | false => False
  end.

Theorem eqb_a_a:
  (forall a : bool, Is_true (eqb a a)).
Proof.
  intros a.
  case a.
    simpl. exact I.
    simpl. exact I.
Qed.

Theorem spec_impl_refinement:
  impl <<== spec.
Proof.
  (* repeat autounfold with ModuleDefs. *)
  apply traceRefines_inlining_left.
  apply impl_ModEquiv.
  kinline_compute.
  noDup_tac.
  remember (inlineF impl) as im eqn:Heq.
  repeat autounfold with ModuleDefs in Heq.

  cbv [string_eq attrName withPrefix append prefixSymbol] in Heq.
  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
	       ] in Heq.

  cbv [getDefsBodies namesOf filter map app attrName string_eq ascii_eq] in Heq.
  rewrite eqb_reflx in Heq.
  rewrite andb_diag in Heq.

  cbv [getDefsBodies namesOf filter map app attrName string_eq ascii_eq andb orb negb] in Heq.

  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
               getRegInits getDefs getDefsBodies getRules namesOf
               map app attrName attrType
               getCalls getCallsR getCallsM getCallsA
	       ] in Heq.

  cbv [inlineF inline inlineDms inlineDms'
               inlineDmToMod inlineDmToRules inlineDmToRule
               inlineDmToDms inlineDmToDm inlineDm
               filterDms filter
               noInternalCalls noCalls
               noCallsRules noCallsDms noCallDm isLeaf
               getBody inlineArg
               appendAction getAttribute
               makeModule makeModule' max plus
               getRegInits getDefs getDefsBodies getRules namesOf
               map app attrName attrType
               getCalls getCallsR getCallsM getCallsA
               ret arg fst snd projT1 projT2
               string_in string_eq ascii_eq
               eqb existsb andb orb negb] in Heq.

  (* kinline_left implInlined. *)

  kdecompose_nodefs spec_impl_regMap spec_impl_ruleMap.
Qed.


(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University
  Copyright 2018 Luxembourg University

  This file is part of Velisarios.

  Velisarios is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  Velisarios is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with Velisarios.  If not, see <http://www.gnu.org/licenses/>.

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export Quorum.
Require Export CorrectTrace.
Require Export Process.

Section LearnAndKnow.

  Context { pd  : @Data }.
  Context { pn  : @Node }.
  Context { pk  : @Key }.
  Context { pm  : @Msg }.
  Context { qc  : @Quorum_context pn}.
  Context { pat : @AuthTok }.
  Context { paf : @AuthFun pn pk pat pd }.
  Context { pda : @DataAuth pd pn }.
  Context { cad : @ContainedAuthData pd pat pm }.

  Local Open Scope eo.
  Local Open Scope proc.

  Class LearnAndKnow (n : nat) :=
    MkLearnAndKnow {
        (* known raw data *)
        lak_data : Type;

        (* some distinguished information embedded in the data *)
        lak_info : Type;

        (* to compute the info from the data *)
        lak_data2info : lak_data -> lak_info;

        (* where we store data *)
        lak_memory : Type;

        (* explains what it means to know the data *)
        lak_knows : lak_data -> lak_memory -> Prop;

        (* "owner" of the data *)
        lak_data2owner : lak_data -> node_type;

        (* to verify the authenticity of the data *)
        lak_data2auth : lak_data -> AuthenticatedData;
        lak_verify : forall {eo : EventOrdering} (e : Event) (d : lak_data), bool;

        (* the system *)
        lak_output : Type;
        lak_system : node_type -> StateMachine lak_memory msg lak_output;
        lak_no_initial_memory : forall n d, ~ lak_knows d (sm_state (lak_system n));
      }.

  Context { p : nat }.
  Context { lak : LearnAndKnow p }.

  Definition lak_data2node (d : lak_data) : name :=
    node2name (lak_data2owner d).

  Definition knows
             {eo : EventOrdering}
             (e  : Event)
             (d  : lak_data) :=
    exists mem n,
      loc e = node2name n
      /\ lak_knows d mem
      /\ state_sm_on_event (lak_system n) e = Some mem.

  Definition knew
             {eo : EventOrdering}
             (e  : Event)
             (d  : lak_data) :=
    exists mem n,
      loc e = node2name n
      /\ lak_knows d mem
      /\ state_sm_before_event (lak_system n) e = Some mem.

  (* We know a list of length [n] of [lak_info] stuff that we got from various owners *)
  Definition knows_certificate
             {eo : EventOrdering}
             (e : Event)
             (n : nat)
             (i : lak_info)
             (P : list lak_data -> Prop) :=
    exists (l : list lak_data),
      n <= length l
      /\ no_repeats (map lak_data2owner l)
      /\ P l
      /\ forall d, In d l -> (knows e d /\ i = lak_data2info d).

  Definition learns {eo : EventOrdering} (e : Event) (d : lak_data) :=
    exists n,
      loc e = node2name n
      /\ In (lak_data2auth d) (bind_op_list get_contained_authenticated_data (trigger e))
      (*/\ verify_authenticated_data (loc e) (lak_data2auth d) (keys e) = true.*)
      /\ lak_verify e d = true.

  Definition learned {eo : EventOrdering} (e : Event) (d : lak_data) :=
    exists e', e' ⊑ e /\ learns e' d.

  Definition learns_or_knows (eo : EventOrdering) : Prop :=
    forall (d  : lak_data) (e : Event),
      knows e d
      -> learned e d \/ lak_data2node d = loc e.

  Definition learns_if_knows (eo : EventOrdering) :=
    forall (d  : lak_data) (e : Event),
      learns e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≺ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.

  Lemma knows_implies_correct :
    forall {eo : EventOrdering} (e : Event) (d : lak_data),
      knows e d
      -> has_correct_trace_before e (loc e).
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    eapply state_sm_on_event_some_implies_has_correct_trace_before;eauto.
  Qed.
  Hint Resolve knows_implies_correct : eo.

  Lemma knows_propagates :
    forall {eo : EventOrdering} (e : Event) (d : lak_data),
      learns_or_knows eo
      -> learns_if_knows eo
      -> knows e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≼ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.
  Proof.
    introv lok lik knows ctrace.
    pose proof (lok d e) as sent.
    repeat (autodimp sent hyp);[].
    repndors; repnd;[|exists e; dands; eauto 2 with eo];[].

    unfold learned in *; exrepnd.

    pose proof (lik d e') as h.
    repeat (autodimp h hyp); eauto 3 with eo;[].
    exrepnd.
    exists e'0; dands; auto; eauto 4 with eo.
  Qed.

  Lemma knows_in_intersection :
    forall {eo : EventOrdering}
           (e1 e2 : Event)
           (n : nat)
           (i1 i2 : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      learns_or_knows eo
      -> learns_if_knows eo
      -> n <= num_nodes
      -> num_nodes + F < 2 * n
      -> knows_certificate e1 n i1 P
      -> knows_certificate e2 n i2 P
      -> exists_at_most_f_faulty E F
      -> In e1 E
      -> In e2 E
      ->
      exists e1' e2' d1 d2,
        loc e1' = loc e2'
        /\ e1' ≼ e1
        /\ e2' ≼ e2
        /\ loc e1' = lak_data2node d1
        /\ loc e2' = lak_data2node d2
        /\ knows e1' d1
        /\ knows e2' d2
        /\ i1 = lak_data2info d1
        /\ i2 = lak_data2info d2.
  Proof.
    introv lok lik cond1 cond2 kna knb; introv atmost e1in e2in.
    unfold knows_certificate in *.
    destruct kna as [l1 [lena [norepa [conda impa]]]]; repnd.
    destruct knb as [l2 [lenb [norepb [condb impb]]]]; repnd.

    pose proof (overlapping_quorums_same_size
                  (MkNRlist _ (map lak_data2owner l1) norepa)
                  (MkNRlist _ (map lak_data2owner l2) norepb)
                  n) as q.
    simpl in q; autorewrite with list in *.
    repeat (autodimp q hyp); try omega;[].
    exrepnd.

    pose proof (there_is_one_correct_before eo l E F) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd.

    pose proof (h0 e1) as ctrace1; simpl in ctrace1; autodimp ctrace1 hyp.
    pose proof (h0 e2) as ctrace2; simpl in ctrace2; autodimp ctrace2 hyp.

    applydup q3 in h1.
    applydup q0 in h1.
    allrw in_map_iff; exrepnd.

    applydup impa in h5.
    applydup impb in h4.
    repnd.

    pose proof (knows_propagates e1 x0) as w.
    repeat (autodimp w hyp); try (complete (unfold lak_data2node; allrw; auto));[].

    pose proof (knows_propagates e2 x) as z.
    repeat (autodimp z hyp); try (complete (unfold lak_data2node; allrw; auto));[].

    destruct w as [e1' w]; repnd.
    destruct z as [e2' z]; repnd.
    assert (loc e1' = loc e2') as eqloc' by (allrw; unfold lak_data2node; allrw; auto).

    exists e1' e2' x0 x; dands; auto.
  Qed.

  Lemma local_knows_in_intersection :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i1 i2 : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      n <= num_nodes
      -> num_nodes + F < 2 * n
      -> knows_certificate e n i1 P
      -> knows_certificate e n i2 P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists correct d1 d2,
        has_correct_trace_before e (node2name correct)
        /\ lak_data2node d1 = lak_data2node d2
        /\ knows e d1
        /\ knows e d2
        /\ i1 = lak_data2info d1
        /\ i2 = lak_data2info d2
        /\ lak_data2owner d1 = correct
        /\ lak_data2owner d2 = correct.
  Proof.
    introv cond1 cond2 kna knb atmost ein.
    unfold knows_certificate in *.
    destruct kna as [l1 [lena [norepa [conda impa]]]]; repnd.
    destruct knb as [l2 [lenb [norepb [condb impb]]]]; repnd.

    pose proof (overlapping_quorums_same_size
                  (MkNRlist _ (map lak_data2owner l1) norepa)
                  (MkNRlist _ (map lak_data2owner l2) norepb)
                  n) as q.
    simpl in q; autorewrite with list in *.
    repeat (autodimp q hyp); try omega;[].
    exrepnd.

    pose proof (there_is_one_correct_before eo l E F) as h.
    repeat (autodimp h hyp); try omega;[].
    exrepnd.

    exists correct.

    pose proof (h0 e) as ctrace1; simpl in ctrace1; autodimp ctrace1 hyp.

    applydup q3 in h1.
    applydup q0 in h1.
    allrw in_map_iff; exrepnd.

    applydup impa in h5.
    applydup impb in h4.
    repnd.

    exists x0 x; dands; auto;[].
    unfold lak_data2node; allrw; auto.
  Qed.

  Definition learns_or_knows_if_knew (eo : EventOrdering) : Prop :=
    forall (d  : lak_data) (e : Event),
      knew e d
      -> learned e d \/ lak_data2node d = loc e.

  Lemma knew_implies_knows :
    forall (eo : EventOrdering) (e : Event) (d : lak_data),
      knew e d
      -> knows (local_pred e) d.
  Proof.
    introv k.
    unfold knew in *; exrepnd.
    rewrite <- ite_first_state_sm_on_event_as_before in k1.
    unfold ite_first in k1; destruct (dec_isFirst e) as [de|de];
      [|exists mem n; autorewrite with eo; dands; auto];[].
    ginv.
    apply lak_no_initial_memory in k2; tcsp.
  Qed.

  Lemma learns_or_knows_implies_learns_or_knows_if_new :
    forall (eo : EventOrdering),
      learns_or_knows eo
      -> learns_or_knows_if_knew eo.
  Proof.
    introv lok k.
    apply knew_implies_knows in k.
    apply lok in k; autorewrite with eo in *.
    repeat (autodimp k hyp); eauto 3 with eo;[].
    repndors; tcsp; left;[].
    unfold learned in *; exrepnd.
    exists e'; dands; auto; eauto 3 with eo.
  Qed.

  Lemma knows_implies :
    forall {eo : EventOrdering} (e : Event) d,
      knows e d
      ->
      exists mem mem' n,
        loc e = node2name n
        /\ op_state (lak_system n) mem (trigger e) = Some mem'
        /\ lak_knows d mem'
        /\ state_sm_before_event (lak_system n) e = Some mem.
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    rewrite state_sm_on_event_unroll2 in kn1.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv]
    end.

    exists l mem n; dands; auto.
  Qed.

  Lemma knows_implies_before_after :
    forall {eo : EventOrdering} (e : Event) d,
      knows e d
      ->
      exists mem mem' n,
        loc e = node2name n
        /\ op_state (lak_system n) mem (trigger e) = Some mem'
        /\ lak_knows d mem'
        /\ state_sm_before_event (lak_system n) e = Some mem
        /\ state_sm_on_event (lak_system n) e = Some mem'.
  Proof.
    introv kn.
    unfold knows in kn; exrepnd.
    dup kn1 as ston.
    rewrite state_sm_on_event_unroll2 in kn1.

    match goal with
    | [ H : context[map_option _ ?s] |- _ ] =>
      remember s as sop; symmetry in Heqsop; destruct sop; simpl in *;[|ginv]
    end.

    exists l mem n; dands; auto.
  Qed.

  Lemma implies_knows :
    forall {eo : EventOrdering} (e : Event) d n mem,
      loc e = node2name n
      -> lak_knows d mem
      -> state_sm_on_event (lak_system n) e = Some mem
      -> knows e d.
  Proof.
    introv eqloc k eqst.
    eexists; eexists; dands; eauto.
  Qed.
  Hint Resolve implies_knows : eo.

  Lemma learned_local_pred_implies :
    forall (eo : EventOrdering) (e : Event) d,
      learned (local_pred e) d
      -> learned e d.
  Proof.
    introv h.
    unfold learned in *; exrepnd.
    eexists; dands; eauto; eauto 3 with eo.
  Qed.
  Hint Resolve learned_local_pred_implies : eo.

  Lemma learned_local_le_implies :
    forall (eo : EventOrdering) (e1 e2 : Event) d,
      e1 ⊑ e2
      -> learned e1 d
      -> learned e2 d.
  Proof.
    introv lee h.
    unfold learned in *; exrepnd.
    eexists; dands;[|eauto]; eauto 3 with eo.
  Qed.
  Hint Resolve learned_local_le_implies : eo.

  Definition learned_if_knows (eo : EventOrdering) :=
    forall (d  : lak_data) (e : Event),
      learned e d
      -> has_correct_trace_before e (lak_data2node d)
      ->
      exists e',
        e' ≺ e
        /\ loc e' = lak_data2node d
        /\ knows e' d.

  Lemma learns_if_knows_implies_learned_if_knows :
    forall (eo : EventOrdering),
      learns_if_knows eo
      -> learned_if_knows eo.
  Proof.
    introv lik l hc.
    unfold learned in l; exrepnd.
    apply lik in l0; autodimp l0 hyp; eauto 3 with eo.
    exrepnd.
    exists e'0; dands; eauto 3 with eo.
  Qed.
  Hint Resolve learns_if_knows_implies_learned_if_knows : eo.

  Lemma knows_weak_certificate :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      F < n
      -> knows_certificate e n i P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists d,
        has_correct_trace_before e (lak_data2node d)
        /\ knows e d
        /\ i = lak_data2info d.
  Proof.
    introv cond kn atmost ein.
    unfold knows_certificate in *.
    destruct kn as [l [len [norep [condp imp]]]]; repnd.
    pose proof (there_is_one_correct_before eo (map lak_data2owner l) E F) as q.
    repeat (autodimp q hyp); autorewrite with list in *; try omega.
    exrepnd.
    allrw in_map_iff; exrepnd; subst.
    applydup imp in q2; repnd; simpl in *.
    exists x; dands; auto.
  Qed.

  Lemma knows_weak_certificate_propagates :
    forall {eo : EventOrdering}
           (e : Event)
           (n : nat)
           (i : lak_info)
           (P : list lak_data -> Prop)
           (E : list Event)
           (F : nat),
      learns_or_knows eo
      -> learns_if_knows eo
      -> F < n
      -> knows_certificate e n i P
      -> exists_at_most_f_faulty E F
      -> In e E
      ->
      exists e' d,
        e' ≼ e
        /\ loc e' = lak_data2node d
        /\ knows e' d
        /\ i = lak_data2info d.
  Proof.
    introv lok lik cond kn atmost ein.
    eapply knows_weak_certificate in kn; eauto; exrepnd; subst.
    apply knows_propagates in kn2; auto.
    exrepnd.
    exists e' d; dands; auto.
  Qed.

End LearnAndKnow.

Ltac prove_knows :=
  match goal with
  | [ |- knows _ _ ] =>
    eapply implies_knows; simpl;[| |eassumption];auto;
    autorewrite with eo; auto
  end.

Hint Resolve implies_knows : eo.
Hint Resolve learned_local_pred_implies : eo.
Hint Resolve learned_local_le_implies : eo.
Hint Resolve learns_if_knows_implies_learned_if_knows : eo.
Hint Resolve knows_implies_correct : eo.