Require Import List.

Parameter string : Type.

Parameter empty_string : string.

Parameter concat : string -> string -> string.

(*3 axioms about concatenation that should hold for any reasonable implementation *)
Axiom concat_assoc : forall a b c, concat a (concat b c) = concat (concat a b) c.
Axiom concat_empty : forall s : string, concat s empty_string = s.
Axiom concat_empty_l : forall s : string, concat empty_string s = s.

Parameter state : Type.

Parameter HMAC : string -> string -> string.

Parameter HMAC_init : string -> state.

Parameter HMAC_update : string -> state -> state.

Parameter HMAC_digest : state -> string.

(* We have proved this as stated here in SAW *)
Axiom update_concat : forall m1 m2 s,
    HMAC_update (concat m1 m2) s = HMAC_update m2 (HMAC_update m1 s).

(* We have proved this for a set of m and k sizes in SAW *)
Axiom equiv_one : forall m k,
    HMAC_digest (HMAC_update m (HMAC_init k)) = HMAC k m.

(* Not yet proved in SAW, can be proved as stated *)
Axiom update_empty : forall s, HMAC_update empty_string s = s.

Lemma fold_right_concat : forall s l,
    fold_right concat (s) l = concat (fold_right concat empty_string l) s.
Proof.
  induction l.
  simpl in *. rewrite concat_empty_l. auto.
  simpl in *. rewrite IHl. rewrite concat_assoc. auto.
Qed.

Lemma update_concat_any:
  forall (l : list string) (key s : string),
    HMAC_update (concat (fold_right concat empty_string (rev l)) s) (HMAC_init key) =
    HMAC_update s (fold_right HMAC_update (HMAC_init key) l).
Proof.
  induction l; intros.
    + simpl in *. rewrite concat_empty_l. auto.
    + simpl in *. rewrite <- update_concat. rewrite fold_right_app.
      simpl. rewrite fold_right_concat. simpl. rewrite concat_empty. rewrite <- IHl. f_equal.
      rewrite concat_assoc. auto.
Qed.

Theorem HMAC_incremental_equiv :
  forall (ms : list string) key,
    HMAC key (fold_right concat empty_string ms) =
    HMAC_digest (fold_left (fun (st: state) msg => HMAC_update msg st) ms (HMAC_init key)).
Proof.
  intros.
  rewrite <- fold_left_rev_right in *.
  remember (rev ms).
  destruct l; simpl.
  - rewrite <- equiv_one. destruct ms.
    + simpl. rewrite update_empty. auto.
    +  assert (rev nil = rev (rev (s :: ms))). f_equal. auto.
       clear Heql. rewrite rev_involutive in *. simpl in *. congruence.
  - rewrite <- equiv_one. rewrite <- update_concat_any.
    f_equal.  assert (rev (s :: l) = rev (rev ms)). f_equal. auto.
    rewrite rev_involutive in *. subst. clear Heql. simpl.
    rewrite fold_right_app. simpl. rewrite concat_empty. rewrite fold_right_concat. auto.
Qed.


(* This file has been taken from https://github.com/PrincetonUniversity/VST/blob/master/hmacfcf/HMAC_spec.v *)
(* It has been formatted to fit your repository *)

(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)
Set Implicit Arguments.

Require Import Bvector.
Require Import List.
Require Import Arith.

Definition Blist := list bool.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
    | 0 =>
      fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
    | S n' =>
      fun (v : Vector.t A (S n' + m)) =>
        let (v1, v2) := splitVector _ _ (Vector.tl v) in
          (Vector.cons _ (Vector.hd v) _ v1, v2)
  end.

Section HMAC.

  Variable c p : nat.
  Definition b := c + p.

  (* The compression function *)
  Variable h : Bvector c -> Bvector b -> Bvector c.
  (* The initialization vector is part of the spec of the hash function. *)
  Variable iv : Bvector c.
  (* The iteration of the compression function gives a keyed hash function on lists of words. *)
  Definition h_star k (m : list (Bvector b)) :=
    fold_left h m k.
  (* The composition of the keyed hash function with the IV gives a hash function on lists of words. *)
  Definition hash_words := h_star iv.

  Variable Message : Set.
  Variable splitAndPad : Message -> list (Bvector b).
  Hypothesis splitAndPad_1_1 :
    forall b1 b2,
      splitAndPad b1 = splitAndPad b2 ->
      b1 = b2.

  Variable fpad : Bvector c -> Bvector p.
  Definition app_fpad (x : Bvector c) : Bvector b :=
    (Vector.append x (fpad x)).

  Definition h_star_pad k x :=
    app_fpad (h_star k x).

  Definition GNMAC k m :=
    let (k_Out, k_In) := splitVector c c k in
    h k_Out (app_fpad (h_star k_In m)).

  (* The "two-key" version of GHMAC and HMAC. *)
  Definition GHMAC_2K (k : Bvector (b + b)) m :=
    let (k_Out, k_In) := splitVector b b k in
      let h_in := (hash_words (k_In :: m)) in
        hash_words (k_Out :: (app_fpad h_in) :: nil).

  Definition HMAC_2K (k : Bvector (b + b)) (m : Message) :=
    GHMAC_2K k (splitAndPad m).

  (* opad and ipad are constants defined in the HMAC spec. *)
  Variable opad ipad : Bvector b.
  Hypothesis opad_ne_ipad : opad <> ipad.

  Definition GHMAC (k : Bvector b) :=
    GHMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

  Definition HMAC (k : Bvector b) :=
    HMAC_2K (Vector.append (BVxor _ k opad) (BVxor _ k ipad)).

End HMAC.


Require Import List.
Import ListNotations.

Require Import Bvector.
Require Import Program. (* dependent destruction *)
Require Import Coqlib.

Require Import Utils.
Require Import Bitstream.
Require Import Eager.

Require Import HMAC_spec.
Require Import HMAC_lib.

Fixpoint to_bvector (w : nat) (e : ext_val) : option (Bvector w) :=
  match e,w with
  | eseq (ebit b :: r),S n =>
    match to_bvector n (eseq r) with
    | Some bv =>
      Some (Vector.cons bool b n bv)
    | _ => None
    end
  | eseq nil, O => Some (Vector.nil bool)
  | _,_ => None
  end.

Lemma to_bvector_succeeds :
  forall l n,
    has_type (eseq l) (tseq n tbit) ->
    exists bv,
      to_bvector n (eseq l) = Some bv.
Proof.
  induction l; intros.

  * inversion H. subst. simpl.
    eauto.

  * inversion H. subst. inversion H2.
    subst.
    edestruct IHl. econstructor; eauto.
    inversion H3. subst.
    simpl. rewrite H0.
    eauto.
Qed.

Lemma bytestream_type :
  forall l t,
    Forall (fun x => has_type x t) l ->
    has_type (eseq l) (tseq (length l) t).
Proof.
  induction l; intros.
  econstructor; eauto.
  inversion H. subst.
  econstructor; eauto.
Qed.

Fixpoint bv_to_extval' {w : nat} (bv : Bvector w) : list ext_val :=
  match bv with
  | Vector.nil => nil
  | Vector.cons b _ r => ebit b :: bv_to_extval' r
  end.

Definition bv_to_extval {w : nat} (bv : Bvector w) : ext_val :=
  let bits := bv_to_extval' bv in
  let bytes := get_each_n 8 bits in
  eseq (map eseq bytes).

(* Bottom out with nil, maybe not a great idea but it's ok *)
Fixpoint eappend (l : list ext_val) : ext_val :=
  match l with
  | nil => eseq nil
  | (eseq l0) :: r =>
    match eappend r with
    | eseq x => eseq (l0 ++ x)
    | _ => eseq nil
    end
  | _ => eseq nil
  end.

(* eappend takes a list of sequences of the same type t to one sequence of that type t *)
Lemma eappend_type :
  forall l t,
    (Forall (fun x => exists n, has_type x (tseq n t)) l) ->
    exists n,
      has_type (eappend l) (tseq n t).
Proof.
  induction 1; intros.
  eexists; econstructor; eauto.
  destruct IHForall.
  destruct H.
  inversion H. subst.
  simpl.
  inversion H1. subst.
  eexists. econstructor.
  eapply Forall_app.
  split; eassumption.
Qed.

Definition correct_model_hash {c p : nat} (hf : ext_val -> ext_val) (h : list (Bvector (b c p)) -> Bvector c) : Prop :=
    forall l,
      eseq (bv_to_extval' (h l)) = hf (eappend (map bv_to_extval l)).

(* We need this to be true about the hash function *)
(* HASH takes a list of chunks and produces some bits *)
(* hf takes a stream of bytes and produces a stream of bits *)
(* l is a list of chunks *)
(* (map bv_to_extval l) is a list of ext_val which are all streams of bytes *)
(* eappend (map bv_to_extval l) is a stream of bytes *)
(* this is the correct statement of hash commuting *)
Lemma correct_hash_commutes :
  forall {c p : nat} hf (HASH : list (Bvector (b c p)) -> Bvector c),
    correct_model_hash hf HASH ->
    forall l,
      eseq (bv_to_extval' (HASH l)) = hf (eappend (map bv_to_extval l)).
Proof.
  intros. eapply H.
Qed.

Lemma split_append :
  forall a (x : Bvector a) b (y : Bvector b),
    splitVector a b (Vector.append x y) = (x,y).
Proof.
  induction x; intros.
  simpl. reflexivity.
  simpl. rewrite IHx. reflexivity.
Qed.

Lemma firstn_app :
  forall {A} (l : list A) l',
    firstn (length l) (l ++ l') = l.
Proof.
  induction l; intros; simpl; auto.
  f_equal. eapply IHl.
Qed.

Lemma list_drop_app :
  forall {A} (l : list A) l',
    list_drop (length l) (l ++ l') = l'.
Proof.
  induction l; intros; simpl; auto.
Qed.

Lemma list_drop_length :
  forall {A} (l : list A) n,
    (length (list_drop n l) <= length l)%nat.
Proof.
  induction l; intros.
  simpl. destruct n; simpl; omega.
  simpl. destruct n; simpl. omega.
  specialize (IHl n). omega.
Qed.

Lemma get_each_n'_fuel :
  forall {A} n (l : list A) fuel tot,
    (n >= length l)%nat ->
    (fuel >= length l)%nat ->
    tot <> O ->
    get_each_n' fuel tot l = get_each_n' (length l) tot l.
Proof.
  induction n; intros.
  destruct l; simpl in *; destruct fuel; try reflexivity; omega.
  destruct l. simpl in *.
  destruct fuel; reflexivity.
  assert (n >= length l)%nat by (simpl in *; omega).
  simpl. destruct tot; try omega.
  simpl. destruct fuel; simpl in *; try omega.
  f_equal.
  assert (tot = O \/ tot <> O) by omega.
  destruct H3. subst. simpl.
  eapply IHn; eauto; omega.
  assert (length (list_drop tot l) <= length l)%nat by (eapply list_drop_length; eauto).
  erewrite IHn; try omega.
  symmetry.
  eapply IHn; omega.
Qed.

Lemma get_each_n_head :
  forall {A : Type} (l l' : list A) n,
    n = length l ->
    n <> O ->
    get_each_n n (l ++ l') = [l] ++ get_each_n n l'.
Proof.
  induction l; intros.
  simpl in *. congruence.
  simpl in *.
  destruct n; inversion H.
  assert (n = O \/ n <> O) by omega.
  destruct H1. subst.
  destruct l; simpl in H1; try omega.
  simpl. unfold get_each_n. simpl. reflexivity.
  unfold get_each_n. simpl.
  rewrite firstn_app.
  rewrite list_drop_app.
  f_equal.
  unfold get_each_n in IHl.
  eapply get_each_n'_fuel; eauto.

  rewrite app_length.
  omega.
Qed.

Lemma zero_width_is_nil :
  forall {A} (v : Vector.t A O),
    v = []%vector.
Proof.
  intros.
  dependent destruction v.
  reflexivity.
Qed.

Inductive same_bits' (n : Z) : list bool -> Prop :=
| same_bits_nil :
    same_bits' n nil
| same_bits_cons :
    forall b7 b6 b5 b4 b3 b2 b1 b0 l,
      same_bits' n l ->
      b7 = Z.testbit n 7 ->
      b6 = Z.testbit n 6 ->
      b5 = Z.testbit n 5 ->
      b4 = Z.testbit n 4 ->
      b3 = Z.testbit n 3 ->
      b2 = Z.testbit n 2 ->
      b1 = Z.testbit n 1 ->
      b0 = Z.testbit n 0 ->
      same_bits' n (b7 :: b6 :: b5 :: b4 :: b3 :: b2 :: b1 :: b0 :: l).

Definition same_bits {w : nat} (n : Z) (bv : Bvector w) : Prop := same_bits' n (Vector.to_list bv).

Lemma vector_to_list_cons :
  forall {A : Type} f {w : nat} (r : Vector.t A w),
    Vector.to_list (f :: r)%vector = f :: (Vector.to_list r).
Proof.
  simpl; auto.
Qed.

Lemma vector_to_list_append :
  forall {A : Type} {w' : nat} (f : Vector.t A w') {w : nat} (r : Vector.t A w),
    Vector.to_list (Vector.append f r)%vector = (Vector.to_list f) ++ (Vector.to_list r).
Proof.
  induction f; intros.
  simpl. reflexivity.
  unfold Vector.append. fold (@Vector.append A).
  repeat rewrite vector_to_list_cons.
  simpl. rewrite <- IHf.
  reflexivity.
Qed.

Lemma same_bits_testbit :
  forall {w} n b7 b6 b5 b4 b3 b2 b1 b0 (bv : Bvector w),
    same_bits n (Vector.append [b7;b6;b5;b4;b3;b2;b1;b0]%vector bv) ->
    b7 = Z.testbit n 7 /\
    b6 = Z.testbit n 6 /\
    b5 = Z.testbit n 5 /\
    b4 = Z.testbit n 4 /\
    b3 = Z.testbit n 3 /\
    b2 = Z.testbit n 2 /\
    b1 = Z.testbit n 1 /\
    b0 = Z.testbit n 0 /\
    same_bits n bv.
Proof.
  intros. unfold same_bits in H.
  rewrite vector_to_list_append in H.
  unfold Vector.append in H.
  simpl in H.
  inversion H. subst.
  repeat (split; [solve [auto] | idtac]).
  eassumption.
Qed.

Lemma BVxor_cons :
  forall n b b' v v',
    BVxor (S n) (b :: v)%vector (b' :: v')%vector = ((xorb b b') :: (BVxor n v v'))%vector.
Proof.
  simpl. auto.
Qed.

(* This proof is ugly, but it works *)
Lemma BVxor_to_xor_const :
  forall keylen w ekey nkey opad n,
    has_type (eseq ekey) (bytestream keylen) ->
    bv_to_extval nkey = eseq ekey ->
    same_bits n opad ->
    map eseq (get_each_n 8 (bv_to_extval' (BVxor w nkey opad))) = map (xor_const n) ekey.
Proof.
  induction keylen; intros.
  * unfold bytestream in H.
    inversion H. subst. destruct ekey; simpl in H3; try congruence.
    simpl. destruct nkey; simpl in H0; try congruence.
    Focus 2. unfold bv_to_extval in H0. inversion H0.
    unfold bv_to_extval'.
    assert (BVxor 0 []%vector opad = []%vector) by (eapply zero_width_is_nil).
    rewrite H2. simpl. reflexivity.

  * inversion H.
    destruct ekey; simpl in H3; try congruence.
    destruct nkey.
    unfold bv_to_extval in H0.
    unfold bv_to_extval' in H0. simpl in H0. inversion H0.
    inversion H4.
    unfold bv_to_extval in H0.
    unfold bv_to_extval' in H0.
    fold (@bv_to_extval' n0) in H0.
    inversion H8. subst.
    do 9 (destruct l1; simpl in H10; try congruence).
    clear H10.
    repeat match goal with
           | [ H : Forall (fun x => has_type x tbit) _ |- _ ] => inversion H; clear H
           end;
      repeat match goal with
             | [ H : has_type _ tbit |- _ ] => inversion H; clear H
             end;
    subst.

    do 7 (destruct nkey; [ subst;
    unfold bv_to_extval in H0;
    unfold bv_to_extval' in H0; simpl in H0; inversion H0;
    inversion H4 |
                     unfold bv_to_extval in H0;
                     unfold bv_to_extval' in H0;
                     fold (@bv_to_extval' n0) in H0 ]).
    remember (bv_to_extval' nkey) as extval_key.

    replace ((ebit h :: ebit h0 :: ebit h1 :: ebit h2 :: ebit h3 :: ebit h4 :: ebit h5 :: ebit h6 :: extval_key)) with
        ((ebit h :: ebit h0 :: ebit h1 :: ebit h2 :: ebit h3 :: ebit h4 :: ebit h5 :: ebit h6 :: nil) ++ extval_key) in H0 by reflexivity.

    erewrite get_each_n_head in H0 by (simpl; eauto).
    simpl in H0.
    inversion H0. subst.
    clear H0.
    inversion H3.
    unfold length.

    eapply is_seq in H9.
    replace (tseq (length (map eseq (get_each_n 8 (bv_to_extval' nkey)))) byte) with
        (bytestream (length (map eseq (get_each_n 8 (bv_to_extval' nkey))))) in H9 by reflexivity.

    rewrite H2 in H9.
    do 8 (dependent destruction opad).
    replace (h :: h0 :: h1 :: h2 :: h3 :: h4 :: h5 :: h6 :: opad)%vector with
        (Vector.append (h :: h0 :: h1 :: h2 :: h3 :: h4 :: h5 :: h6 :: [])%vector opad) in H1 by (simpl; auto).
    eapply same_bits_testbit in H1.
    repeat match goal with
           | [ H : _ /\ _ |- _ ] => destruct H
           end.

    eapply IHkeylen in H9;
      [ idtac |
        unfold bv_to_extval; reflexivity
        | eassumption ].

    repeat rewrite BVxor_cons.
    unfold bv_to_extval'.
    fold (@bv_to_extval' n0).
    replace (ebit (xorb b6 h)
        :: ebit (xorb b5 h0)
           :: ebit (xorb b4 h1)
              :: ebit (xorb b3 h2)
                 :: ebit (xorb b2 h3)
                 :: ebit (xorb b1 h4) :: ebit (xorb b0 h5) :: ebit (xorb b h6) :: bv_to_extval' (BVxor n0 nkey opad)) with
        ((ebit (xorb b6 h)
        :: ebit (xorb b5 h0)
           :: ebit (xorb b4 h1)
              :: ebit (xorb b3 h2)
                 :: ebit (xorb b2 h3)
                 :: ebit (xorb b1 h4) :: ebit (xorb b0 h5) :: ebit (xorb b h6) :: nil) ++ bv_to_extval' (BVxor n0 nkey opad)) by (simpl; auto).

    erewrite get_each_n_head by (simpl; auto).
    unfold app.
    repeat rewrite map_cons.
    erewrite <- H9.
    f_equal.

    unfold xor_const.
    unfold xor_const_list.
    unfold length.
    f_equal.
    subst. reflexivity.
Qed.

Lemma eappend_eseq_append :
  forall l1 l2,
    eseq (l1 ++ l2) = eappend ((eseq l1)::(eseq l2)::nil).
Proof.
  intros. simpl. rewrite app_nil_r. reflexivity.
Qed.

Lemma eseq_eq :
  forall x y a b,
    x = y ->
    eseq a = eseq b ->
    eseq (x ++ a) = eseq (y ++ b).
Proof.
  intros. inversion H0. congruence.
Qed.

Lemma bv_to_extval'_append :
  forall {w w'} (x : Bvector w) (y : Bvector w'),
    bv_to_extval' (Vector.append x y) = (bv_to_extval' x) ++ (bv_to_extval' y).
Proof.
  induction x; intros.
  simpl; auto.
  simpl. f_equal. auto.
Qed.

Lemma eseq_backwards :
  forall x y,
    eseq x = eseq y ->
    x = y.
Proof.
  intros. inversion H. auto.
Qed.

Lemma eappend_map_eseq :
  forall {A} f (l : list A),
    eappend (map (fun x => eseq (f x)) l) = eseq (concat (map f l)).
Proof.
  induction l; intros.
  simpl. reflexivity.
  simpl. rewrite IHl. reflexivity.
Qed.

Theorem HMAC_equiv (MSGT : Set) :
  forall keylen msglen key msg,
    has_type key (bytestream keylen) ->
    has_type msg (bytestream msglen) ->
    forall c p hf res HashBlock iv (splitAndPad : MSGT -> list (Bvector (b c p))),
      hmac_model hf key msg = Some res ->
      @correct_model_hash c p hf (h_star p HashBlock iv) ->
      forall nmsg nkey,
        eappend (map bv_to_extval (splitAndPad nmsg)) = msg ->
        bv_to_extval nkey = key ->
        forall opad ipad,
          same_bits 92 opad ->
          same_bits 54 ipad ->
          forall fpad,
            (forall x, bv_to_extval' (app_fpad fpad (h_star p HashBlock iv x)) = bv_to_extval' (h_star p HashBlock iv x)) ->
            eseq (bv_to_extval' (@HMAC c p HashBlock iv MSGT splitAndPad fpad opad ipad nkey nmsg)) = res.
Proof.
  intros.
  unfold HMAC.
  unfold HMAC_2K.
  unfold GHMAC_2K.
  unfold hash_words.
  rewrite split_append.
  simpl.
  unfold hmac_model in H1.
  destruct key; simpl in *; try congruence.
  destruct msg; simpl in *; try congruence.
  destruct (hf (eseq (map (fun x : ext_val => xor_const 54 x) l ++ l0))) eqn:?; try congruence.
  inversion H1.

  match goal with
  | [ |- eseq (bv_to_extval' (HashBlock (HashBlock iv ?V1) ?V2)) = _ ] =>
    replace (HashBlock (HashBlock iv V1) V2) with (h_star p HashBlock iv (V1 :: V2 :: nil)) by (unfold h_star; simpl; reflexivity)
  end.
  match goal with
  | [ |- context[(h_star p HashBlock (HashBlock iv ?V1) ?V2)] ] =>
    replace (h_star p HashBlock (HashBlock iv V1) V2) with (h_star p HashBlock iv (V1 :: V2)) by (simpl; reflexivity)
  end.
  remember (h_star p HashBlock iv) as HASH.

  rename l into ekey.
  rename l0 into emsg.

  erewrite correct_hash_commutes by eassumption.

  f_equal. simpl.
  f_equal.
  f_equal.
  eapply BVxor_to_xor_const; eauto.

  rewrite app_nil_r.
  unfold Pos.to_nat in *.
  simpl in *.

  (* l1 is a list of bits *)
  (* bv_to_extval' returns a list of bits *)
  (* at this point the types work out *)
  f_equal. f_equal.

  remember (splitAndPad nmsg) as msgl.

  rewrite H7.

  eapply eseq_backwards.
  erewrite correct_hash_commutes by eassumption.
  rewrite <- Heqe.
  f_equal.

  (* types still good here *)
  simpl.
  unfold bv_to_extval.
  erewrite eappend_map_eseq.
  f_equal.
  f_equal.

  eapply BVxor_to_xor_const; eauto.

  eapply eseq_backwards.
  erewrite <- H3.
  unfold bv_to_extval.
  erewrite <- eappend_map_eseq.

  reflexivity.
Qed.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import BuiltinSyntax.
Require Import Values.
Require Import Eager.
Require Import Bitstream.

Require Import EvalTac.

Import HaskellListNotations.
Open Scope string.

Require Import HMAC.

Require Import HMAC_spec.

Require Import HMAC_lib.

Require Import Kinit_eval.

(* lemma for when the length of the key is the same as the length of the block *)
Lemma Hmac_eval_keylen_is_blocklength :
  forall (key : ext_val) keylen,
    has_type key (bytestream keylen) ->
    forall GE TE SE,
      wf_env ge GE TE SE ->
      (forall id, In id [(371, "ks");(372, "okey");(373, "ikey");(374, "internal")] -> GE id = None) ->
      forall h hf,
        good_hash h GE TE SE hf ->
        forall msg msglen unused,
          has_type msg (bytestream msglen) ->
          exists v,
            eager_eval_expr GE TE SE (apply (tapply (EVar hmac) ((typenum (Z.of_nat msglen)) :: (typenum (Z.of_nat keylen)) :: (typenum unused) :: (typenum (Z.of_nat keylen)) :: nil)) (h :: h :: h :: (EValue (to_val key)) :: (EValue (to_val msg)) :: nil)) (to_sval v) /\ hmac_model hf key msg = Some v.
Proof.
  intros.
  rename H1 into HIDs.
  rename H2 into H1.
  rename H3 into H2.
  init_globals ge.
  abstract_globals ge.
  edestruct good_hash_complete_eval; eauto.
  do 4 destruct H3.

  inversion H. subst.
  inversion H2. subst.
  remember (hf (eseq (map (fun x3 : ext_val => xor_const 54 x3) l ++ l0))) as hv1.
  assert (HT : exists n, has_type hv1 (tseq n tbit)). {
    assert (exists n, has_type (eseq (map (fun x3 : ext_val => xor_const 54 x3) l ++ l0)) (bytestream n)). {
      eexists. econstructor.
      rewrite Forall_app. split.
      eapply Forall_map. eauto.
      intros. eapply xor_const_byte; eauto.
      eauto.
    }
    destruct H5.
    eapply H4 in H5. destruct H5. subst hv1. eauto.
  }
  destruct HT as [n0'].
  rename H5 into HT.
  edestruct ext_val_list_of_strictval; try eassumption.
  rename H5 into Hlres.

  eexists; split.

  e. e. e. e. e. e. e. e. e.
  ag.

  e. e. e. e. e.
  eassumption.
  e. eassumption.
  e. eassumption.
  e. e.

  eapply strict_eval_val_to_val.

  e. e.
  eapply strict_eval_val_to_val.

  e. e. e. e. e. e. e. e.
  g. simpl. unfold extend. simpl.
  eapply wf_env_not_local; eauto.
  reflexivity.

  e.
  e. e. e.
  eapply eager_eval_global_var.
  reflexivity.
  reflexivity.
  e. e. e. eapply eager_eval_global_var.
  reflexivity.
  reflexivity.

  eapply kinit_eval.

  unfold bind_decl_groups.
  unfold erase_decl_groups.

  repeat eapply wf_env_extend_TE.
  repeat eapply wf_env_erase_SE.
  repeat eapply wf_env_extend_SE.
  repeat eapply wf_env_extend_GE.
  eassumption.

  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.
  reflexivity.

  exact H.

  eapply good_hash_same_eval; eauto.
  e.

  repeat e. repeat e.
  repeat e. e.

  simpl.
  rewrite list_of_strictval_of_strictlist.
  reflexivity.

  (* Begin model section *)
  eapply eager_eval_bind_senvs. eassumption.
  instantiate (1 := fun x => to_sval (xor_const 92 x)).
  intros. e. e. e. g. unfold extend. simpl.
  eapply wf_env_not_local; eauto. reflexivity.
  e. e. e. e. e. e. g.
  unfold extend. simpl.
  eapply wf_env_not_local; eauto. reflexivity.
  e. repeat e. repeat e. e. repeat e.
  repeat e. simpl.
  inversion H5. subst. simpl.
  unfold strictnum.
  unfold Z.to_nat. unfold Pos.to_nat.
  unfold Pos.iter_op. unfold Init.Nat.add.
  rewrite <- H6.
  rewrite xor_num. reflexivity.
  rewrite H6. eassumption.
  reflexivity.
  (* End model section *)

  e. g.
  e. e. e. e. g.
  simpl. unfold extend. simpl. eapply wf_env_not_local; eauto.
  reflexivity.
  e. e. e. e. e. e. e. e. e. e. e. g.
  simpl. unfold extend. simpl. eapply wf_env_not_local; eauto.
  reflexivity.
  e. e. e. e. g.
  e. e. e. g.
  eapply kinit_eval.

  unfold bind_decl_groups.
  unfold erase_decl_groups.
  repeat eapply wf_env_extend_GE.
  repeat eapply wf_env_extend_TE.
  repeat eapply wf_env_erase_SE.
  repeat eapply wf_env_extend_SE.
  assumption.

  all: try solve [reflexivity].

  exact H.

  solve [eapply good_hash_same_eval; eauto; e].

  repeat e.
  repeat e. repeat e. e.

  simpl.
  rewrite list_of_strictval_of_strictlist.
  reflexivity.

  eapply eager_eval_bind_senvs. eassumption.
  instantiate (1 := fun x => to_sval (xor_const 54 x)).
  intros. e. e. e. g. unfold extend. simpl.
  eapply wf_env_not_local; eauto. reflexivity.
  e. e. e. e. e. e. g.
  unfold extend. simpl.
  eapply wf_env_not_local; eauto. reflexivity.
  e. repeat e. repeat e. e. repeat e.
  repeat e. simpl.
  inversion H5. subst. simpl.
  unfold strictnum.
  unfold Z.to_nat. unfold Pos.to_nat.
  unfold Pos.iter_op. unfold Init.Nat.add.
  rewrite <- H6.
  rewrite xor_num. reflexivity.
  rewrite H6. eassumption.
  reflexivity.

  e. e. e. repeat e.
  repeat e.

  unfold to_sval. fold to_sval.
  rewrite append_strict_list.
  reflexivity.

  eapply global_extends_eager_eval.

  replace (map (fun x3 : ext_val => to_sval (xor_const 54 x3)) l) with
      (map to_sval (map (fun x3 => xor_const 54 x3) l)) by (rewrite list_map_compose; reflexivity).
  rewrite <- list_append_map.
  remember (app (map (fun x3 : ext_val => xor_const 54 x3) l) l0) as ll.
  replace (strict_list (map to_sval ll)) with (to_sval (eseq ll)) by (reflexivity).
  subst ll.
  eapply H4.
  econstructor.

  rewrite Forall_app. split; auto.
  eapply Forall_map. eassumption.

  intros. eapply xor_const_byte; eauto.

  unfold bind_decl_groups.
  unfold bind_decl_group.
  unfold declare.

  repeat (eapply global_extends_extend_r; try eapply wf_env_name_irrel_GE; eauto).
  eapply global_extends_refl.

  eapply HIDs. simpl. left. reflexivity.
  eapply HIDs. simpl. right. left. reflexivity.
  eapply HIDs. simpl. right. right. left. reflexivity.
  eapply HIDs. simpl. right. right. right. left. reflexivity.

  e. repeat e.
  e. e. e.

  simpl.
  rewrite <- Heqhv1.
  rewrite Hlres. reflexivity.

  e. repeat e. repeat e.

  rewrite append_strict_list. reflexivity.
  eapply global_extends_eager_eval.

  (* get to_sval out to outside *)
  (* evaluate the hash function *)

  replace (map (fun x4 : ext_val => to_sval (xor_const 92 x4)) l) with
  (map to_sval (map (xor_const 92) l)) by
      (clear -l;
       induction l; simpl; auto; f_equal; eapply IHl; eauto).

  rewrite get_each_n_map_commutes.

  rewrite map_strict_list_map_map_to_sval.
  rewrite <- list_append_map.
  rewrite strict_list_map_to_sval.

  (* This one will be some fun *)
  assert (exists n, has_type (eseq (map (xor_const 92) l ++ map eseq (get_each_n (Pos.to_nat 8) x3))) (bytestream n)). {

    eapply has_type_seq_append.
    exists (Datatypes.length (map (xor_const 92) l)).
    econstructor.
    eapply Forall_map. eassumption.
    intros. eapply xor_const_byte; eauto.
    subst hv1.
    inversion HT. subst.
    rewrite <- H5 in Hlres.
    eapply list_of_strictval_to_sval in Hlres. inversion Hlres.
    subst. clear Hlres.
    remember H1 as HHash.
    clear HeqHHash.
    symmetry in H5.
    eapply good_hash_fully_padded in H1; try eassumption.
    eapply type_stream_of_bytes in H1; eauto.
  }

  destruct H5.
  eapply H4 in H5. destruct H5. eapply H5.

  repeat (eapply global_extends_extend_r; try eapply wf_env_name_irrel_GE; eauto).
  eapply global_extends_refl.

  eapply HIDs. simpl. left. reflexivity.
  eapply HIDs. simpl. right. left. reflexivity.
  eapply HIDs. simpl. right. right. left. reflexivity.
  eapply HIDs. simpl. right. right. right. left. reflexivity.

  (* our result matches the model *)
  subst hv1.
  eapply list_of_strictval_to_sval in Hlres.
  simpl. rewrite Hlres.

  reflexivity.

  Unshelve.
  all: exact id.

Qed.


Require Import List.
Import ListNotations.
Require Import String.

(* Borrow from CompCert *)
Require Import Coqlib.
Require Import Bitvectors.

Require Import AST.
Require Import Semantics.
Require Import Utils.
Require Import Builtins.
Require Import BuiltinSem.
Require Import BuiltinSyntax.
Require Import Values.
Require Import Eager.
Require Import Bitstream.

Require Import EvalTac.

Import HaskellListNotations.
Open Scope string.

Require Import HMAC.

Require Import HMAC_spec.

Require Import HMAC_lib.

Lemma kinit_eval :
  forall GE TE SE,
    wf_env ge GE TE SE ->
    forall (key : ext_val) keylen,
      has_type key (bytestream keylen) ->
      forall h hf,
        good_hash h GE TE SE hf ->
        forall digest t1 t2 t3 kexpr,
          eager_eval_type GE TE t1 (tnum (Z.of_nat keylen)) ->
          eager_eval_type GE TE t2 (tnum (Z.of_nat keylen)) ->
          eager_eval_type GE TE t3 (tnum digest) ->
          eager_eval_expr GE TE SE kexpr (to_sval key) ->
          eager_eval_expr GE TE SE (apply (tapply (EVar kinit) (ETyp t1 :: ETyp t2 :: ETyp t3 ::  nil)) (h :: kexpr :: nil)) (to_sval key).
Proof.
  intros.
  eapply good_hash_eval in H1. do 4 destruct H1.
  init_globals ge.
  abstract_globals ge.

  unfold bytestream in H0. inversion H0. subst.

  e. e. e. e. e. ag.
  e. e. e. e.
  eassumption.
  e. eassumption.
  e. e. e. e.

  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.
  e. e. e. e.
  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.

  e. e. e. repeat e. repeat e. reflexivity.
  e. e. e.

  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.

  e. e. e. repeat e.
  repeat e. reflexivity.
  e. repeat e. repeat e.
  simpl. unfold strictnum.

  rewrite gt_not_refl; reflexivity.
  simpl.

  e. e. e. e.

  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.
  eapply wf_env_global; eauto. reflexivity.
  e. e. e. e. e. e. e. e. e.
  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.

  e. e. e. e. e. e. e.
  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.

  e. e. repeat e.
  repeat e.
  reflexivity.

  e. repeat e. repeat e.

  unfold to_sval. fold to_sval.
  rewrite append_strict_list.
  reflexivity.

  e. g. e. g. e. e. e. e.
  g. unfold extend. simpl.
  eapply wf_env_not_local; eauto; reflexivity.

  e. e. e. e. e. e. repeat e.
  repeat e.

  erewrite <- map_length.
  rewrite splitAt_len. reflexivity.

  simpl. reflexivity.
Qed.