From ITree Require Import ITree.
From compcert Require Import Maps AST Values Memory Globalenvs Ctypes.
From compcert Require Coqlib Clight Clightdefs.
From Paco Require Import paco.

Require Import Arith ZArith Bool.
Require Import String List Lia.

Require Import sflib.
Require Import Axioms StdlibExt IntegersExt ITreeTac.

Require Import SysSem.
Require Import IPModel DiscreteTimeModel IntByteModel.
Require Import OSModel OSNodes.
Require Import ProgSem CProgEventSem.
Require Import ProgSim CProgSimLemmas.
Require Import RTSysEnv MWITree.

(* Require Import SystemParams. *)
(* Require Import SystemDefs ITreeSpec. *)
(* Require Import SystemEventSem. *)
Require Import config_prm main_prm SystemProgs.
Require Import dev.
Require Import VerifProgBase.
Require Import VerifMainUtil.
Require Import PALSSystem.

Require Import AcStSystem.
Require Import LinkDevice.
Require Import SpecDevice.

Import Clight Clightdefs.
Import ITreeNotations.
Import ActiveStandby.

Import DevState.

Set Nested Proofs Allowed.
(* Arguments app : simpl nomatch. *)
Local Transparent Archi.ptr64.
Local Opaque Z.of_nat Z.to_nat.

(* Arguments Nat.mul: simpl never. *)
Arguments Nat.mul: simpl never.

Opaque globalenv.

Local Open Scope Z.

Definition dev_gvar_ids := map fst dev_gvar_ilist.
Definition dev_gfun_ids := map fst dev_gfun_ilist.
Definition dev_cenv_ids := map fst dev_cenv_ilist.

Record mem_dst_blk (m: mem) (st: DevState.t) (b_cst: block): Prop :=
  MemDevState {
      mem_dst_owner_status:
        Mem.loadbytes m b_cst 0 1 =
        Some [Byte (Byte.repr (owner_status_to_Z (owner_status st)))] ;
      mem_dst_demand: Mem.loadbytes m b_cst 1 1 =
                      Some [Byte (Byte.repr (Z.of_nat (demand st)))] ;

      mem_dst_perm:
        Mem.range_perm m b_cst 0 2 Cur Writable;
    }.

Lemma store_set_owner_status
      (is_owner: bool) zown m m' st b
      (MEM_DST: mem_dst_blk m st b)
      (ZOWN: zown = if is_owner then 1 else 2)
      (STORE: Mem.store Mint8signed m b 0
                        (Vint (Int.repr zown)) = Some m')
  : mem_dst_blk m' (set_owner_status is_owner st) b.
Proof.
  destruct st as [own dmd].
  inv MEM_DST.
  unfold set_owner_status. ss.

  hexploit store_unchanged_on'; eauto.
  s. unfold mem_range. i.

  econs; s.
  - eapply Mem.loadbytes_store_same in STORE. ss.
    rewrite STORE.
    destruct is_owner; ss.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    ii. nia.
  - ii. eapply Mem.perm_store_1; eauto.
Qed.

Lemma store_set_demand
      (new_dmd: nat) m m' st b
      (MEM_DST: mem_dst_blk m st b)
      (STORE: Mem.store Mint8signed m b 1
                        (Vint (Int.repr (Z.of_nat new_dmd))) = Some m')
  : mem_dst_blk m' (set_demand new_dmd st) b.
Proof.
  destruct st as [own dmd].
  inv MEM_DST.
  unfold set_owner_status. ss.

  hexploit store_unchanged_on'; eauto.
  s. unfold mem_range. i.

  econs; s.
  - eapply Mem.loadbytes_unchanged_on; eauto.
    ii. nia.
  - eapply Mem.loadbytes_store_same in STORE. ss.
    rewrite STORE.
    unfold inj_bytes, encode_int. s.
    rewrite rev_if_be_single. s.
    do 3 f_equal.

    symmetry.
    apply signed_byte_int_unsigned_repr_eq.
  - ii. eapply Mem.perm_store_1; eauto.
Qed.

Lemma reduce_demand_eq
      st
  : reduce_demand st = set_demand (pred (demand st)) st.
Proof.
  destruct st; ss.
Qed.

Section MEMORY_INV.

  Variable ge: genv.

  Let fsymb (id: ident) (bpred: block -> Prop): Prop :=
    forall b (FIND_SYMB: Genv.find_symbol ge id = Some b),
      bpred b.

  Definition mem_dst (m: mem) (dst: DevState.t): Prop :=
    fsymb _state (mem_dst_blk m dst).

  Definition mem_acq (m: mem): Prop :=
    fsymb _acq_msg
          (fun b_acq => Mem.loadbytes m b_acq 0 8 =
                     Some (inj_bytes acq_msg)).

  Definition mem_rel (m: mem): Prop :=
    fsymb _rel_msg
          (fun b_rel => Mem.loadbytes m b_rel 0 8 =
                     Some (inj_bytes rel_msg)).

  Definition inv_dev
             (ast: DevState.t) (m: mem): Prop :=
    <<DST_WF: DevState.wf ast>> /\
    <<MEM_DST: mem_dst m ast>> /\
    <<MEM_ACQ: mem_acq m>> /\
    <<MEM_REL: mem_rel m>>.

  Lemma mem_dst_unch
        ast m m'
        (MEM_DST : mem_dst m ast)
        (MEM_UNCH : Mem.unchanged_on (blocks_of ge [_state]) m m')
    : mem_dst m' ast.
  Proof.
    rr. rr in MEM_DST. i.
    hexploit MEM_DST.
    { apply FIND_SYMB. }
    inversion 1.

    assert (forall i, blocks_of ge [_state] b i).
    { unfold blocks_of. i.
      exists _state.
      split.
      * clear. ss. eauto.
      * apply FIND_SYMB.
    }

    econs;
      try by eapply Mem.loadbytes_unchanged_on; eauto.
    ii. eapply Mem.perm_unchanged_on; eauto.
  Qed.

  Lemma mem_dst_unch_diffblk
        ast m m' b
        (MEM_DST : mem_dst m ast)
        (MEM_UNCH : mem_changed_block b m m')
        (FSYMB: Genv.find_symbol ge _state <> Some b)
    : mem_dst m' ast.
  Proof.
    eapply mem_dst_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of. i.
    simpl in *. des; ss.
    ii. subst. ss.
  Qed.

  Lemma mem_acq_unch
        m m'
        (MEM_ACQ : mem_acq m)
        (MEM_UNCH : Mem.unchanged_on (blocks_of ge [_acq_msg]) m m')
    : mem_acq m'.
  Proof.
    rr. rr in MEM_ACQ. i.
    hexploit MEM_ACQ.
    { apply FIND_SYMB. }
    i. eapply Mem.loadbytes_unchanged_on; eauto.
    unfold blocks_of.
    intros _ _.
    exists _acq_msg.
    splits.
    - clear. ss. eauto.
    - apply FIND_SYMB.
  Qed.

  Lemma mem_acq_unch_diffblk
        m m' b
        (MEM_DST : mem_acq m)
        (MEM_UNCH : mem_changed_block b m m')
        (FSYMB: Genv.find_symbol ge _acq_msg <> Some b)
    : mem_acq m'.
  Proof.
    eapply mem_acq_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of. i.
    simpl in *. des; ss.
    ii. subst. ss.
  Qed.

  Lemma mem_rel_unch
        m m'
        (MEM_REL : mem_rel m)
        (MEM_UNCH : Mem.unchanged_on (blocks_of ge [_rel_msg]) m m')
    : mem_rel m'.
  Proof.
    rr. rr in MEM_REL. i.
    hexploit MEM_REL.
    { apply FIND_SYMB. }
    i. eapply Mem.loadbytes_unchanged_on; eauto.
    unfold blocks_of.
    intros _ _.
    exists _rel_msg.
    splits.
    - clear. ss. eauto.
    - apply FIND_SYMB.
  Qed.

  Lemma mem_rel_unch_diffblk
        m m' b
        (MEM_DST : mem_rel m)
        (MEM_UNCH : mem_changed_block b m m')
        (FSYMB: Genv.find_symbol ge _rel_msg <> Some b)
    : mem_rel m'.
  Proof.
    eapply mem_rel_unch; eauto.
    eapply Mem.unchanged_on_implies; eauto.
    unfold blocks_of. i.
    simpl in *. des; ss.
    ii. subst. ss.
  Qed.

  Lemma inv_dev_dep_app_blocks
    : forall (ast : DevState.t) (m m' : mem)
        (INV: inv_dev ast m)
        (MEM_UNCH: Mem.unchanged_on (blocks_of ge dev_gvar_ids) m m'),
      inv_dev ast m'.
  Proof.
    unfold inv_dev. i. des.
    splits.
    - ss.
    - eapply mem_dst_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      unfold blocks_of. ss.
      i. des; ss.
      clarify. esplits; eauto.
    - eapply mem_acq_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      unfold blocks_of. ss.
      i. des; ss.
      clarify.
      exists _acq_msg. esplits; eauto.
    - eapply mem_rel_unch; eauto.
      eapply Mem.unchanged_on_implies; eauto.
      unfold blocks_of. ss.
      i. des; ss.
      clarify.
      exists _rel_msg. esplits; eauto.
  Qed.

End MEMORY_INV.

Section MEM_INIT.

  Variable tid: nat.
  Variable cprog: Clight.program.

  Hypothesis CPROG_EQ: __guard__ (cprog = prog_dev (Z.of_nat tid)).
  Notation ge := (globalenv cprog).

  Let GENV_PROPS
    : genv_props (globalenv cprog)
                 (main_gvar_ilist tid ++ dev_gvar_ilist)
                 (main_gfun_ilist ++ dev_gfun_ilist)
                 (main_cenv_ilist ++ dev_cenv_ilist).
  Proof.
    rewrite CPROG_EQ.
    apply (genv_props_dev tid).
  Qed.

  Lemma inv_dev_init:
    forall (m_i : mem),
      Genv.init_mem cprog = Some m_i ->
      inv_dev ge DevState.init m_i.
  Proof.
    intros m_i INIT_MEM. r.
    split.
    { apply DevState.wf_init. }

    assert (DEFMAP: (prog_defmap cprog) ! _state = Some (Gvar v_state) /\
                    (prog_defmap cprog) ! _acq_msg = Some (Gvar v_acq_msg) /\
                    (prog_defmap cprog) ! _rel_msg = Some (Gvar v_rel_msg)).
    { rewrite CPROG_EQ.
      change (prog_defmap (prog_dev (Z.of_nat tid))) with
          (PTree.combine Linking.link_prog_merge
                         (prog_defmap prog_mw) (prog_defmap (dev.prog (Z.of_nat tid)))).
      do 3 rewrite PTree.gcombine by ss.
      splits.
      - replace ((prog_defmap prog_mw) ! _state) with
            (@None (globdef fundef type)).
        2: {
          change (prog_defmap prog_mw) with
              (PTree.combine Linking.link_prog_merge
                             (prog_defmap config_prog)
                             (prog_defmap main_prog)).
          rewrite PTree.gcombine by ss.
          ss.
        }
        ss.
      - replace ((prog_defmap prog_mw) ! _acq_msg) with
            (@None (globdef fundef type)).
        2: {
          change (prog_defmap prog_mw) with
              (PTree.combine Linking.link_prog_merge
                             (prog_defmap config_prog)
                             (prog_defmap main_prog)).
          rewrite PTree.gcombine by ss.
          ss.
        }
        ss.
      - replace ((prog_defmap prog_mw) ! _rel_msg) with
            (@None (globdef fundef type)).
        2: {
          change (prog_defmap prog_mw) with
              (PTree.combine Linking.link_prog_merge
                             (prog_defmap config_prog)
                             (prog_defmap main_prog)).
          rewrite PTree.gcombine by ss.
          ss.
        }
        ss.
    }
    destruct DEFMAP as (DEFMAP1 & DEFMAP2 & DEFMAP3).

    splits.
    - (* dev_state *)
      intros b_dst FSYMB_DST.

      apply Genv.find_def_symbol in DEFMAP1.
      destruct DEFMAP1 as (b_dst' & FSYMB_DST' & FDEF_DST).

      replace (Genv.globalenv cprog) with
          (genv_genv (globalenv cprog)) in FSYMB_DST' by ss.
      fold fundef in FSYMB_DST'.
      rewrite FSYMB_DST in FSYMB_DST'.
      symmetry in FSYMB_DST'. inv FSYMB_DST'.

      eapply Genv.init_mem_characterization_gen in INIT_MEM.
      r in INIT_MEM.
      exploit INIT_MEM; eauto. s.
      intros (RANGE_PERM & PERM & LOAD & LOADBYTES).

      hexploit LOADBYTES; eauto.
      rewrite Z.max_l by ss.
      replace (Z.to_nat 2) with 2%nat by ss.
      rewrite app_nil_r. s.
      replace 2 with (1 + 1) by ss.

      clear LOADBYTES. intro LOADBYTES.
      apply Mem_loadbytes_split' in LOADBYTES; try nia.
      des; ss.

    - intros b FSYMB.
      apply Genv.find_def_symbol in DEFMAP2.
      destruct DEFMAP2 as (b' & FSYMB' & FDEF).

      replace (Genv.globalenv cprog) with
          (genv_genv (globalenv cprog)) in FSYMB' by ss.
      fold fundef in FSYMB'.
      rewrite FSYMB in FSYMB'.
      symmetry in FSYMB'. clarify.

      eapply Genv.init_mem_characterization_gen in INIT_MEM.
      r in INIT_MEM.
      exploit INIT_MEM; eauto. s.
      intros (RANGE_PERM & PERM & LOAD & LOADBYTES).

      rewrite LOADBYTES by ss.
      ss.
    - intros b FSYMB.
      apply Genv.find_def_symbol in DEFMAP3.
      destruct DEFMAP3 as (b' & FSYMB' & FDEF).

      replace (Genv.globalenv cprog) with
          (genv_genv (globalenv cprog)) in FSYMB' by ss.
      fold fundef in FSYMB'.
      rewrite FSYMB in FSYMB'.
      symmetry in FSYMB'. clarify.

      eapply Genv.init_mem_characterization_gen in INIT_MEM.
      r in INIT_MEM.
      exploit INIT_MEM; eauto. s.
      intros (RANGE_PERM & PERM & LOAD & LOADBYTES).

      rewrite LOADBYTES by ss.
      ss.
  Qed.

End MEM_INIT.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*  Tactics for proving Clight code of the Compcert verified compiler  *)
(*                                                                     *)
(*                 Developed by Xiongnan (Newman) Wu                   *)
(*                                                                     *)
(*                         Yale University                             *)
(*                                                                     *)
(* *********************************************************************)

(** This file develops the tactics for proving the Clight code using the
    Compcert verified compiler. The main tactic vcgen is the
    verification condition generator for special Clight code. It applies
    the Bigstep operational semantics of the Clight 2 language to generate
    verification condition for a loop-free clight statement where all the
    expression can be evaluated out using the knowledge in the context,
    i.e., if the statement contains conditional statement, appropiate
    case analysis on the conditional expressions need to be applied before
    the application of the vcgen tactic so that the evaluation can go through.
    In presense of loops, the loop has to be proved separately for its
    specification and loop termination. This can be done using a saparate
    frameworks deleloped in LoopProof.v. We recommand to use the version
    of the framework with while loop with no Break, Continue, or Return
    statement in the while body, so that the proof of the loop body can
    still be automated with the vcgen tactic.

Currently we assume:
- We never take address of a local variable in the stack.
- No use of C union.

 *)

Require Import Coqlib.
Require Import Maps.
Require Import Integers.
Require Import Values.
Require Import MemoryExtra.
Require Import EventsExtra.
Require Import Clight.
Require Import Smallstep.
Require Import ClightBigstep.
Require Import Cop.
Require Import Ctypes.
Require Import DataType.
Require Import ZArith.

Hint Unfold Int.max_unsigned.
Hint Unfold Int.modulus.
Hint Unfold Int.half_modulus.

Global Opaque PTree.get PTree.set "!" Z.land Z.lor.

(** * Frequently used lemmas in tactics. *)

Lemma zadd_rm_head: forall n p q, p = q -> n + p = n + q.
Proof.
  intros.
  rewrite H.
  trivial.
Qed.

Lemma zadd_rm_tail: forall n p q, p = q -> p + n = q + n.
Proof.
  intros.
  rewrite H.
  trivial.
Qed.

Lemma zdiv_range_le_lt : forall a b c x: Z, a <= 0 -> b > 0 -> c > 0 -> a <= x < b -> a <= x/ c < b.
Proof.
  intros.
  destruct H2.
  split.
  apply Zdiv_le_lower_bound.
  omega.
  assert(a * c <= a).
  assert(- a * c >= - a).
  rewrite <- Zmult_1_r.
  assert(c >= 1) by omega.
  apply Zmult_ge_compat_l.
  omega.
  omega.
  rewrite Zopp_mult_distr_l_reverse in H4.
  omega.
  omega.
  apply Zdiv_lt_upper_bound.
  omega.
  assert(b <= b * c).
  rewrite <- Zmult_1_r at 1.
  assert(1 <= c) by omega.
  apply Zmult_le_compat_l.
  omega.
  omega.
  omega.
Qed.

Lemma zdiv_range_le_le : forall a b c x: Z, a <= 0 -> b > 0 -> c > 0 -> a <= x <= b -> a <= x/ c <= b.
Proof.
  intros.
  destruct H2.
  split.
  apply Zdiv_le_lower_bound.
  omega.
  assert(a * c <= a).
  assert(- a * c >= - a).
  rewrite <- Zmult_1_r.
  assert(c >= 1) by omega.
  apply Zmult_ge_compat_l.
  omega.
  omega.
  rewrite Zopp_mult_distr_l_reverse in H4.
  omega.
  omega.
  apply Zdiv_le_upper_bound.
  omega.
  assert(b <= b * c).
  rewrite <- Zmult_1_r at 1.
  assert(1 <= c) by omega.
  apply Zmult_le_compat_l.
  omega.
  omega.
  omega.
Qed.

Lemma max_unsigned_gt0: Int.max_unsigned > 0.
Proof.
  repeat autounfold.
  simpl.
  omega.
Qed.

Lemma max_unsigned_val: Int.max_unsigned  = 4294967295.
Proof.
  repeat autounfold; reflexivity.
Qed.

Lemma unsigned_inj : forall a b, Int.unsigned a = Int.unsigned b -> a = b.
Proof.
  intros. rewrite <- (Int.repr_unsigned a).
  rewrite <- (Int.repr_unsigned b).
  f_equal.
  trivial.
Qed.

Lemma minus1lt: forall i:Z, i - 1 < i.
Proof.
  intro.
  omega.
Qed.

Lemma Z_land_range_lo: forall x y, 0 <= x -> 0 <= Z.land x y.
Proof.
  intros.
  rewrite Z.land_nonneg.
  left.
  assumption.
Qed.

Lemma Z_land_range_lo_r: forall x y, 0 <= y -> 0 <= Z.land x y.
Proof.
  intros.
  rewrite Z.land_nonneg.
  right.
  assumption.
Qed.

Lemma Z_land_range_hi: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> Z.land x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val.
  intros.
  assert(Z.land x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.land x y) <= Z.min (Z.log2 x) (Z.log2 y)).
  apply Z.log2_land.
  omega.
  omega.
  rewrite Zmin_spec in H1.
  destruct (zlt (Z.log2 x) (Z.log2 y)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_land_range: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> 0 <= Z.land x y <= Int.max_unsigned.
Proof.
  split.
  apply Z_land_range_lo; omega.
  apply Z_land_range_hi; omega.
Qed.

Lemma Z_lor_range_lo: forall x y, 0 <= x -> 0 <= y -> 0 <= Z.lor x y.
Proof.
  intros.
  apply Z.lor_nonneg; auto.
Qed.

Lemma Z_lor_range_hi: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> Z.lor x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val; simpl.
  intros.
  assert(Z.lor x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.lor x y) = Z.max (Z.log2 x) (Z.log2 y)).
  apply Z.log2_lor.
  omega.
  omega.
  rewrite H1.
  rewrite Zmax_spec in *.
  destruct (zlt (Z.log2 y) (Z.log2 x)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_lor_range: forall x y, 0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned -> 0 <= Z.lor x y <= Int.max_unsigned.
Proof.
  intros.
  split.
  apply Z_lor_range_lo; omega.
  apply Z_lor_range_hi; omega.
Qed.

Lemma Z_lxor_range :
  forall x y,
    0 <= x <= Int.max_unsigned -> 0 <= y <= Int.max_unsigned ->
    0 <= Z.lxor x y <= Int.max_unsigned.
Proof.
  rewrite max_unsigned_val; simpl.
  intros.
  split.
  rewrite Z.lxor_nonneg.
  split; omega.
  assert(Z.lxor x y < 4294967296).
  apply Z.log2_lt_cancel.
  assert(Z.log2 (Z.lxor x y) <= Z.max (Z.log2 x) (Z.log2 y)).
  apply Z.log2_lxor.
  omega.
  omega.
  apply Z.le_lt_trans with (m := Z.max (Z.log2 x) (Z.log2 y)); auto.
  rewrite Zmax_spec in *.
  destruct (zlt (Z.log2 y) (Z.log2 x)).
  assert(Z.log2 x <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  assert(Z.log2 y <= Z.log2 4294967295).
  apply Z.log2_le_mono.
  omega.
  simpl in *.
  omega.
  omega.
Qed.

Lemma Z_shiftl_16_range :
  forall x,
    0 <= x < 65536 -> 0 <= Z.shiftl x 16 <= Int.max_unsigned.
Proof.
  unfold Int.max_unsigned. simpl (Int.modulus - 1).
  intros.
  split.
  rewrite Z.shiftl_nonneg. omega.

  assert (Z.shiftl x 16 < 4294967296).
  case_eq (zeq x 0); intros; subst.

  (* x = 0 *)
  simpl. omega.

  (* x <> 0 *)
  apply Z.log2_lt_cancel.
  rewrite Z.log2_shiftl; try omega.

  assert (Z.log2 x <= Z.log2 65535).
  apply Z.log2_le_mono. omega.
  simpl in *. omega.

  omega.
Qed.

(** * Hints for autorewrite *)

Lemma unsigned_zero: Int.unsigned Int.zero = 0.
Proof. reflexivity. Qed.

Lemma unsigned_one: Int.unsigned Int.one = 1.
Proof. reflexivity. Qed.

Lemma eq_one_zero: Int.eq Int.one Int.zero = false.
Proof. reflexivity. Qed.

Lemma eq_zero_zero: Int.eq Int.zero Int.zero = true.
Proof. reflexivity. Qed.

Lemma negb_true: negb true = false.
Proof. reflexivity. Qed.

Lemma negb_false: negb false = true.
Proof. reflexivity. Qed.

Lemma repr_zero: Int.repr 0 = Int.zero.
Proof. reflexivity. Qed.

Lemma repr_one: Int.repr 1 = Int.one.
Proof. reflexivity. Qed.

Lemma and_zero_zero: Z.land 0 0 = 0.
Proof. reflexivity. Qed.

Lemma and_one_zero: Z.land 1 0 = 0.
Proof. reflexivity. Qed.

Lemma and_zero_one: Z.land 0 1 = 0.
Proof. reflexivity. Qed.

Lemma and_one_one: Z.land 1 1 = 1.
Proof. reflexivity. Qed.

Lemma or_zero_zero: Z.lor 0 0 = 0.
Proof. reflexivity. Qed.

Lemma or_one_zero: Z.lor 1 0 = 1.
Proof. reflexivity. Qed.

Lemma or_zero_one: Z.lor 0 1 = 1.
Proof. reflexivity. Qed.

Lemma or_one_one: Z.lor 1 1 = 1.
Proof. reflexivity. Qed.

Hint Rewrite unsigned_zero unsigned_one eq_one_zero eq_zero_zero negb_true negb_false repr_zero repr_one: arith.
Hint Rewrite and_zero_zero and_zero_one and_one_zero and_one_one or_zero_zero or_zero_one or_one_zero or_one_one : arith.


From iris.program_logic Require Export weakestpre.
From iris.program_logic Require Import ectx_lifting.
From iris.base_logic Require Export invariants.
From iris.algebra Require Import auth frac agree gmap.
From iris.proofmode Require Import proofmode.
From iris.base_logic Require Export gen_heap.
From RobustSafety Require Export lang.
From iris.prelude Require Import options.

(** The CMRA for the heap of the implementation. This is linked to the
    physical heap. *)
Class heapIG Σ := HeapIG {
  heapI_invG : invGS Σ;
  heapI_gen_heapG :> gen_heapGS loc val Σ;
}.

Class heapPG Σ := HeapPG {
  heapP_invG : invGpreS Σ;
  heapP_gen_heapG :> gen_heapGpreS loc val Σ;
}.

Definition heapΣ := #[invΣ; gen_heapΣ loc val].

Global Instance: ∀ Σ, subG heapΣ Σ → heapPG Σ.
Proof. solve_inG. Qed.

Global Instance heapIG_irisG `{heapIG Σ} : irisGS LambdaRS_lang Σ := {
  iris_invGS := heapI_invG;
  num_laters_per_step _ := 0;
  state_interp σ  _ _ _ := (gen_heap_interp (Heap σ) ∗ ⌜Failure σ = false⌝)%I;
  fork_post _ := True%I;
  state_interp_mono _ _ _ _ := fupd_intro _ _
}.

Notation "l ↦{ dq } v" := (mapsto (L:=loc) (V:=val) l dq v)
  (at level 20, format "l  ↦{ dq }  v") : bi_scope.
Notation "l ↦□ v" := (mapsto (L:=loc) (V:=val) l DfracDiscarded v)
  (at level 20, format "l  ↦□  v") : bi_scope.
Notation "l ↦{# q } v" := (mapsto (L:=loc) (V:=val) l (DfracOwn q) v)
  (at level 20, format "l  ↦{# q }  v") : bi_scope.
Notation "l ↦ v" := (mapsto (L:=loc) (V:=val) l (DfracOwn 1) v)
  (at level 20, format "l  ↦  v") : bi_scope.

Section lang_rules.
  Context `{heapIG Σ}.
  Implicit Types P Q : iProp Σ.
  Implicit Types Φ : val → iProp Σ.
  Implicit Types σ : state.
  Implicit Types e : expr.
  Implicit Types v w : val.

  Ltac inv_head_step :=
  repeat match goal with
  | _ => progress simplify_map_eq/= (* simplify memory stuff *)
  | H : to_val _ = Some _ |- _ => apply of_to_val in H
  | H : _ = of_val ?v |- _ =>
     is_var v; destruct v; first[discriminate H|injection H as H]
  | H : head_step ?e _ _ _ _ _ |- _ =>
     try (is_var e; fail 1); (* inversion yields many goals if [e] is a variable
     and can thus better be avoided. *)
     inversion H; subst; clear H
  end.

  Local Hint Extern 0 (atomic _) => solve_atomic : core.
  Local Hint Extern 0 (head_reducible _ _) => eexists _, _, _, _; simpl : core.

  Local Hint Constructors head_step : core.
  Local Hint Resolve alloc_fresh : core.
  Local Hint Resolve to_of_val : core.

  (** Base axioms for core primitives of the language: Stateful reductions. *)
  Lemma wp_alloc E e v :
    IntoVal e v →
    {{{ True }}} Alloc e @ E {{{ l, RET (LocV l); l ↦ v }}}.
  Proof.
    iIntros (<- Φ) "_ HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>"; iSplit; first by auto.
    iNext; iIntros (v2 σ2 efs Hstep) "_"; inv_head_step.
    iMod (@gen_heap_alloc with "Hh") as "(Hh & Hl & _)"; first done.
    iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_load E l dq v :
    {{{ ▷ l ↦{dq} v }}} Load (Loc l) @ E {{{ RET v; l ↦{dq} v }}}.
  Proof.
    iIntros (Φ) ">Hl HΦ". iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>". iDestruct (@gen_heap_valid with "Hh Hl") as %?.
    iSplit; first by eauto.
    iNext; iIntros (v2 σ2 efs Hstep) "_"; inv_head_step.
    iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_store E l v' e v :
    IntoVal e v →
    {{{ ▷ l ↦ v' }}} Store (Loc l) e @ E
    {{{ RET UnitV; l ↦ v }}}.
  Proof.
    iIntros (<- Φ) ">Hl HΦ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>". iDestruct (@gen_heap_valid with "Hh Hl") as %?.
    iSplit; first by eauto. iNext; iIntros (v2 σ2 efs Hstep) "_"; inv_head_step.
    iMod (@gen_heap_update with "Hh Hl") as "[$ Hl]".
    iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_cas_fail E l dq v' e1 v1 e2 v2 :
    IntoVal e1 v1 → IntoVal e2 v2 → v' ≠ v1 →
    {{{ ▷ l ↦{dq} v' }}} CAS (Loc l) e1 e2 @ E
    {{{ RET (BoolV false); l ↦{dq} v' }}}.
  Proof.
    iIntros (<- <- ? Φ) ">Hl HΦ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>". iDestruct (@gen_heap_valid with "Hh Hl") as %?.
    iSplit; first by eauto.
    iNext; iIntros (v2' σ2 efs Hstep) "_"; inv_head_step.
    iModIntro; iSplit=> //. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_cas_suc E l e1 v1 e2 v2 :
    IntoVal e1 v1 → IntoVal e2 v2 →
    {{{ ▷ l ↦ v1 }}} CAS (Loc l) e1 e2 @ E
    {{{ RET (BoolV true); l ↦ v2 }}}.
  Proof.
    iIntros (<- <- Φ) ">Hl HΦ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>". iDestruct (@gen_heap_valid with "Hh Hl") as %?.
    iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep) "_"; inv_head_step.
    iMod (@gen_heap_update with "Hh Hl") as "[$ Hl]".
    iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_FAA E l m e2 k :
    IntoVal e2 (#nv k) →
    {{{ ▷ l ↦ (#nv m) }}} FAA (Loc l) e2 @ E
    {{{ RET (#nv m); l ↦ #nv (m + k) }}}.
  Proof.
    iIntros (<- Φ) ">Hl HΦ".
    iApply wp_lift_atomic_head_step_no_fork; auto.
    iIntros (σ1 ????) "[Hh Hfl] !>". iDestruct (@gen_heap_valid with "Hh Hl") as %?.
    iSplit; first by eauto. iNext; iIntros (v2' σ2 efs Hstep) "_"; inv_head_step.
    iMod (@gen_heap_update with "Hh Hl") as "[$ Hl]".
    iModIntro. iSplit=>//. iFrame. by iApply "HΦ".
  Qed.

  Lemma wp_fork E s e Φ :
    ▷ (|={E}=> Φ UnitV) ∗ ▷ WP e @ s; ⊤ {{ _, True }} ⊢ WP Fork e @ s; E {{ Φ }}.
  Proof.
    iIntros "[He HΦ]". iApply wp_lift_atomic_head_step; [done|].
    iIntros (σ1 ????) "Hσ !>"; iSplit; first by eauto.
    iNext; iIntros (v2 σ2 efs Hstep) "_"; inv_head_step. by iFrame.
  Qed.

  Local Ltac solve_exec_safe := intros; subst; do 3 eexists; econstructor; eauto.
  Local Ltac solve_exec_puredet := simpl; intros; by inv_head_step.
  Local Ltac solve_pure_exec :=
    unfold IntoVal in *;
    repeat match goal with H : AsVal _ |- _ => destruct H as [??] end; subst;
    intros ?; apply nsteps_once, pure_head_step_pure_step;
      constructor; [solve_exec_safe | solve_exec_puredet].

  Global Instance pure_rec e1 e2 `{!AsVal e2} :
    PureExec True 1 (App (Rec e1) e2) e1.[(Rec e1), e2 /].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_lam e1 e2 `{!AsVal e2} :
    PureExec True 1 (App (Lam e1) e2) e1.[e2 /].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_LetIn e1 e2 `{!AsVal e1} :
    PureExec True 1 (LetIn e1 e2) e2.[e1 /].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_seq e1 e2 `{!AsVal e1} :
    PureExec True 1 (Seq e1 e2) e2.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_fst e1 e2 `{!AsVal e1, !AsVal e2} :
    PureExec True 1 (Fst (Pair e1 e2)) e1.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_snd e1 e2 `{!AsVal e1, !AsVal e2} :
    PureExec True 1 (Snd (Pair e1 e2)) e2.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_case_inl e0 e1 e2 `{!AsVal e0}:
    PureExec True 1 (Case (InjL e0) e1 e2) e1.[e0/].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_case_inr e0 e1 e2 `{!AsVal e0}:
    PureExec True 1 (Case (InjR e0) e1 e2) e2.[e0/].
  Proof. solve_pure_exec. Qed.

  Global Instance pure_if_true e1 e2 :
    PureExec True 1 (If (#♭ true) e1 e2) e1.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_if_false e1 e2 :
    PureExec True 1 (If (#♭ false) e1 e2) e2.
  Proof. solve_pure_exec. Qed.

  Global Instance pure_nat_binop op a b :
    PureExec True 1 (BinOp op (#n a) (#n b)) (of_val (binop_eval op a b)).
  Proof. solve_pure_exec. Qed.

  Global Instance pure_assert_true :
    PureExec True 1 (Assert (#♭ true)) Unit.
  Proof. solve_pure_exec. Qed.

  (* stuck rules *)

  Lemma var_stuck x Φ : ⊢ WP Var x ? {{v, Φ v}}.
  Proof.
    iApply wp_lift_pure_head_stuck; [done| |by split; [done|inversion 1]].
    intros K ?; destruct K as [|[]] using rev_ind; simpl; try rewrite fill_app; inversion 1; done.
  Qed.

  Lemma binop_stuck op v1 v2 Φ :
    non_nat_val v1 ∨ non_nat_val v2 →
    ⊢ WP BinOp op (of_val v1) (of_val v2) ? {{v, Φ v}}.
  Proof.
    intros Hnn.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heqop Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[Heqop Heqv1 Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v1; destruct v2;
        simplify_eq/=; destruct Hnn as [Hnn|Hnn]; inversion Hnn.
  Qed.

  Lemma fst_stuck v Φ : non_pair_val v → ⊢ WP Fst (of_val v) ? {{w, Φ w}}.
  Proof.
    intros Hnp.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      inversion 1 as [[Heq]]; simplify_eq.
      assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
      eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v; simplify_eq/=; inversion Hnp.
  Qed.

  Lemma snd_stuck v Φ : non_pair_val v → ⊢ WP Snd (of_val v) ? {{w, Φ w}}.
  Proof.
    intros Hnp.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      inversion 1 as [[Heq]]; simplify_eq.
      assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
      eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v; simplify_eq/=; inversion Hnp.
  Qed.

  Lemma case_stuck v e1 e2 Φ : non_sum_val v → ⊢ WP Case (of_val v) e1 e2 ? {{w, Φ w}}.
  Proof.
    intros Hns.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      inversion 1 as [[Heq]]; simplify_eq.
      assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
      eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v; simplify_eq/=; inversion Hns.
  Qed.

  Lemma if_stuck v e1 e2 Φ : non_bool_val v → ⊢ WP If (of_val v) e1 e2 ? {{w, Φ w}}.
  Proof.
    intros Hnb.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      inversion 1 as [[Heq]]; simplify_eq.
      assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
      eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v; simplify_eq/=; inversion Hnb.
  Qed.

  Lemma app_stuck v1 v2 Φ : non_fun_val v1 → ⊢ WP App (of_val v1) (of_val v2) ? {{w, Φ w}}.
  Proof.
    intros Hnf.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[z Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v1; simplify_eq/=; inversion Hnf.
  Qed.

  Lemma load_stuck v Φ : non_loc_val v → ⊢ WP Load (of_val v) ? {{w, Φ w}}.
  Proof.
    intros Hnl.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      inversion 1 as [[Heq]]; simplify_eq.
      assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
      eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v; simplify_eq/=; inversion Hnl.
  Qed.

  Lemma store_stuck v1 v2 Φ : non_loc_val v1 → ⊢ WP Store (of_val v1) (of_val v2) ? {{w, Φ w}}.
  Proof.
    intros Hnl.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[z Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v1; simplify_eq/=; inversion Hnl.
  Qed.

  Lemma cas_stuck v1 v2 v3 Φ :
    non_loc_val v1 → ⊢ WP CAS (of_val v1) (of_val v2) (of_val v3) ? {{w, Φ w}}.
  Proof.
    intros Hnl.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[z Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[z1 z2 Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v1; simplify_eq/=; inversion Hnl.
  Qed.

  Lemma faa_stuck_non_loc_or_non_nat v1 v2 Φ :
    non_loc_val v1 ∨ non_nat_val v2 → ⊢ WP FAA (of_val v1) (of_val v2) ? {{w, Φ w}}.
  Proof.
    intros Hnln.
    iApply wp_lift_pure_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
      + inversion 1 as [[z Heq]]; simplify_eq.
        assert (is_Some (to_val e')) as [? ?]; last by intros?; simplify_eq.
        eapply fill_val with K; rewrite /= -Heq to_of_val; eauto.
    - split; first done.
      inversion 1; simplify_eq; destruct v1; destruct v2;
        simplify_eq/=; destruct Hnln as [Hnln|Hnln]; inversion Hnln;
        simplify_eq/=;
          repeat match goal with
            HX : context [to_val (of_val _)] |- _ => rewrite to_of_val /= in HX
          end; simplify_eq.
  Qed.

  Lemma faa_stuck_non_nat_loc E l n v Φ :
    non_nat_val v → l ↦ v ⊢ WP FAA (Loc l) (#n n) @ E ? {{w, Φ w}}.
  Proof.
    iIntros (Hnn) "Hl".
    iApply wp_lift_head_stuck; [done| |].
    - intros K e';
        destruct K as [|[] ? _] using rev_ind; simpl; try rewrite fill_app; try by inversion 1.
      + inversion 1 as [[Heq]]; simplify_eq.
        destruct K as [|[] ? _] using rev_ind; rewrite ?fill_app in Heq; simplify_eq/=; done.
      + inversion 1 as [[z Heq]]; simplify_eq.
        destruct K as [|[] ? _] using rev_ind; rewrite ?fill_app in Heq; simplify_eq/=; done.
    - iIntros (σ ns κs nt) "[Hh Hfl]".
      iMod ((fupd_mask_weaken ∅ (P := True)) with "[]") as "_";
        [set_solver|by iIntros "?"; iModIntro|].
      iModIntro.
      iDestruct (@gen_heap_valid with "Hh Hl") as %?.
      iPureIntro.
      split; first done.
      inversion 1; simplify_eq/=; inversion Hnn.
  Qed.

End lang_rules.


Require Import VerdiRaft.Raft.
Require Import VerdiRaft.RaftRefinementInterface.
Local Arguments update {_} {_} _ _ _ _ _ : simpl never.

Require Import VerdiRaft.SpecLemmas.
Require Import VerdiRaft.RefinementSpecLemmas.
Require Import VerdiRaft.CommonTheorems.

Require Import VerdiRaft.RequestVoteMaxIndexMaxTermInterface.
Require Import VerdiRaft.VotedForTermSanityInterface.

Require Import VerdiRaft.VotedForMoreUpToDateInterface.

Section VotedForMoreUpToDate.
  Context {orig_base_params : BaseParams}.
  Context {one_node_params : OneNodeParams orig_base_params}.
  Context {raft_params : RaftParams orig_base_params}.

  Context {rri : raft_refinement_interface}.
  Context {rvmimti : requestVote_maxIndex_maxTerm_interface}.
  Context {vftsi : votedFor_term_sanity_interface}.

  Lemma votedFor_moreUpToDate_append_entries :
    refined_raft_net_invariant_append_entries votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto;
    try rewrite votesWithLog_same_append_entries; eauto.
    - find_copy_eapply_lem_hyp handleAppendEntries_term_votedFor; eauto.
      find_apply_lem_hyp handleAppendEntries_log_term_type.
      intuition; try congruence. repeat find_rewrite. eauto.
    - find_copy_eapply_lem_hyp handleAppendEntries_term_votedFor; eauto.
      intuition; repeat find_rewrite; eauto.
    - find_apply_lem_hyp handleAppendEntries_log_term_type.
      intuition; try congruence. repeat find_rewrite. eauto.
  Qed.

  Lemma votedFor_moreUpToDate_append_entries_reply :
    refined_raft_net_invariant_append_entries_reply votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    find_copy_apply_lem_hyp handleAppendEntriesReply_log_term_type.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto;
    intuition; try congruence; repeat find_rewrite; eauto;
    find_copy_eapply_lem_hyp handleAppendEntriesReply_term_votedFor; eauto;
    intuition; repeat find_rewrite; eauto.
  Qed.

  Lemma votedFor_moreUpToDate_request_vote :
    refined_raft_net_invariant_request_vote votedFor_moreUpToDate.
  Proof using rvmimti.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    find_copy_apply_lem_hyp handleRequestVote_log_term_type.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto;
    intuition; try congruence; repeat find_rewrite; eauto.
    - find_eapply_lem_hyp update_elections_data_request_vote_votedFor; eauto.
      intuition; repeat find_rewrite.
      + eapply_prop_hyp RaftState.votedFor RaftState.votedFor; eauto.
        break_exists_exists; intuition.
        eauto using update_elections_data_request_vote_votesWithLog_old.
      + simpl. eauto using moreUpToDate_refl.
    - find_eapply_lem_hyp update_elections_data_request_vote_votedFor; eauto.
      intuition; repeat find_rewrite.
      + eapply_prop_hyp RaftState.votedFor RaftState.votedFor; eauto.
        break_exists_exists; intuition.
        eauto using update_elections_data_request_vote_votesWithLog_old.
      + find_apply_lem_hyp requestVote_maxIndex_maxTerm_invariant.
        subst.
        eapply_prop_hyp requestVote_maxIndex_maxTerm pBody. conclude_using eauto.
        all:eauto.
        intuition; subst.
        eexists; intuition; eauto.
    - find_eapply_lem_hyp update_elections_data_request_vote_votedFor; eauto.
      intuition; repeat find_rewrite.
      + eapply_prop_hyp RaftState.votedFor RaftState.votedFor; eauto.
        break_exists_exists; intuition.
        eauto using update_elections_data_request_vote_votesWithLog_old.
      + find_apply_lem_hyp requestVote_maxIndex_maxTerm_invariant.
        subst.
        eapply_prop_hyp requestVote_maxIndex_maxTerm pBody. conclude_using eauto.
        all:eauto.
        intuition; subst.
        eexists; intuition; eauto.
  Qed.

  Lemma votedFor_moreUpToDate_request_vote_reply :
    refined_raft_net_invariant_request_vote_reply votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *;
    try rewrite update_elections_data_request_vote_reply_votesWithLog;
    eauto.
    - erewrite handleRequestVoteReply_log; eauto.
      find_copy_eapply_lem_hyp handleRequestVoteReply_log_term_type; eauto.
      find_copy_eapply_lem_hyp handleRequestVoteReply_term_votedFor; eauto.
      intuition. repeat find_rewrite. eauto.
    - find_copy_eapply_lem_hyp handleRequestVoteReply_term_votedFor; eauto.
      intuition. repeat find_rewrite. eauto.
    - erewrite handleRequestVoteReply_log; eauto.
      find_copy_eapply_lem_hyp handleRequestVoteReply_log_term_type; eauto.
      intuition. repeat find_rewrite. eauto.
  Qed.

  Lemma votedFor_moreUpToDate_timeout :
    refined_raft_net_invariant_timeout votedFor_moreUpToDate.
  Proof using vftsi.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto.
    - find_copy_apply_lem_hyp handleTimeout_log_same.
      find_copy_eapply_lem_hyp update_elections_data_timeout_votedFor; eauto.
      intuition; repeat find_rewrite; eauto.
      simpl. eauto using moreUpToDate_refl.
    - find_copy_eapply_lem_hyp update_elections_data_timeout_votedFor; eauto.
      intuition; [repeat find_rewrite; eauto|].
      subst. lia.
    - find_copy_apply_lem_hyp handleTimeout_log_same.
      find_apply_lem_hyp update_elections_data_timeout_votesWithLog_votesReceived.
      intuition; try congruence.
      find_copy_apply_lem_hyp votedFor_term_sanity_invariant.
      eapply_prop_hyp votedFor_term_sanity RaftState.votedFor; eauto.
      unfold raft_data in *; simpl in *; unfold raft_data in *; simpl in *.
      lia.
  Qed.

  Lemma votedFor_moreUpToDate_client_request :
    refined_raft_net_invariant_client_request votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    subst. repeat find_higher_order_rewrite.
    find_copy_apply_lem_hyp handleClientRequest_type; intuition.
    find_copy_apply_lem_hyp handleClientRequest_term_votedFor; intuition.
    destruct_update_hyp; simpl in *; eauto; repeat find_rewrite;
    try rewrite votesWithLog_same_client_request;
    find_apply_lem_hyp handleClientRequest_log;
    intuition; repeat find_rewrite; eauto;
    break_exists; intuition; congruence.
  Qed.

  Lemma votedFor_moreUpToDate_do_leader :
    refined_raft_net_invariant_do_leader votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto;
    try solve [find_apply_lem_hyp doLeader_candidate; subst; eauto].
    find_apply_lem_hyp doLeader_term_votedFor.
    intuition; repeat find_rewrite; eauto.
  Qed.

  Lemma votedFor_moreUpToDate_do_generic_server :
    refined_raft_net_invariant_do_generic_server votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto;
    find_apply_lem_hyp doGenericServer_log_type_term_votesReceived;
    intuition; repeat find_rewrite; eauto.
  Qed.

  Lemma votedFor_moreUpToDate_reboot :
    refined_raft_net_invariant_reboot votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    match goal with
      | H : nwState ?net ?h = (?gd, ?d) |- _ =>
        replace gd with (fst (nwState net h)) in * by (rewrite H; reflexivity);
          replace d with (snd (nwState net h)) in * by (rewrite H; reflexivity);
          clear H
    end.
    subst. repeat find_higher_order_rewrite.
    destruct_update_hyp; simpl in *; eauto; congruence.
  Qed.

  Lemma votedFor_moreUpToDate_state_same_packet_subset :
    refined_raft_net_invariant_state_same_packet_subset votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    subst. repeat find_reverse_higher_order_rewrite.
    eauto.
  Qed.

  Lemma votedFor_moreUpToDate_init :
    refined_raft_net_invariant_init votedFor_moreUpToDate.
  Proof using.
    red. unfold votedFor_moreUpToDate. intros. simpl in *.
    congruence.
  Qed.

  Instance vfmutdi : votedFor_moreUpToDate_interface.
  split.
  intros.
  apply refined_raft_net_invariant; auto.
  - apply votedFor_moreUpToDate_init.
  - apply votedFor_moreUpToDate_client_request.
  - apply votedFor_moreUpToDate_timeout.
  - apply votedFor_moreUpToDate_append_entries.
  - apply votedFor_moreUpToDate_append_entries_reply.
  - apply votedFor_moreUpToDate_request_vote.
  - apply votedFor_moreUpToDate_request_vote_reply.
  - apply votedFor_moreUpToDate_do_leader.
  - apply votedFor_moreUpToDate_do_generic_server.
  - apply votedFor_moreUpToDate_state_same_packet_subset.
  - apply votedFor_moreUpToDate_reboot.
  Qed.

End VotedForMoreUpToDate.


(*
 * Copyright (c) 2020-2021 BedRock Systems, Inc.
 * This software is distributed under the terms of the BedRock Open-Source License.
 * See the LICENSE-BedRock file in the repository root for details.
 *)
From elpi Require Import locker.
From bedrock.prelude Require Import base.
From bedrock.lang.cpp.syntax Require Import names expr stmt types typing.
From bedrock.lang.cpp.semantics Require Import genv.

Definition GlobDecl_size_of (g : GlobDecl) : option N :=
  match g with
  | Gstruct s => Some s.(s_size)
  | Gunion u => Some u.(u_size)
  | Genum t _ =>
    match drop_qualifiers t with
    | Tchar_ sz => Some $ char_type.bytesN sz
    | Tnum sz _ => Some $ bytesN sz
    | Tbool => Some 1%N
    | _ => None
    end
  | _ => None
  end.
Definition GlobDecl_align_of (g : GlobDecl) : option N :=
  match g with
  | Gstruct s => Some s.(s_alignment)
  | Gunion u => Some u.(u_alignment)
  | Genum t _ =>
    match drop_qualifiers t with
    | Tchar_ sz => Some $ char_type.bytesN sz
    | Tnum sz _ => Some $ bytesN sz
    | Tbool => Some 1%N
    | _ => None
    end
  | _ => None
  end.
Variant Roption_leq {T} (R : T -> T -> Prop) : option T -> option T -> Prop :=
| Rleq_None {x} : Roption_leq R None x
| Rleq_Some {x y} (_ : R x y) : Roption_leq R (Some x) (Some y).

#[global] Instance proper_GlobDecl_size_of: Proper (GlobDecl_ler ==> Roption_leq eq) GlobDecl_size_of.
Proof.
  rewrite /GlobDecl_size_of/GlobDecl_ler/GlobDecl_le => x y Heq.
  do 2 case_match; subst; try contradiction; try constructor.
  case_bool_decide; subst; eauto. contradiction.
  case_bool_decide; subst; eauto. contradiction.
  case_bool_decide; subst; eauto. case_match; constructor; eauto. contradiction.
Qed.
#[global] Instance proper_GlobDecl_align_of: Proper (GlobDecl_ler ==> Roption_leq eq) GlobDecl_align_of.
Proof.
  rewrite /GlobDecl_size_of/GlobDecl_ler/GlobDecl_le => x y Heq.
  do 2 case_match; subst; try contradiction; try constructor.
  case_bool_decide; subst; eauto. contradiction.
  case_bool_decide; subst; eauto. contradiction.
  case_bool_decide; subst; eauto. simpl. case_match; constructor; eauto. contradiction.
Qed.

(** * sizeof() *)
(** this is a partial implementation of [size_of] for primitives.
 *)
Fixpoint size_of (resolve : genv) (t : type) : option N :=
  match t with
  | Tpointer _ => Some (pointer_size resolve)
  | Tref _ => None
  | Trv_ref _ => None
  | Tnum sz _ => Some (bytesN sz)
  | Tchar_ ct => Some (char_type.bytesN ct)
  | Tvoid => None
  | Tarray t n => N.mul n <$> size_of resolve t
  | Tnamed nm => glob_def resolve nm ≫= GlobDecl_size_of
  | Tenum nm => glob_def resolve nm ≫= GlobDecl_size_of
  | Tfunction _ _ => None
  | Tbool => Some 1
  | Tmember_pointer _ _ => None (* TODO these are not well supported right now *)
  | Tqualified _ t => size_of resolve t
  | Tnullptr => Some (pointer_size resolve)
  | Tfloat sz => Some (bytesN sz)
  | Tarch sz _ => bytesN <$> sz
  end%N.

#[global] Instance Proper_size_of
  : Proper (genv_leq ==> eq ==> Roption_leq eq) (@size_of).
Proof.
  intros ?? Hle ? t ->; induction t; simpl; (try constructor) => //.
  all: try exact: pointer_size_proper.
  - by destruct IHt; constructor; subst.
  - move: Hle => [[ /(_ g) Hle _] _ _].
    unfold glob_def. rewrite -tu_lookup_globals in Hle.
    destruct ((genv_tu x) !! g) as [g1| ]; last constructor.
    move: Hle => /(_ _ eq_refl). rewrite -tu_lookup_globals.
    move => [g2 [-> HH]] /=.
    exact: proper_GlobDecl_size_of.
  - move: Hle => [[ /(_ g) Hle _] _ _].
    unfold glob_def. rewrite -tu_lookup_globals in Hle.
    destruct ((genv_tu x) !! g) as [g1| ]; last constructor.
    move: Hle => /(_ _ eq_refl). rewrite -tu_lookup_globals.
    move => [g2 [-> HH]] /=.
    exact: proper_GlobDecl_size_of.
  - by destruct o; constructor.
Qed.

Theorem size_of_int : forall {c : genv} s w,
    @size_of c (Tnum w s) = Some (bytesN w).
Proof. reflexivity. Qed.
Theorem size_of_char : forall {c : genv} s,
    @size_of c (Tchar_ s) = Some (char_type.bytesN s).
Proof. reflexivity. Qed.
Theorem size_of_bool : forall {c : genv},
    @size_of c Tbool = Some 1%N.
Proof. reflexivity. Qed.
Theorem size_of_pointer : forall {c : genv} t,
    @size_of c (Tpointer t) = Some (pointer_size c).
Proof. reflexivity. Qed.
Theorem size_of_qualified : forall {c : genv} t q,
    @size_of c t = @size_of c (Tqualified q t).
Proof. reflexivity. Qed.
Theorem size_of_array_0 : forall {c : genv} t sz,
    @size_of c t = Some sz ->
    @size_of c (Tarray t 0) = Some 0%N.
Proof. intros; simpl. by rewrite H. Qed.

Theorem size_of_array_shatter : forall {c : genv} ty n sz,
    @size_of c (Tarray ty n) = Some sz <-> exists sz', (sz = n * sz')%N /\ @size_of c ty = Some sz' /\ @size_of c (Tarray ty n) = Some (n * sz')%N.
Proof.
  simpl. intros. destruct (size_of c ty) => /=; split; intros H.
  - inversion H; subst; eauto.
  - by destruct H as [? [? [H1 H2]]]; inversion H1; inversion H2; subst.
  - by inversion H.
  - by destruct H as [? [? [? ?]]]; discriminate.
Qed.

Theorem size_of_array_pos : forall {c : genv} t n sz,
    (0 < n)%N ->
    @size_of c t = Some sz <-> @size_of c (Tarray t n) = Some (n * sz)%N.
Proof.
  simpl. intros. destruct (size_of c t) => /=; split; try congruence.
  inversion 1. f_equal. apply N.mul_cancel_l in H2.  auto. lia.
Qed.

Theorem size_of_array : forall {c : genv} t n sz,
    @size_of c t = Some sz -> @size_of c (Tarray t n) = Some (n * sz)%N.
Proof.
  simpl. intros. destruct (size_of c t) => /=; try congruence.
Qed.

Lemma size_of_Qmut : forall {c} t,
    @size_of c t = @size_of c (Qmut t).
Proof. reflexivity. Qed.

Lemma size_of_Qconst : forall {c} t ,
    @size_of c t = @size_of c (Qconst t).
Proof. reflexivity. Qed.

(* XXX: since size_of simplifies eagerly, this might be hard to apply, so you
might need to inline the proof. *)
Lemma size_of_genv_compat tu σ gn st
      (Hσ : tu ⊧ σ)
      (Hl : tu !! gn = Some (Gstruct st)) :
  size_of σ (Tnamed gn) = GlobDecl_size_of (Gstruct st).
Proof. by rewrite /= (glob_def_genv_compat_struct st Hl). Qed.

Lemma size_of_erase_qualifiers σ ty :
  size_of σ (erase_qualifiers ty) = size_of σ ty.
Proof. induction ty => //=. by rewrite IHty. Qed.
Lemma size_of_drop_qualifiers σ ty :
  size_of σ (drop_qualifiers ty) = size_of σ ty.
Proof. by induction ty. Qed.

(** [SizeOf ty n] means that C++ type [ty] has size [n] bytes *)
Class SizeOf {σ : genv} (ty : type) (n : N) : Prop :=
  size_of_spec : size_of σ ty = Some n.
#[global] Hint Mode SizeOf - + - : typeclass_instances.

#[global] Instance SizeOf_mono :
  Proper (genv_leq ==> eq ==> eq ==> impl) (@SizeOf).
Proof.
  rewrite /SizeOf=>σ1 σ2 Hσ t1 t2 Ht n ? <- ?.
  by destruct (Proper_size_of _ _ Hσ _ _ Ht); simplify_eq.
Qed.

#[global] Instance array_size_of {σ : genv} ty a n b :
  SizeOf ty a ->
  TCEq (n * a)%N b ->
  SizeOf (Tarray ty n) b.
Proof.
  rewrite /SizeOf TCEq_eq=>Hty <-.
  cbn. by rewrite Hty.
Qed.

#[global] Instance named_struct_size_of tu σ gn st n :
  genv_compat tu σ ->
  TCEq (tu !! gn) (Some (Gstruct st)) ->
  TCEq st.(s_size) n ->
  SizeOf (Tnamed gn) n.
Proof.
  rewrite /SizeOf !TCEq_eq=>? /glob_def_genv_compat_struct Htu <-.
  cbn. by rewrite Htu.
Qed.

#[global] Instance named_union_size_of tu σ gn u n :
  genv_compat tu σ ->
  TCEq (tu !! gn) (Some (Gunion u)) ->
  TCEq u.(u_size) n ->
  SizeOf (Tnamed gn) n.
Proof.
  rewrite /SizeOf !TCEq_eq=>? /glob_def_genv_compat_union Htu <-.
  cbn. by rewrite Htu.
Qed.

#[global] Instance bool_size_of {σ : genv} : SizeOf Tbool 1.
Proof. done. Qed.

(* TODO?: consider using [SizeOf (Tnum sz sgn) (bytesN sz)]. *)
#[global] Instance int_size_of {σ : genv} sz sgn n :
  TCEq (bytesN sz) n -> SizeOf (Tnum sz sgn) n.
Proof. by rewrite /SizeOf TCEq_eq=><-. Qed.

(* TODO?: consider using [SizeOf (Tnum sz sgn) (char_type.bytesN ct)]. *)
#[global] Instance char_size_of {σ' : genv} ct n :
  TCEq (char_type.bytesN ct) n -> SizeOf (Tchar_ ct) n.
Proof. by rewrite /SizeOf TCEq_eq=><-. Qed.

#[global] Instance qualified_size_of {σ : genv} qual ty n :
  SizeOf ty n -> SizeOf (Tqualified qual ty) n.
Proof. done. Qed.

#[global] Instance ptr_size_of {σ : genv} ty n :
  TCEq (pointer_size σ) n -> SizeOf (Tptr ty) n.
Proof. by rewrite /SizeOf TCEq_eq=><-. Qed.

#[global] Instance arch_size_of {σ : genv} sz name n :
  TCEq (bytesN sz) n -> SizeOf (Tarch (Some sz) name) n.
Proof. by rewrite /SizeOf TCEq_eq=><-. Qed.

(** [HasSize ty] means that C++ type [ty] has a defined size *)
Class HasSize {σ : genv} (ty : type) : Prop :=
  has_size : is_Some (size_of σ ty).
#[global] Hint Mode HasSize - + : typeclass_instances.
#[global] Arguments has_size {_} _ {_} : assert.

#[global] Instance HasSize_mono :
  Proper (genv_leq ==> eq ==> impl) (@HasSize).
Proof.
  rewrite /HasSize=>σ1 σ2 Hσ t1 t2 Ht H.
  destruct (Proper_size_of _ _ Hσ _ _ Ht).
  - exfalso. exact: is_Some_None.
  - by simplify_eq.
Qed.

#[global] Instance size_of_has_size {σ : genv} ty n :
  SizeOf ty n -> HasSize ty.
Proof.
  intros. rewrite /HasSize size_of_spec. by eexists.
Qed.

(** [sizeof ty : N] is the size of C++ type [ty] (if it has a size) *)
Definition sizeof {σ : genv} (ty : type) `{!HasSize ty} : N :=
  is_Some_proj (has_size ty).

Lemma sizeof_spec {σ : genv} ty `{Hsz : !HasSize ty} :
  size_of σ ty = Some (sizeof ty).
Proof.
  rewrite/sizeof/has_size. by destruct Hsz as [sz ->].
Qed.

(** [offset_of] *)

Fixpoint find_assoc_list {T} (f : ident) (fs : list (ident * T)) : option T :=
  match fs with
  | nil => None
  | (f',v) :: fs =>
    if decide (f = f') then
      Some v
    else find_assoc_list f fs
  end%list.

Lemma find_assoc_list_elem_of {T} base xs :
  (∃ v, (base, v) ∈ xs) ->
  ∃ y, find_assoc_list (T := T) base xs = Some y.
Proof.
  move=>[v]. elim: xs => /= [/elem_of_nil //|[k w] xs IH]
    /elem_of_cons [|] Hin; simplify_eq.
  { rewrite decide_True; eauto. }
  case_decide; eauto.
Qed.

#[local] Close Scope nat_scope.
#[local] Open Scope Z_scope.
(* note: we expose the fact that reference fields are compiled to pointers,
   so the [offset_of] a reference field is the offset of the pointer.
 *)
Definition offset_of (resolve : genv) (t : globname) (f : ident) : option Z :=
  match glob_def resolve t with
  | Some (Gstruct s) =>
    find_assoc_list f (List.map (fun m => (m.(mem_name),m.(mem_layout).(li_offset) / 8)) s.(s_fields))
  | Some (Gunion u) =>
    find_assoc_list f (List.map (fun m => (m.(mem_name),m.(mem_layout).(li_offset) / 8)) u.(u_fields))
  | _ => None
  end.

Definition parent_offset_tu (tu : translation_unit) (derived : globname) (base : globname) : option Z :=
  match tu !! derived with
  | Some (Gstruct s) => find_assoc_list base (List.map (fun '(s,l) => (s,l.(li_offset) / 8)) s.(s_bases))
  | _ => None
  end.
(* We hide whether [genv_tu] exists. *)
mlock Definition parent_offset σ derived base := parent_offset_tu σ.(genv_tu) derived base.
Notation directly_derives_tu tu derived base := (is_Some (parent_offset_tu tu derived base)).
Notation directly_derives σ derived base := (is_Some (parent_offset σ derived base)).

Lemma find_assoc_list_parent_offset tu derived st base li :
  tu !! derived = Some (Gstruct st) ->
  (base, li) ∈ st.(s_bases) ->
  ∃ z, parent_offset_tu tu derived base = Some z.
Proof.
  rewrite /parent_offset_tu => -> Hin.
  apply /find_assoc_list_elem_of.
  eexists; apply /elem_of_list_fmap; by exists (base, li).
Qed.

Lemma parent_offset_genv_compat {σ tu derived base z} {Hσ : tu ⊧ σ} :
  parent_offset_tu tu derived base = Some z ->
  parent_offset σ derived base = Some z.
Proof.
  rewrite parent_offset.unlock /parent_offset_tu -/(glob_def σ derived).
  case E: (tu !! derived) => [ gd //= | // ]; destruct gd => //.
  by erewrite glob_def_genv_compat_struct.
Qed.

(** * alignof() *)
Parameter align_of : forall {resolve : genv} (t : type), option N.
Axiom align_of_named : ∀ {σ : genv} (nm : globname),
  align_of (Tnamed nm) =
  glob_def σ nm ≫= GlobDecl_align_of.

(** If [size_of] is defined, [align_of] must divide [size_of]. *)
Axiom align_of_size_of' : forall {σ : genv} (t : type) sz,
    size_of σ t = Some sz ->
    (exists al, align_of t = Some al /\ al <> 0 /\ (al | sz))%N.

Lemma align_of_size_of {σ : genv} (t : type) sz :
    size_of σ t = Some sz ->
    exists al, align_of t = Some al /\
          (* size is a multiple of alignment *)
          (sz mod al = 0)%N.
Proof.
  move=>/align_of_size_of' [al [? [? /N.mod_divide ?]]].
  eauto.
Qed.

Axiom align_of_array : forall {σ : genv} (ty : type) n,
    align_of (Tarray ty n) = align_of ty.
Axiom align_of_qualified : ∀ σ t q,
    align_of (resolve:=σ) (Tqualified q t) = align_of (resolve:=σ) t.

Axiom Proper_align_of : Proper (genv_leq ==> eq ==> Roption_leq eq) (@align_of).
#[global] Existing Instance Proper_align_of.

Lemma align_of_genv_compat tu σ gn st
      (Hσ : tu ⊧ σ)
      (Hl : tu !! gn = Some (Gstruct st)) :
  align_of (Tnamed gn) = GlobDecl_align_of (Gstruct st).
Proof. by rewrite /= align_of_named (glob_def_genv_compat_struct st Hl). Qed.


(* Borrowed from CompCert *)
(* Modified to fit your screen *)

Require Import Relations.
Require Import Wellfounded.
Require Import compcert.lib.Coqlib.
Require Import compcert.common.Events.
Require Import compcert.common.Globalenvs.
Require Import compcert.lib.Integers.
Global Unset Asymmetric Patterns.

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import oeuf.EricTact.
Require Import oeuf.StuartTact.

Require Import oeuf.AllValues.
Require Import oeuf.MatchValues.

Require oeuf.FullSemantics.

Set Default Timeout 15.
Set Implicit Arguments.

Definition nostep := FullSemantics.nostep.
Definition star := FullSemantics.star.
Definition plus := FullSemantics.plus.

Definition semantics := FullSemantics.semantics.
Definition Semantics_gen := FullSemantics.Semantics_gen.
Definition state := FullSemantics.state.
Definition genvtype := FullSemantics.genvtype.
Definition val_level  := FullSemantics.val_level .
Definition valtype  := FullSemantics.valtype .
Definition is_callstate  := FullSemantics.is_callstate .
Definition step  := FullSemantics.step .
Definition final_state := FullSemantics.final_state.
Definition globalenv := FullSemantics.globalenv.
Definition Semantics {state funtype vartype val_level}
        step is_callstate final_state globalenv :=
    @FullSemantics.Semantics state funtype vartype val_level
        step is_callstate final_state globalenv.

Notation " 'Step' L " := (step L (globalenv L)) (at level 1).
Notation " 'Star' L " := (star (step L) (globalenv L)) (at level 1).
Notation " 'Plus' L " := (plus (step L) (globalenv L)) (at level 1).

Definition forward_simulation L1 L2 :=
    forall M, FullSemantics.forward_simulation L1 L2 M.

Section FORWARD_SIMU_DIAGRAMS.

Variable L1: semantics.
Variable L2: semantics.

(*Hypothesis public_preserved:
  forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id. *)

Variable match_states: state L1 -> state L2 -> Prop.
Variable match_values: valtype L1 -> valtype L2 -> Prop.

Hypothesis match_callstate :
      forall fv1 av1 fv2 av2 s2,
        is_callstate L2 fv2 av2 s2 ->
        match_values fv1 fv2 ->
        match_values av1 av2 ->
        exists s1,
          match_states s1 s2 /\
          is_callstate L1 fv1 av1 s1.

Hypothesis match_final_states:
  forall s1 s2 v,
  match_states s1 s2 ->
  final_state L1 s1 v ->
  exists v',
    final_state L2 s2 v' /\ match_values v v'.

Hypothesis fsim_val_level_le :
    value_level_le (val_level L1) (val_level L2).

Hypothesis match_val_canon :
    forall v1 v2,
    match_values v1 v2 <->
    value_match (val_level L1) (val_level L2) v1 v2.

Lemma trace_value_level_le : value_level_le_indexed (val_level L1) (val_level L2).
eapply value_level_le_add_index; eauto.
Qed.

Lemma trace_match_val_canon : forall M v1 v2,
    match_values v1 v2 <->
    value_match_indexed M (val_level L1) (val_level L2) v1 v2.
intros. rewrite <- value_match_add_index_iff; eauto.
Qed.

Section SIMULATION_STAR_WF.

(** [order] is a well-founded ordering associated with states
  of the first semantics.  Stuttering steps must correspond
  to states that decrease w.r.t. [order]. *)

Variable order: state L1 -> state L1 -> Prop.
Hypothesis order_wf: well_founded order.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2',
  (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order s1' s1))
  /\ match_states s1' s2'.

Lemma forward_simulation_star_wf: forward_simulation L1 L2.
Proof.
  intro M. eapply FullSemantics.forward_simulation_star_wf with
    (order := order)
    (match_values := match_values)
    (match_states := match_states);
  eauto using trace_value_level_le, trace_match_val_canon.
Qed.

End SIMULATION_STAR_WF.

Section SIMULATION_STAR.

(** We now consider the case where we have a nonnegative integer measure
  associated with states of the first semantics.  It must decrease when we take
  a stuttering step. *)

Variable measure: state L1 -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Plus L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_star: forward_simulation L1 L2.
Proof.
  intro M. eapply FullSemantics.forward_simulation_star with
    (measure := measure)
    (match_values := match_values)
    (match_states := match_states);
  eauto using trace_value_level_le, trace_match_val_canon.
Qed.

End SIMULATION_STAR.

(** Simulation when one transition in the first program corresponds
    to one or several transitions in the second program. *)

Section SIMULATION_PLUS.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Plus L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_plus: forward_simulation L1 L2.
Proof.
  intro M. eapply FullSemantics.forward_simulation_plus with
    (match_values := match_values)
    (match_states := match_states);
  eauto using trace_value_level_le, trace_match_val_canon.
Qed.

End SIMULATION_PLUS.

(** Lock-step simulation: each transition in the first semantics
    corresponds to exactly one transition in the second semantics. *)

Section SIMULATION_STEP.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  exists s2', Step L2 s2 t s2' /\ match_states s1' s2'.

Lemma forward_simulation_step: forward_simulation L1 L2.
Proof.
  intro M. eapply FullSemantics.forward_simulation_step with
    (match_values := match_values)
    (match_states := match_states);
  eauto using trace_value_level_le, trace_match_val_canon.
Qed.

End SIMULATION_STEP.

(** Simulation when one transition in the first program
    corresponds to zero or one transitions in the second program.
    However, there is no stuttering: infinitely many transitions
    in the source program must correspond to infinitely many
    transitions in the second program. *)

Section SIMULATION_OPT.

Variable measure: state L1 -> nat.

Hypothesis simulation:
  forall s1 t s1', Step L1 s1 t s1' ->
  forall s2, match_states s1 s2 ->
  (exists s2', Step L2 s2 t s2' /\ match_states s1' s2')
  \/ (measure s1' < measure s1 /\ t = E0 /\ match_states s1' s2)%nat.

Lemma forward_simulation_opt: forward_simulation L1 L2.
Proof.
  intro M. eapply FullSemantics.forward_simulation_opt with
    (match_values := match_values)
    (match_states := match_states);
  eauto using trace_value_level_le, trace_match_val_canon.
Qed.

End SIMULATION_OPT.

End FORWARD_SIMU_DIAGRAMS.

Definition receptive L := FullSemantics.receptive L.
Definition determinate L := FullSemantics.determinate L.


From mathcomp Require Import
     all_ssreflect.

From AUChain
     Require Import
     BlockTree
     Blocks
     Messages
     Parameters
     LocalState
     StateMonad.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(** * Protocol
      Execution plan for each party pr. round:
      This consists of two parts:

      1) Recieve and process messages:
         - Recieve messages for this party and extend the blocktree with the
           received blocks.

      2) Execute consensus algorithm:
         - Check if leader.
         - If leader then bake block and add return messages that has to be submitted.
 **)

Section Protocol.

  Definition extend_tree_l (l: LocalState) (b : Block) : LocalState  :=
    mkLocalState (pk l) (extendTree (tree l) b).

  Definition process_msg (m: Message) (l: LocalState) : LocalState :=
    let: BlockMsg b := m in extend_tree_l l b.

  Definition process_msgs (msgs: Messages) : State LocalState unit :=
    modify (fun l => foldr process_msg l msgs).

  (* Notice that if a party actually bakes a block it will be added
     directly to the blocktree of this party. *)
  Definition honest_bake (sl : Slot) (txs : Transactions) : State LocalState Messages :=
    local_state <- get;
    if Winner (pk local_state) sl
    then let: bestChain := bestChain (sl-1) (tree local_state) in
         let: hashPrev := HashB (head GenesisBlock bestChain) in
         let: newBlock := MkBlock sl txs hashPrev (pk local_state) in
         modify (fun l => extend_tree_l l newBlock);;
         pure [:: BlockMsg newBlock]
    else pure [::].

  Definition honest_rcv (msgs : Messages) (sl : Slot) : State LocalState unit :=
    process_msgs msgs.

End Protocol.


Require Import Mtac2.Mtac2.

Goal True.
MProof.
  M.bind (M.ret I) (fun r => M.ret r).
Qed.

Goal True.
MProof.
  (r <- M.ret I; M.ret r)%MC.
Qed.


(** FreeSpec is a general-purpose framework for implementing (with a Free monad)
    and certifying (with contracts) impure computations. In this tutorial, we
    will use FreeSpec to implement and certify a webserver we call
    <<MiniHTTPServer>>. Our goal is to prove our HTTP server correctly uses the
    filesystem, that is it reads from and closes valid file descriptors, and
    closes all its file descriptors.

    The [FreeSpec.Core] module reexports the key component provided by
    FreeSpec. *)

Generalizable All Variables.

From Coq Require Import String.
From FreeSpec Require Import Core.

(** * I. Implementation *)

(** FreeSpec provides the [impure] monad to implement impure computations. This
    monad is equipped with the necessary notations to write idiomatic momadic
    code, thanks to the same notations as the ones introduced in recent versions
    of OCaml.

    The [impure] type takes two parameters respectively of type [interface] and
    [Type]:

      - An interface is a parameterized inductive type, whose constructors
        identify impure primitives. For an interface [i], a term of type [i a]
        identifies a primitive which produces a term of type [a]. An impure
        computation of type [impure i a] can leverage primitives of the
        interface [i].
      - The second parameter of [impure] is the type of result returned by the
        impure computation. Therefore, an impure computation of type [impure i a]
        is expected to produce a result of type [a]. *)

(** ** I.1 Defining Interfaces *)

(** An [interface] is a parameterized inductive type whose constructors identify
    impure primitives.

    For our server, we anticipate the use of three “kinds” of primitives to:

      - Create and manipulate TCP sockets
      - Interact with the filesystem
      - Interact with the console

    Since an impure computation can use _several_ interfaces, FreeSpec favors
    defining independent primitives as part of different interfaces. In our
    case, this means we will have three different interfaces.

    In practice, FreeSpec users do not defined their interface
    manually, but rather generate them.  To that end, we use
    <<coqffi>>. *)

(** *** The TCP Interface *)

From MiniHTTPServerFFI Require Import TCP.

(** *** The FILESYSTEM Interface *)

From MiniHTTPServerFFI Require Import FileSystem.

(** *** The CONSOLE Interface *)

From MiniHTTPServerFFI Require Import Console.

(** ** I.2. Implementing a HTTP Server *)

(** With the three interfaces we have defined in the previous section, we can
    now implement <<MiniHTTPServer>>, that is a minimal HTTP server. Our
    objective is to write a code as idiomatic as possible.

    To that end, we rely on the <<coq-ext-lib>> package, and therefore
    import it. *)

Import List.ListNotations.
From ExtLib Require Import Monad Functor.
Import MonadLetNotation FunctorNotation.
From CoqFFI Require Import String.

(** *** A Word on Non-Termination *)

(** As Coq users know, Gallina only allows to implement strictly recursive
    functions, which means a function in Coq will always terminate. A webserver,
    on the other hand, is expected to run as long as incoming connections
    arrive.  FreeSpec will eventually deal with non-termination, but this has
    not been our priority just yet. In the context of this tutorial, we
    compromise and <<MiniHTTPServer>> will therefore only accept a finite number
    of connections. However, we show that it is correct for any number of finite
    steps.

    To implement this behavior, we introduce [repeatM], which repeats an impure
    computation [n] times. *)

Fixpoint repeatM {m : Type -> Type} `{Monad m} {a} (n : nat) (p : m a) : m unit :=
  match n with
  | O => ret tt
  | S n => p;; repeatM n p
  end.

(** *** A Generic TCP Server *)

(** We first define a generic TCP Server as an impure computation parameterized
    by a so-called handler, that is an impure computation which computes a
    response message for each request message received from a client. *)

From FreeSpec.FFI Require Import FFI.

Definition tcp_server `{Monad m, MonadTCP m}
    (n : nat) (handler : string -> m string)
  : m unit :=
  let* server := new_tcp_socket "127.0.0.1:8088" in
  listen_incoming_connection server;;

  repeatM n (let* client := accept_connection server in

             let* req := read_socket client in
             let* res := handler req in
             write_socket client res;;

             close_tcp_socket client);;

  close_tcp_socket server.

(** *** A HTTP Handler *)

(** <<MiniHTTPServer>> is a minimal server which serves static files over HTTP.
    The main task of its handler will perform is therefore to fetch the content
    of a file identified by a given path. To implement this behavior, we define
    an impure computation [read_content], which performs some logging in
    addition to interacting with the file system.

    As such, [read_content] uses two interfaces. We can specify that thanks to
    [Provide], for instance with [`{Provide ix CONSOLE, Provide ix FILESYSTEM}].
    FreeSpec provides [Provide2], [Provide3], [Provide4], and [Provide5] to make
    the type more readable. *)

Definition read_content `{Monad m, MonadFileSystem m, MonadConsole m}
    (path : string)
  : m string :=
  echo ("  reading <" ++ path ++ ">... ");;
  let* fd := open_file path in
  let* c := read_file fd in
  close_file fd;;
  echo "done.\n";;
  ret c.

(** Using this utility function, we can define the handler itself.

    The parsing of the incoming HTTP requests, and the serialization of HTTP
    response have been implemented in Coq, but are not relevant in this
    tutorial. They are provided inside the <<coq-MiniHTTPServer>> and we reuse
    them. *)

From MiniHTTPServer Require Import URI HTTP.

(** This provides the following types and functions:

      - [http_req] encodes the supported HTTP requests (currently, only GET
        requests are supported).
      - [http_request] a parsing function of the form [bytes -> error_stack +
        http_req]
      - [http_res] encodes the HTTP responses used by MiniHTTPServer (in our
        case, 200, 401, and 404)
      - [response_to_string] to serialize a response as a valid HTTP string. *)

Definition request_handler `{Monad m, MonadFileSystem m, MonadConsole m}
    (base : list directory_id) (req : request)
  : m response :=
  match req with
  | Get uri =>
    let path := uri_to_path (sandbox base uri) in
    let* isf := file_exists path in
    if (isf : bool)
    then let* content := read_content path in
         ret (make_response success_OK content)
    else echo ("  resource <" ++ path ++"> not found\n");;
         ret (make_response client_error_NotFound "Resource not found.")
  end.

From ExtLib Require Import StateMonad.

Definition http_handler `{Monad m, MonadFileSystem m, MonadConsole m}
    (base : list directory_id) (req : string)
  : m string :=
  echo "new request received\n";;
  echo ("  request size is " ++ StrExt.of_int (StrExt.length req) ++ "\n");;

  let* res := match runStateT http_request (Slice.of_string req) with
              | inr req => request_handler base (fst req)
              | _ => ret (make_response client_error_BadRequest "Bad request")
              end in

  ret (response_to_string res).

(** Since [read_content] uses the [CONSOLE] interface in addition to
    [FILESYSTEM], our [http_handler] type exposes this explicitely. However,
    [http_handler] does not use the [TCP] interface itself, and therefore the
    [TCP] interface does not appear inside its type even if in practice it will
    be used in a context where [TCP] is available.

    [http_server] is the final function, the [tcp_server] is specialized with
    our [http_handler]. As a consequence, the type of [http_server] exposes the
    three interfaces we use. *)

Definition http_server `{Monad m, MonadFileSystem m, MonadTCP m, MonadConsole m} (n : nat)
  : m unit :=
  echo "hello, MiniHTTPServer!\n";;
  tcp_server n (http_handler [Dirname (Slice.of_string "tmp")]).

(** * II. Certifying *)

(** As a reminder, our goal is to prove our HTTP server correctly use the
    filesystem, that is it reads from and closes valid file descriptors, and
    closes all its file descriptors. To that end, we need to define a contract
    for the [FILESYSTEM] interface, then reason about [http_server] executions
    w.r.t. this contract. *)

(** ** II.1. Defining a Contract *)

From FreeSpec.Core Require Import CoreFacts.

(** Defining a contract for an interface in FreeSpec means specifying how an
    interface shall be used, but also what to expect from the results of its
    primitives. *)

(** *** The Witness State Type and Helpers *)

(** A contract in FreeSpec has a so-called witness state attached to it. It
    allows to take into account the stateful nature of impure computations and
    primitives implementers. More precisely, a primitive of an interface which
    could be used at a given time may become forbidden in the future.

    This is precisely the case with our use case: a valid file descriptor
    becomes invalid once it has been used as an arguent of the [Close]
    primitive. Witness states shall be as simple as possible, and only holds the
    minimum amount of information about past executed primitives. In our case,
    the witness state can be as simple as a set of open file descriptors. *)

Definition fd_set : Type := file -> bool.

(** In addition, we provide the usuals helpers to manipulate (addition,
    deletion) and reason about sets. *)

Axiom fd_eq_dec : forall (fd1 fd2 : file), { fd1 = fd2 } + { ~ (fd1 = fd2) }.

Definition add_fd (ω : fd_set) (fd : file) : fd_set :=
  fun (fd' : file) => if fd_eq_dec fd fd' then true else ω fd'.

Definition del_fd (ω : fd_set) (fd : file) : fd_set :=
  fun (fd' : file) => if fd_eq_dec fd fd' then false else ω fd'.

Definition member (ω : fd_set) (fd : file) : Prop :=
  ω fd = true.

Definition absent (ω : fd_set) (fd : file) : Prop :=
  ω fd = false.

Lemma member_not_absent (ω : fd_set) (fd : file)
  : member ω fd -> ~ absent ω fd.

Proof.
  unfold member, absent.
  intros m a.
  now rewrite m in a.
Qed.

#[global] Hint Resolve member_not_absent : minihttp.

Lemma absent_not_member (ω : fd_set) (fd : file)
  : absent ω fd -> ~ member ω fd.

Proof.
  unfold member, absent.
  intros a m.
  now rewrite m in a.
Qed.

#[global] Hint Resolve absent_not_member : minihttp.

Lemma member_add_fd (ω : fd_set) (fd : file) : member (add_fd ω fd) fd.

Proof.
  unfold member, add_fd.
  destruct fd_eq_dec; auto.
Qed.

#[global] Hint Resolve member_add_fd : minihttp.

(** *** The Update Function *)

(** In FreeSpec, a contract provides a so-called “update function” to be used to
    reason about an interface usage over time. At any computation step requiring
    the use of a primitive, the “current” witness state is used to determine
    both the caller and the callee obligations. Then, the update function is
    used to update the witness state to take into account what happened for
    future primitives execution.

    In our case, since the witness state is just a set of open file descriptors
    and does not hold any information about e.g. file actual content, the update
    function remains simple: we add newly open file descriptor after [Open], and
    remove them after [Close]. *)

Definition fd_set_update (ω : fd_set) (a : Type) (e : FILESYSTEM a) (x : a) : fd_set :=
  match e, x with
  | Open_file _, fd =>
    add_fd ω fd
  | Close_file fd, _ =>
    del_fd ω fd
  | Read_file _, _ =>
    ω
  | File_exists _, _ =>
    ω
  end.

(** *** The Caller Obligations *)

(** Our experience with FreeSpec has tended to show that using inductive types
    for obligations is the more convenient approach in practice, but this comes
    with a tradeoff in terms of readability. *)

Inductive fd_set_caller_obligation (ω : fd_set)
  : forall (a : Type), FILESYSTEM a -> Prop :=

(** We do not restrict the use of [Open] or [FileExists] *)

| fd_set_open_caller (p : string)
  : fd_set_caller_obligation ω file (Open_file p)
| fd_set_is_file_caller (p : string)
  : fd_set_caller_obligation ω bool (File_exists p)

(** In order for [Read] and [Close] to be used correctly, their
    [file] argument has to be a member of the witness state. *)

| fd_set_read_caller (fd : file)
    (is_member : member ω fd)
  : fd_set_caller_obligation ω string (Read_file fd)
| fd_set_close_caller (fd : file)
    (is_member : member ω fd)
  : fd_set_caller_obligation ω unit (Close_file fd).

#[global] Hint Constructors fd_set_caller_obligation : minihttp.

(** *** The Callee Obligations *)

(** The callee obligations of our contract are not as straightforward as the
    caller obligations. It appears that we could potentially require nothing
    special from a [FILESYSTEM] implementer for our particular use case. There
    is, however, one scenario that we want to avoid in practice:

      - The caller opens two different files
      - The callee returns the same file descriptor for both files
      - the caller closes one file descriptor, and uses the second one

    In such a scenario, the caller misuses the interface in good faith. To avoid
    this, we require the [Open] primitives to return _fresh_ file
    descriptors. *)

Inductive fd_set_callee_obligation (ω : fd_set)
  : forall (a : Type), FILESYSTEM a -> a -> Prop :=

(** The [file] returned by the [Open] primitive shall not be a member
    of the witness state. *)

| fd_set_open_callee (p : string) (fd : file)
    (is_absent : absent ω fd)
  : fd_set_callee_obligation ω file (Open_file p) fd

(** We do not specify any particular requirements for the results of the other
    primitives. Therefore, we cannot use this contract to reason about the
    result of reading twice the same file, for instance. This would require
    another contract, which is totally fine with FreeSpec since we can compose
    them together. *)

| fd_set_read_callee (fd : file) (s : string)
  : fd_set_callee_obligation ω string (Read_file fd) s
| fd_set_close_callee (fd : file) (t : unit)
  : fd_set_callee_obligation ω unit (Close_file fd) t
| fd_set_is_file_callee (p : string) (b : bool)
  : fd_set_callee_obligation ω bool (File_exists p) b.

#[global] Hint Constructors fd_set_callee_obligation : minihttp.

(** *** The Contract Definition *)

(** We put everything together by defining a term of type [contract FILESYSTEM
    fd set]. *)

Definition fd_set_contract : contract FILESYSTEM fd_set :=
  {| witness_update := fd_set_update
   ; caller_obligation := fd_set_caller_obligation
   ; callee_obligation := fd_set_callee_obligation
  |}.

(** ** II.2. Problem Definition *)

(** From the caller perspective, there is two concerns that we want to express.
    First, we _always_ use correct file descriptors. Secondly, we _eventually_
    close any file descriptor previously opened.

    The first objective is a _safety_ property that we can express
    using the [respectful_impure] predicate. The exact lemma is: *)

Lemma fd_set_respectful_http_server `{StrictProvide3 ix FILESYSTEM TCP CONSOLE}
    (ω : fd_set) (n : nat)
  : pre (to_hoare fd_set_contract (http_server n)) ω.
Abort.

(** The [StrictProvide3] typeclass is very analogous to the [Provide3] one, but
    it requires more contrains about its arguments. The exact details about
    the difference is out of the scope of this tutorial, especially since the
    two typeclasses with eventually be merged together.

    The second objective is a _liveness_ property that we can express agains the
    final witness state. This can be acheived using the [respectful_run]
    predicate provided by FreeSpec. *)

Lemma fd_set_preserving_http_server `{StrictProvide3 ix FILESYSTEM TCP CONSOLE}
      (n : nat)
  : forall (ω ω' : fd_set) (x : unit),
    post (to_hoare fd_set_contract (http_server n)) ω x ω'
    -> forall fd, ω fd = ω' fd.
Abort.

(** This property can be read as: any [file] which is opened during
    the execution of [http_server] is closed before the execution ends. This
    is a property that we generalize for any impure computations:  *)

Definition fd_set_preserving {a} `{MayProvide ix FILESYSTEM} (p : impure ix a) :=
  forall (ω ω' : fd_set) (x : a),
    post (to_hoare fd_set_contract p) ω x ω' -> forall fd, ω fd = ω' fd.

(** And, as a consequence, the second lemma we want to prove becomes: *)

Lemma fd_set_preserving_http_server `{StrictProvide3 ix FILESYSTEM TCP CONSOLE}
    (n : nat)
  : fd_set_preserving (http_server n).
Abort.

(** ** II.3. <<MiniHTTPServer>> Proofs of Correctness *)

(** We now have defined everything we need to prove the correctness of
    <<MiniHTTPServer>>. The rest of this tutorial consists in actually write the
    proofs. Our approach is bottom-up: we start from the leaves of our
    computations, show they have some important properties, then reuse our
    result to eventually conclude about the correctness of the whole program. *)

(** *** Certifying [read_content] *)

(** From the perspective of this tutorial, the [read_content] impure computation
    is an interesting starting point: it uses two primitives that can be misused
    according to the [fd_set_contract] ([Read], and [Close]), and it also uses
    an interface which is not relevant from the perspective of [fd_set_contract]
    ([CONSOLE]). *)

Lemma fd_set_respectful_read_content `{StrictProvide2 ix FILESYSTEM CONSOLE}
    (ω : fd_set) (path : string)
  : pre (to_hoare fd_set_contract (read_content path)) ω.

(** FreeSpec provides the [prove impure] tactics to automate as much as possible
    the construction of a proof for [respectful_impure] goals. It performs many
    uninteresting tasks that FreeSpec users would have to do manually if they
    decided not to use it. For the sake of demonstration, we attempt to do just that,
    and use [repeat constructor].

    This generates 5 hardly readable subgoals, for instance the 5th subgoal is:

<<
  ω : fd_set
  path : bytes
  x : unit
  H4 : gen_callee_obligation fd_set_contract ω
         (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x
  x0 : file
  H5 : gen_callee_obligation fd_set_contract
         (gen_witness_update fd_set_contract ω
            (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x)
         (inj_p (Open path)) x0
  x1 : bytes
  H6 : gen_callee_obligation fd_set_contract
         (gen_witness_update fd_set_contract
            (gen_witness_update fd_set_contract ω
               (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x)
            (inj_p (Open path)) x0) (inj_p (Read x0)) x1
  x2 : unit
  H7 : gen_callee_obligation fd_set_contract
         (gen_witness_update fd_set_contract
            (gen_witness_update fd_set_contract
               (gen_witness_update fd_set_contract ω
                  (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x)
               (inj_p (Open path)) x0) (inj_p (Read x0)) x1)
         (inj_p (Close x0)) x2
  ============================
 gen_caller_obligation fd_set_contract
   (gen_witness_update fd_set_contract
      (gen_witness_update fd_set_contract
         (gen_witness_update fd_set_contract
            (gen_witness_update fd_set_contract ω
               (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x)
            (inj_p (Open path)) x0) (inj_p (Read x0)) x1)
      (inj_p (Close x0)) x2) (inj_p (Echo "done.
"))
>>

    [prove_impure] provides a much cleaner output:

<<
subgoal 1 is:
  fd_set_caller_obligation ω file (Open path)

subgoal 2 is:
 fd_set_caller_obligation (add_fd ω x0) bytes (Read x0)

subgoal 3 is:
 fd_set_caller_obligation (add_fd ω x0) unit (Close x0)
>>

    In this case, we can use the [minihttp] database that we have enriched with various [Hint]
    to conclude automatically about this. *)

Proof.
  prove impure with minihttp.
Qed.

#[global] Hint Resolve fd_set_respectful_read_content : minihttp.

(** The second property we want to prove about [read_content] is that
    it does not forget to close any [file]. *)

Lemma fd_set_preserving_read_content `{StrictProvide2 ix FILESYSTEM CONSOLE}
    (path : string)
  : fd_set_preserving (read_content path).

(** Similarly to [prove_impure], FreeSpec provides a tactic to exploit
    hypotheses about [respectful_run]. More precisely, it explore the different
    execution path that could lead to the production of the run in hypothesis,
    and clean-up as much as possible the resulting alternative goals.. We can
    explicit the tasks performed by [respectful_run] with the following
    command.

<<
  repeat match goal with
         | H : respectful_run _ _ _ _ _ |- _ => inversion H; clear H; ssubst
         end.
>>

    This produces the following goal:

<<
  path : bytes
  ω : fd_set
  x : bytes
  x0 : unit
  o_callee : gen_callee_obligation fd_set_contract ω
               (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0
  o_caller : gen_caller_obligation fd_set_contract ω
               (inj_p (Echo ("  reading <" ++ path ++ ">... ")))
  x1 : file
  o_callee0 : gen_callee_obligation fd_set_contract
                (gen_witness_update fd_set_contract ω
                   (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0)
                (inj_p (Open path)) x1
  o_caller0 : gen_caller_obligation fd_set_contract
                (gen_witness_update fd_set_contract ω
                   (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0)
                (inj_p (Open path))

                               [...]

  o_caller3 : gen_caller_obligation fd_set_contract
                (gen_witness_update fd_set_contract
                   (gen_witness_update fd_set_contract
                      (gen_witness_update fd_set_contract
                         (gen_witness_update fd_set_contract ω
                            (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0)
                         (inj_p (Open path)) x1) (inj_p (Read x1)) x)
                   (inj_p (Close x1)) x3) (inj_p (Echo "done.
"))
  o_callee3 : gen_callee_obligation fd_set_contract
                (gen_witness_update fd_set_contract
                   (gen_witness_update fd_set_contract
                      (gen_witness_update fd_set_contract
                         (gen_witness_update fd_set_contract ω
                            (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0)
                         (inj_p (Open path)) x1) (inj_p (Read x1)) x)
                   (inj_p (Close x1)) x3) (inj_p (Echo "done.
")) x4
  ============================
  forall fd : file,
  ω fd =
  gen_witness_update fd_set_contract
    (gen_witness_update fd_set_contract
       (gen_witness_update fd_set_contract
          (gen_witness_update fd_set_contract
             (gen_witness_update fd_set_contract ω
                (inj_p (Echo ("  reading <" ++ path ++ ">... "))) x0)
             (inj_p (Open path)) x1) (inj_p (Read x1)) x)
       (inj_p (Close x1)) x3) (inj_p (Echo "done.
")) x4 fd
>>

    On the contrary, [unroll_respectful_run] keeps the goal manageable, and once called, the FreeSpec
    internals are gone and we can write a “classical” Coq proof. *)

Proof.
  intros ω x ω' run.
  unroll_post run.
  intros fd'.
  unfold add_fd, del_fd.
  destruct fd_eq_dec; subst.
  + now inversion H4; ssubst.
  + reflexivity.
Qed.

(** The implementation details of [read_content] will not be relevant with our
    two freshly proven lemmas. Therefore, we make the impure computation to
    prevent [improve_impure] and [unroll_respectful_run] to unfold them. *)

#[local] Opaque read_content.

(** *** Certifying [file_exists] *)

(** We use the exact same approach for [file_exists]. Since this computation
    does not use any problematic primitives, the proofs are straightforward. *)

Lemma fd_set_respectful_file_exists `{Provide ix FILESYSTEM} (ω : fd_set) (path : string)
  : pre (to_hoare fd_set_contract (file_exists path)) ω.

Proof.
  prove impure with minihttp.
Qed.

#[global] Hint Resolve fd_set_respectful_file_exists : minihttp.

Lemma fd_set_preserving_file_exists `{Provide ix FILESYSTEM} (path : string)
  : fd_set_preserving (file_exists path).

Proof.
  intros ω x ω' run.
  now unroll_post run.
Qed.

(** Again, we make [file_exists] opaque because its concrete implementation is
    not relevant anymore. *)

#[local] Opaque file_exists.

(** *** Certifying [http_handler] *)

(** The [http_handler] is interesting, because to a large extent, it does not
    use primitives itself: it relies on other impure computations [read_content]
    and [file_exists] to do so. Interested readers can try to remove the
    vernacular commands which make these two computations opaque and see the
    outputs of [prove_impure] and [unroll_respectful_run]: in a nutshell, they
    would find themselves having to prove one more time the exact same goals, in
    more crowded contexts. *)

#[local] Opaque http_request.

Lemma fd_set_respectful_http_handler `{StrictProvide2 ix FILESYSTEM CONSOLE}
    (base : list directory_id) (req : string) (ω : fd_set)
  : pre (to_hoare  fd_set_contract (http_handler base req)) ω.

Proof.
  prove impure.
  destruct (runStateT http_request (Slice.of_string req)).
  + prove impure.
  + destruct (fst p).
    prove impure.

(** Here, [prove_impure] did not unfold [file_exists] and [read_content], but
    has leveraged FreeSpec formalism to generate two clean subgoals.
<<
subgoal 1 is:
  respectful_impure fd_set_contract ω
    (file_exists (uri_to_path (sandbox base resource)))

subgoal 2 is:
 respectful_impure fd_set_contract w
   (read_content (uri_to_path (sandbox base resource)))
>>

    Both are straightforward to prove using the [minihttp] hint database. *)

    all: eauto with minihttp.
Qed.

#[global] Hint Resolve fd_set_respectful_http_handler : minihttp.

Lemma fd_set_preserving_http_handler `{StrictProvide2 ix FILESYSTEM CONSOLE}
    (base : list directory_id) (req : string)
  : fd_set_preserving (http_handler base req).

Proof.
  intros ω x ω' run fd.
  unroll_post run.
  destruct (runStateT http_request (Slice.of_string req)).
  + now unroll_post run.
  + destruct p as [[res_id] req'].
    unroll_post run.

(** [unroll_respectful_run] uses a similar approach when in presence of opaque
    terms. *)

    ++ apply fd_set_preserving_file_exists in run0.
       apply fd_set_preserving_read_content in run.
       now transitivity (ω0 fd).
    ++ now apply fd_set_preserving_file_exists in run0.
Qed.

#[global] Hint Resolve fd_set_preserving_http_handler : minihttp.

#[local] Opaque http_handler.
#[local] Opaque response_to_string.

(** *** Certifying [repeatM] *)

From Coq Require Import FunctionalExtensionality.

Lemma fd_set_preserving_repeatM {a} `{Provide ix FILESYSTEM}
    (p : impure ix a)
    (fd_preserving : fd_set_preserving p)
    (n : nat)
  : fd_set_preserving (repeatM n p).

Proof.
  intros ω ω' fd run.
  induction n.
  + now unroll_post run.
  + unroll_post run.
    apply IHn.
    replace ω with ω0; auto.
    symmetry.
    apply functional_extensionality.
    eauto.
Qed.

#[global] Hint Resolve fd_set_preserving_repeatM : minihttp.

Lemma repeatM_preserving_respectful {a} `{Provide ix FILESYSTEM}
    (p : impure ix a) (ω : fd_set)
    (fd_trust : pre (to_hoare fd_set_contract p) ω)
    (fd_preserving : fd_set_preserving p)
    (n : nat)
  : pre (to_hoare fd_set_contract (repeatM n p)) ω.

Proof.
  revert ω fd_trust.
  induction n; intros ω fd_trust.
  + prove impure.
  + prove impure with minihttp.
    apply IHn.
    replace ω0 with ω; auto.
    apply functional_extensionality.
    intros fd.
    eapply fd_preserving.
    exact hpost.
Qed.

#[local] Opaque repeatM.

Lemma fd_set_preserving_tcp_server_repeat_routine
   `{Provide ix TCP, MayProvide ix FILESYSTEM, Distinguish ix TCP FILESYSTEM}
    (server : socket)
    (handler : string -> impure ix string)
    (preserve : forall (req : string), fd_set_preserving (handler req))
  : fd_set_preserving (let* client := accept_connection server in

                       let* req := read_socket client in
                       let* res := handler req in
                       write_socket client res;;

                       close_tcp_socket client).

Proof.
  intros ω b ω' run fd.
  unroll_post run.
  now apply preserve in run.
Qed.

#[global] Hint Resolve fd_set_preserving_tcp_server_repeat_routine : minihttp.

(** *** Certifying [http_server] *)

Lemma fd_set_respectful_http_server `{StrictProvide3 ix FILESYSTEM TCP CONSOLE}
    (ω : fd_set) (n : nat)
  : pre (to_hoare fd_set_contract (http_server n)) ω.

Proof.
  prove impure.
  apply repeatM_preserving_respectful.
  + prove impure.
    apply fd_set_respectful_http_handler.
  + intros ω' ω'' [] run fd.
    apply fd_set_preserving_tcp_server_repeat_routine in run; auto with minihttp.
    apply fd_set_preserving_http_handler.
Qed.

Lemma fd_set_preserving_http_server `{StrictProvide3 ix FILESYSTEM TCP CONSOLE}
    (n : nat)
  : fd_set_preserving (http_server n).

Proof.
  intros ω x ω' run fd.
  unroll_post run.
  apply fd_set_preserving_repeatM in run0; auto with minihttp.
  apply fd_set_preserving_tcp_server_repeat_routine.
  apply fd_set_preserving_http_handler.
Qed.