(*

  Copyright 2016 Luxembourg University
  Copyright 2017 Luxembourg University

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export Simulator.
Require Export PBFT.
Require Export PBFTcollision_resistant.
Require Import Ascii String.
(*Require Import SHA256.*)

(*
    We'll define here an instance of PBFT so that we can simulate it.
 *)

(* ================== INSTANCE OF PBFT ================== *)

Section PBFTinstance.

(*  Class NumNodes := MkNumNodes { total_num_faults : nat; total_num_clients : nat }.
  Context { p_num_nodes : NumNodes }.*)

  (* ============================================ *)
  (* total_num_faults *)
  Definition F := 1.

  (* total_num_clients is C+1 *)
  Definition C := 0.

  (* max requests in progress *)
  Definition MIP := 2.

  (* water-mark range *)
  Definition WMR := 100.

  (* checkpoint period *)
  Definition CP := 50.
  (* ============================================ *)

  Definition pbft_digest : Set := list nat.

  Lemma pbft_digest_deq : Deq pbft_digest.
  Proof.
    introv; apply list_eq_dec.
    apply deq_nat.
  Defined.

  Inductive sending_key_stub : Set :=
  | pbft_sending_key_stub.

  Inductive receiving_key_stub : Set :=
  | pbft_receiving_key_stub.

  Definition pbft_sending_key   : Set := sending_key_stub.
  Definition pbft_receiving_key : Set := receiving_key_stub.

  (*Definition F : nat := 1.*)
  Definition nreps (F : nat) : nat := 3 * F + 1.

  Definition replica (F : nat) : Set := nat_n (nreps F).

  Lemma replica_deq (F : nat) : Deq (replica F).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition reps2nat (F : nat) : replica F -> nat_n (nreps F) := fun n => n.

  Lemma bijective_reps2nat (F : nat) : bijective (reps2nat F).
  Proof.
    exists (fun n : nat_n (nreps F) => n); introv; unfold reps2nat; auto.
  Defined.

  Definition nclients (C : nat) : nat := S C.

  Definition client (C : nat) : Set := nat_n (nclients C).

  Definition client0 (C : nat) : client C.
  Proof.
    exists 0.
    apply leb_correct.
    unfold nclients.
    omega.
  Defined.

  Lemma client_deq (C : nat) : Deq (client C).
  Proof.
    apply nat_n_deq.
  Defined.

  Definition clients2nat (C : nat) : client C -> nat_n (nclients C) := fun n => n.

  Lemma bijective_clients2nat (C : nat) : bijective (clients2nat C).
  Proof.
    exists (fun n : nat_n (nclients C) => n); introv; unfold clients2nat; auto.
  Defined.

  Inductive operation :=
  | opr_add (n : nat)
  | opr_sub (n : nat).

  Lemma operation_deq : Deq operation.
  Proof.
    introv; destruct x as [n|n], y as [m|m]; prove_dec;
      destruct (deq_nat n m); subst; prove_dec.
  Defined.

  Definition smState : Set := nat.
  Definition result : Set := nat.

  Definition operation_upd (C : nat) (c : client C) (state : smState) (opr : operation) : result * smState :=
    match opr with
    | opr_add m => let k := state + m in (k,k)
    | opr_sub m => let k := state - m in (k,k)
    end.

  Inductive PBFTtoken_stub : Set :=
  | pbft_token_stub.

  Definition pbft_token : Set := PBFTtoken_stub.

  Lemma pbft_token_deq : Deq pbft_token.
  Proof.
    introv; destruct x, y; simpl; prove_dec.
  Defined.

  Global Instance PBFT_I_context : PBFTcontext :=
    MkPBFTcontext
      (* max in progress *)
      MIP

      (* water mark range *)
      WMR

      (* checkpoint period *)
      CP

      (* digest type *)
      pbft_digest

      (* digest decider *)
      pbft_digest_deq

      (* token type *)
      pbft_token

      (* token decider *)
      pbft_token_deq

      (* sending key type *)
      pbft_sending_key

      (* receiving key type *)
      pbft_receiving_key

      (* number of faults *)
      F

      (* replica type *)
      (replica F)

      (* Replica decider *)
      (replica_deq F)

      (* replica 2 nat *)
      (reps2nat F)

      (* proof that reps2nat is bijective *)
      (bijective_reps2nat F)

      (* number of clients *)
      (nclients C)

      (* client type *)
      (client C)

      (* client decider *)
      (client_deq C)

      (* client 2 nat *)
      (clients2nat C)

      (* proof that clients2nat is bijective *)
      (bijective_clients2nat C)

      (* operation type *)
      operation

      (* operation decider *)
      operation_deq

      (* result type *)
      result

      (* result decider *)
      deq_nat

      (* state type *)
      smState

      (* initial state *)
      0

      (* update function *)
      (operation_upd C)

      (* delay in ms *)
      1000.

  Definition pbft_create_signature
             (m  : PBFTBare_Msg)
             (ks : sending_keys) : PBFTtokens := [pbft_token_stub].

  Definition pbft_verify_signature
             (m : PBFTBare_Msg)
             (n : name)
             (k : receiving_key)
             (a : pbft_token) : bool := true.

  Global Instance PBFT_I_auth : PBFTauth :=
    MkPBFTauth pbft_create_signature pbft_verify_signature.

  Definition pbft_lookup_replica_sending_key   (i : Rep) (dst : Rep)    : pbft_sending_key   := pbft_sending_key_stub.
  Definition pbft_lookup_replica_receiving_key (i : Rep) (dst : Rep)    : pbft_receiving_key := pbft_receiving_key_stub.

  Definition pbft_lookup_client_sending_key    (i : Rep) (c   : Client) : pbft_sending_key   := pbft_sending_key_stub.
  Definition pbft_lookup_client_receiving_key  (i : Rep) (c   : Client) : pbft_receiving_key := pbft_receiving_key_stub.

  Definition initial_pbft_local_key_map_replicas (src : name) : local_key_map :=
    match src with
    | PBFTreplica i =>
      MkLocalKeyMap
        (List.app
           (map (fun c => MkDSKey [PBFTclient c]  (pbft_lookup_client_sending_key  i c)) clients)
           (map (fun m => MkDSKey [PBFTreplica m] (pbft_lookup_replica_sending_key i m)) reps))
        (List.app
           (map (fun c => MkDRKey [PBFTclient c]  (pbft_lookup_client_receiving_key  i c)) clients)
           (map (fun m => MkDRKey [PBFTreplica m] (pbft_lookup_replica_receiving_key i m)) reps))
    | PBFTclient _ => MkLocalKeyMap [] []
    end.

  Global Instance PBFT_I_keys : PBFTinitial_keys :=
    MkPBFTinitial_keys initial_pbft_local_key_map_replicas.

  Definition pbft_simple_create_hash_messages (msgs : list PBFTmsg) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_messages (msgs : list PBFTmsg) (d : PBFTdigest) := true.
  Definition pbft_simple_create_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) : PBFTdigest := [].
  Definition pbft_simple_verify_hash_state_last_reply (smst : PBFTsm_state) (lastr : LastReplyState) (d : PBFTdigest) := true.

  Global Instance PBFT_I_hash : PBFThash :=
    MkPBFThash
      pbft_simple_create_hash_messages
      pbft_simple_verify_hash_messages
      pbft_simple_create_hash_state_last_reply
      pbft_simple_verify_hash_state_last_reply.

  (*Lemma simple_create_hash_messages_collision_resistant :
  forall msgs1 msgs2,
    simple_create_hash_messages msgs1 = simple_create_hash_messages msgs2
    -> msgs1 = msgs2.
Proof.
  introv h.
  unfold simple_create_hash_messages in *.
Admitted.

Lemma simple_create_hash_state_last_reply_collision_resistant :
  forall sm1 sm2 last1 last2,
    simple_create_hash_state_last_reply sm1 last1 = simple_create_hash_state_last_reply sm2 last2
    -> sm1 = sm2 /\ last1 = last2.
Proof.
  introv h.
Admitted.

Global Instance PBFT_I_hash_axioms : PBFThash_axioms.
Proof.
  exact (Build_PBFThash_axioms
           (* create_hash_message is collision resistant *)
           simple_create_hash_messages_collision_resistant

           (* create_hash_state_last_reply is collision resistant *)
           simple_create_hash_state_last_reply_collision_resistant
        ).
Defined.
   *)

  (* ================== TIME ================== *)

  Definition time_I_type : Set := unit.

  Definition time_I_get_time : unit -> time_I_type := fun _ => tt.

  Definition time_I_sub : time_I_type -> time_I_type -> time_I_type := fun _ _ => tt.

  Definition time_I_2string : time_I_type -> string := fun _ => "".

  Global Instance TIME_I : Time.
  Proof.
    exists time_I_type.
    { exact time_I_get_time. }
    { exact time_I_sub. }
    { exact time_I_2string. }
  Defined.

  (* ================== PRETTY PRINTING ================== *)

  (* FIX: to replace when extracting *)
  Definition print_endline : string -> unit := fun _ => tt.
  Definition nat2string (n : nat) : string := "-".

  Definition CR : string := String (ascii_of_nat 13) "".

  Definition token2string (t : Token) : string := "-".

  Fixpoint tokens2string (toks : Tokens) : string :=
    match toks with
    | [] => ""
    | [t] => token2string t
    | t :: ts => str_concat [token2string t, ",", tokens2string ts]
    end.

  (* Fix: to finish *)
  Definition digest2string (d : pbft_digest) : string := "-".

  (* Fix: to finish *)
  Definition result2string (r : result) : string := "-".

  (* Fix: there's only one client anyway *)
  Definition client2string (c : client C) : string := "-".

  Definition timestamp2string (ts : Timestamp) : string :=
    match ts with
    | time_stamp n => nat2string n
    end.

  Definition view2string (v : View) : string :=
    match v with
    | view n => nat2string n
    end.

  Definition seq2string (s : SeqNum) : string :=
    match s with
    | seq_num n => nat2string n
    end.

  Definition operation2string (opr : operation) : string :=
    match opr with
    | opr_add n => str_concat ["+", nat2string n]
    | opr_sub n => str_concat ["-", nat2string n]
    end.

  Definition nat_n2string {m} (n : nat_n m) : string := nat2string (proj1_sig n).

  Definition replica2string (r : replica F) : string := nat_n2string r.

  Definition bare_request2string (br : Bare_Request) : string :=
    match br with
    | null_req => str_concat [ "null_req"]
    | bare_req opr ts c => str_concat [operation2string opr, ",", timestamp2string ts, ",", client2string c]
    end.

  Definition request2string (r : Request) : string :=
    match r with
    | req br a => str_concat ["REQUEST(", bare_request2string br, ",", tokens2string a, ")"]
    end.

  Fixpoint requests2string (rs : list Request) : string :=
    match rs with
    | [] => ""
    | [r] => request2string r
    | r :: rs => str_concat [request2string r, ",", requests2string rs]
    end.

  Definition bare_pre_prepare2string (bpp : Bare_Pre_prepare) : string :=
    match bpp with
    | bare_pre_prepare v s reqs => str_concat [view2string v, ",", seq2string s, ",", requests2string reqs]
    end.

  Definition bare_prepare2string (bp : Bare_Prepare) : string :=
    match bp with
    | bare_prepare v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_commit2string (bc : Bare_Commit) : string :=
    match bc with
    | bare_commit v s d i => str_concat [view2string v, ",", seq2string s, ",", digest2string d, ",", replica2string i]
    end.

  Definition bare_reply2string (br : Bare_Reply) : string :=
    match br with
    | bare_reply v ts c i res => str_concat [view2string v, ",", timestamp2string ts, ",", client2string c, ",", replica2string i, ",", result2string res]
    end.

  Definition pre_prepare2string (pp : Pre_prepare) : string :=
    match pp with
    | pre_prepare b a => str_concat ["PRE_PREPARE(",bare_pre_prepare2string b, ",", tokens2string a, ")"]
    end.

  Definition prepare2string (p : Prepare) : string :=
    match p with
    | prepare bp a => str_concat ["PREPARE(", bare_prepare2string bp, ",", tokens2string a, ")"]
    end.

  Definition commit2string (c : Commit) : string :=
    match c with
    | commit bc a => str_concat ["COMMIT(", bare_commit2string bc, ",", tokens2string a, ")"]
    end.

  Definition reply2string (r : Reply) : string :=
    match r with
    | reply br a => str_concat ["REPLY(", bare_reply2string br, ",", tokens2string a, ")"]
    end.

  Definition debug2string (d : Debug) : string :=
    match d with
    | debug r s => str_concat ["DEBUG(", replica2string r, ",", s, ")"]
    end.

  Definition bare_checkpoint2string (bc : Bare_Checkpoint) : string :=
    match bc with
    | bare_checkpoint v n d i => str_concat [view2string v, ",", seq2string n, ",", digest2string d, ",", replica2string i]
    end.

  Definition checkpoint2string (c : Checkpoint) : string :=
    match c with
    | checkpoint bc a => str_concat ["CHECKPOINT(", bare_checkpoint2string bc, ",", tokens2string a, ")"]
    end.

  Definition check_ready2string (c : CheckReady) : string := "CHECK-READY()".

  Definition check_stable2string (c : CheckStableChkPt) : string := "CHECK-STABLE()".

  Definition start_timer2string (t : StartTimer) : string :=
    match t with
    | start_timer r v => str_concat ["START-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  Definition expired_timer2string (t : ExpiredTimer) : string :=
    match t with
    | expired_timer r v => str_concat ["EXPIRED-TIMER(", bare_request2string r, "," , view2string v, ")"]
    end.

  (* FIX *)
  Definition stable_chkpt2string (stable : StableChkPt) : string := "-".

  (* FIX *)
  Definition checkpoint_cert2string (cert : CheckpointCert) : string := "-".

  (* FIX *)
  Definition prepared_infos2string (l : list PreparedInfo) : string := "-".

  Definition bare_view_change2string (bvc : Bare_ViewChange) : string :=
    match bvc with
    | bare_view_change v n stable cert preps i =>
      str_concat
        [view2string v,
         ",",
         seq2string n,
         ",",
         stable_chkpt2string stable,
         ",",
         checkpoint_cert2string cert,
         ",",
         prepared_infos2string preps,
         ",",
         replica2string i
        ]
    end.

  Definition view_change2string (vc : ViewChange) : string :=
    match vc with
    | view_change bvc a => str_concat ["VIEW-CHANGE(", bare_view_change2string bvc, ",", tokens2string a, ")"]
    end.

  (* FIX *)
  Definition view_change_cert2string (V : ViewChangeCert) : string := "-".

  Fixpoint pre_prepares2string (l : list Pre_prepare) : string :=
    match l with
    | [] => ""
    | [r] => pre_prepare2string r
    | r :: rs => str_concat [pre_prepare2string r, ",", pre_prepares2string rs]
    end.

  Definition bare_new_view2string (bnv : Bare_NewView) : string :=
    match bnv with
    | bare_new_view v V OP NP =>
      str_concat
        [
          view2string v,
          ",",
          view_change_cert2string V,
          ",",
          pre_prepares2string OP,
          ",",
          pre_prepares2string NP
        ]
    end.

  Definition new_view2string (nv : NewView) : string :=
    match nv with
    | new_view bnv a => str_concat ["NEW-VIEW(", bare_new_view2string bnv, ",", tokens2string a, ")"]
    end.

  Definition check_bcast_new_view2string (c : CheckBCastNewView) : string :=
    match c with
    | check_bcast_new_view i => str_concat ["CHECK-BCAST-NEW-VIEW(", nat2string i, ")"]
    end.

  Definition msg2string (m : PBFTmsg) : string :=
    match m with
    | PBFTrequest r              => request2string r
    | PBFTpre_prepare pp         => pre_prepare2string pp
    | PBFTprepare p              => prepare2string p
    | PBFTcommit c               => commit2string c
    | PBFTcheckpoint c           => checkpoint2string c
    | PBFTcheck_ready c          => check_ready2string c
    | PBFTcheck_stable c         => check_stable2string c
    | PBFTcheck_bcast_new_view c => check_bcast_new_view2string c
    | PBFTstart_timer t          => start_timer2string t
    | PBFTexpired_timer t        => expired_timer2string t
    | PBFTview_change v          => view_change2string v
    | PBFTnew_view v             => new_view2string v
    | PBFTdebug d                => debug2string d
    | PBFTreply r                => reply2string r
    end.

  Definition name2string (n : name) : string :=
    match n with
    | PBFTreplica r => replica2string r
    | PBFTclient c => client2string c
    end.

  Fixpoint names2string (l : list name) : string :=
    match l with
    | [] => ""
    | [n] => name2string n
    | n :: ns => str_concat [name2string n, ",", names2string ns]
    end.

  Definition delay2string (delay : nat) : string := nat2string delay.

  Definition DirectedMsg2string (dm : DirectedMsg) : string :=
    match dm with
    | MkDMsg msg dst delay =>
      str_concat [msg2string msg, ":", "[", names2string dst, "]", ":", delay2string delay]
    end.

  Fixpoint DirectedMsgs2string (l : DirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => DirectedMsg2string dm
    | dm :: dmsgs => str_concat [DirectedMsg2string dm, CR, DirectedMsgs2string dmsgs]
    end.

  Definition TimedDirectedMsg2string (m : TimedDirectedMsg) : string :=
    match m with
    | MkTimedDMsg dm time => str_concat [DirectedMsg2string dm, ":", time_I_2string time]
    end.

  Fixpoint TimedDirectedMsgs2string (l : TimedDirectedMsgs) : string :=
    match l with
    | [] => ""
    | [dm] => TimedDirectedMsg2string dm
    | dm :: dmsgs => str_concat [TimedDirectedMsg2string dm, CR, TimedDirectedMsgs2string dmsgs]
    end.

  Definition MonoSimulationState2string (s : MonoSimulationState) : string :=
    match s with
    | MkMonoSimState ty sys step out_inflight in_inflight delivered =>
      str_concat
        [CR,
         "====== STEP ======",
         CR,
         nat2string step,
         CR,
         "====== IN FLIGHT (from outside the system) ======",
         CR,
         DirectedMsgs2string out_inflight,
         CR,
         "====== IN FLIGHT (from inside the system) ======",
         CR,
         DirectedMsgs2string in_inflight,
         CR,
         "====== DELIVERED ======",
         CR,
         TimedDirectedMsgs2string delivered,
         CR]
    end.

  Definition pbft_state2string (s : PBFTstate) :=
      str_concat
        ["(checkpoint state size:"
         , nat2string (List.length (chk_state_others (cp_state s)))
         ,")"
         ,"(ready size:"
         , nat2string (List.length (ready s))
         ,")"
         ,"(buffered requests:"
         , nat2string (List.length (request_buffer (primary_state s)))
         ,")"
         ,"(log size:"
         , nat2string (List.length (log s))
         ,")"
        ].

  (* ================== SYSTEM ================== *)

  Definition dummy_initial_state : PBFTstate :=
    Build_State
      (MkLocalKeyMap [] [])
      initial_view
      []
      initial_checkpoint_state
      PBFTsm_initial_state
      initial_next_to_execute
      initial_ready
      initial_last_reply
      initial_view_change_state
      initial_primary_state.

  Definition PBFTdummySM : MStateMachine PBFTstate :=
    MhaltedSM dummy_initial_state.

  Definition PBFTmono_sys : NMStateMachine PBFTstate :=
    fun name =>
      match name with
      | PBFTreplica n => PBFTreplicaSM n
      | _ => MhaltedSM dummy_initial_state
      end.

  Definition mk_request_to (rep : Rep) (ts : nat) (opr : nat) : DirectedMsg :=
    let ts   := time_stamp ts in
    let breq := bare_req (opr_add opr) ts (client0 C) in
    let dst  := PBFTreplica rep in (* the leader *)
    let toks := [ pbft_token_stub ] : Tokens in (* we just send empty lists here to authenticate messages *)
    let req  := req breq toks in
    let msg  := PBFTrequest req in
    MkDMsg msg [dst] 0.

  Definition mk_request (ts : nat) (opr : nat) : DirectedMsg :=
    mk_request_to (PBFTprimary initial_view) ts opr.

  (* n request starting with number start *)
  Fixpoint mk_requests_start (n start opr : nat) : DirectedMsgs :=
    match n with
    | 0 => []
    | S m => List.app (mk_requests_start m start opr) [mk_request (n + start) opr]
    end.

  Definition mk_requests (n opr : nat) : DirectedMsgs :=
    mk_requests_start n 0 opr.

  Record InitRequests :=
    MkInitRequests
      {
        num_requests     : nat;
        starting_seq_num : nat;
        req_operation    : nat;
      }.

  Definition PBFTinit_msgs (msgs : DirectedMsgs) : MonoSimulationState :=
    MkInitMonoSimState PBFTmono_sys msgs.

  Definition PBFTinit (init : InitRequests) : MonoSimulationState :=
    PBFTinit_msgs
      (mk_requests_start
         (num_requests init)
         (starting_seq_num init)
         (req_operation init)).

  Definition PBFTsimul_list (init : InitRequests) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit init).

  Definition PBFTsimul_list_msgs (msgs : DirectedMsgs) (L : list nat) : MonoSimulationState :=
    mono_run_n_steps L (PBFTinit_msgs msgs).

  (* [switch] is the list of steps at which we want to switch to sending messages
   coming from the outside (from clients) instead of keeping on sending messages
   coming from the inside (from replicas). *)
  Definition PBFTsimul_n
             (init     : InitRequests) (* This is to generate an initial list of requests *)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit init).

  Definition PBFTsimul_n_msgs
             (msgs     : DirectedMsgs)
             (rounds   : Rounds)
             (switches : Switches) : MonoSimulationState :=
    mono_iterate_n_steps rounds switches (PBFTinit_msgs msgs).

End PBFTinstance.

(* ================== EXTRACTION ================== *)

Extraction Language Ocaml.

(* printing stuff *)
Extract Inlined Constant print_endline => "Prelude.print_coq_endline".
Extract Inlined Constant nat2string    => "Prelude.char_list_of_int".
Extract Inlined Constant CR            => "['\n']".

(* numbers *)
Extract Inlined Constant Nat.modulo    => "(mod)".

(* timing stuff *)
Extract Inlined Constant time_I_type     => "float".
Extract Inlined Constant time_I_get_time => "Prelude.Time.get_time".
Extract Inlined Constant time_I_sub      => "Prelude.Time.sub_time".
Extract Inlined Constant time_I_2string  => "Prelude.Time.time2string".

(* crypto stuff *)
(* === COMMENT OUT THIS PART IF YOU DON'T WANT TO USE KEYS === *)
Extract Inlined Constant pbft_sending_key   => "Cstruct.t".
Extract Inlined Constant pbft_receiving_key => "Cstruct.t".
Extract Inlined Constant pbft_lookup_replica_sending_key   => "MacKeyFun.lookup_replica_key".
Extract Inlined Constant pbft_lookup_replica_receiving_key => "MacKeyFun.lookup_replica_key".
Extract Inlined Constant pbft_lookup_client_sending_key    => "MacKeyFun.lookup_client_key".
Extract Inlined Constant pbft_lookup_client_receiving_key  => "MacKeyFun.lookup_client_key".

Extract Inlined Constant pbft_create_signature => "MacKeyFun.sign_list".
Extract Inlined Constant pbft_verify_signature => "MacKeyFun.verify_one".
Extract Inlined Constant pbft_token => "Cstruct.t".
Extract Inlined Constant pbft_token_deq => "(=)".
Extract Inlined Constant token2string => "(fun t -> Batteries.String.to_list (Sexplib.Sexp.to_string (Cstruct.sexp_of_t (Obj.magic t))))".
(* === --- === *)

(* == hashing stuff == *)
Extract Inlined Constant pbft_digest => "Cstruct.t".
Extract Inlined Constant pbft_digest_deq => "(=)".
Extract Inlined Constant pbft_simple_create_hash_messages => "Obj.magic (Hash.create_hash_objects)".
Extract Inlined Constant pbft_simple_verify_hash_messages => "Obj.magic (Hash.verify_hash_objects)".
Extract Inlined Constant pbft_simple_create_hash_state_last_reply => "Obj.magic (Hash.create_hash_pair)".
Extract Inlined Constant pbft_simple_verify_hash_state_last_reply => "Obj.magic (Hash.verify_hash_pair)".
(* === --- === *)

Require Export ExtrOcamlBasic.
Require Export ExtrOcamlNatInt.
Require Export ExtrOcamlString.

Definition local_replica (*(F C : nat)*) :=
  @PBFTreplicaSM
    (@PBFT_I_context (*(MkNumNodes F C)*))
    PBFT_I_auth
    PBFT_I_keys
    PBFT_I_hash.

Extraction "PbftReplica.ml" pbft_state2string lrun_sm MonoSimulationState2string PBFTdummySM local_replica.


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2004-09-06

This file provides an implementation of finite multisets using list
representation.
*)

Set Implicit Arguments.

From Coq Require Import Permutation PermutSetoid Omega Multiset.
From CoLoR Require Import LogicUtil RelExtras MultisetCore ListExtras.

Module MultisetList (ES : Eqset_dec) <: MultisetCore with Module Sid := ES.

  Module Export Sid := ES.

Section Operations.

  Definition Multiset := list A.

  Definition empty : Multiset := nil.
  Definition singleton a : Multiset := a :: nil.
  Definition union := app (A:=A).
  Definition meq := permutation eqA eqA_dec.

  Definition mult := countIn eqA eqA_dec.
  Definition rem := removeElem eqA eqA_dec.
  Definition diff := removeAll eqA eqA_dec.

  Definition intersection := inter_as_diff diff.

  Definition fold_left := fun T : Type => List.fold_left (A := T) (B := A).

End Operations.

  Infix "=mul=" := meq (at level 70) : msets_scope.
  Notation "X <>mul Y" := (~meq X Y) (at level 50) : msets_scope.
  Notation "{{ x }}" := (singleton x) (at level 5) : msets_scope.
  Infix "+" := union : msets_scope.
  Infix "-" := diff : msets_scope.
  Infix "#" := intersection (at level 50, left associativity) : msets_scope.
  Infix "/" := mult : msets_scope.

  Delimit Scope msets_scope with msets.
  Open Scope msets_scope.
  Bind Scope msets_scope with Multiset.

Section ImplLemmas.

  Lemma empty_empty : forall M, (forall x, x / M = 0) -> M = empty.

  Proof.
    intros M mulM; destruct M.
    trivial.
    absurd (a / (a::M) = 0).
    simpl. destruct (eqA_dec a a); auto with sets.
    auto.
  Qed.

End ImplLemmas.

Section SpecConformation.

  Lemma mult_eqA_compat : forall M x y, x =A= y -> x / M = y / M.

  Proof.
     induction M.
     auto.
     intros; simpl.
     destruct (eqA_dec x a); destruct (eqA_dec y a); intros;
       solve [ absurd (y =A= a); eauto with sets
             | assert (x / M = y / M); auto ].
  Qed.

  Lemma mult_comp : forall l a,
    a / l = multiplicity (list_contents eqA eqA_dec l) a.

  Proof.
    induction l.
    auto.
    intro a0; simpl.
    destruct (eqA_dec a0 a); destruct (eqA_dec a a0); simpl;
    rewrite <- (IHl a0); (reflexivity || absurd (a0 =A= a); auto with sets).
  Qed.

  Lemma multeq_meq : forall M N, (forall x, x / M = x / N) -> M =mul= N.

  Proof.
    unfold meq. intros M N mult_MN x. rewrite <- !mult_comp. exact (mult_MN x).
  Qed.

  Lemma meq_multeq : forall M N, M =mul= N -> forall x, x / M = x / N.

  Proof.
    unfold meq, permutation, Multiset.meq.
    intros M N eqMN x. rewrite !mult_comp. exact (eqMN x).
  Qed.

  Lemma empty_mult : forall x, mult x empty = 0.

  Proof. auto. Qed.

  Lemma union_mult : forall M N x,
                       (x/(M + N))%msets = ((x/M)%msets + (x/N)%msets)%nat.

  Proof.
    induction M; auto.
    intros N x; simpl. destruct (eqA_dec x a); auto. rewrite IHM. auto.
  Qed.

  Lemma diff_empty_l : forall M, empty - M = empty.

  Proof.
    induction M; auto.
  Qed.

  Lemma diff_empty_r : forall M, M - empty = M.

  Proof.
    induction M; auto.
  Qed.

  Lemma mult_remove_in : forall x a M,
    x =A= a -> (x / (rem a M))%msets = ((x / M)%msets - 1)%nat.

  Proof.
    induction M.
    auto.
    intro x_a.
    simpl; destruct (eqA_dec x a0); destruct (eqA_dec a a0);
      simpl; try solve [absurd (x =A= a); eauto with sets].
    auto with arith.
    destruct (eqA_dec x a0).
    contr.
    auto.
  Qed.

  Lemma mult_remove_not_in : forall M a x,
    ~ x =A= a -> x / (rem a M) = x / M.

  Proof.
    induction M; intros.
    auto.
    simpl; destruct (eqA_dec a0 a).
    destruct (eqA_dec x a);
      solve [absurd (x =A= a); eauto with sets | trivial].
    simpl; destruct (eqA_dec x a).
    rewrite (IHM a0 x); trivial.
    apply IHM; trivial.
  Qed.

  Lemma remove_perm_single : forall x a b M,
   x / (rem a (rem b M)) = x / (rem b (rem a M)).

  Proof.
    intros x a b M.
    case (eqA_dec x a); case (eqA_dec x b); intros x_b x_a.
     (* x=b,  x=a *)
    rewrite !mult_remove_in; trivial.
     (* x<>b, x=a *)
    rewrite mult_remove_in; trivial.
    do 2 (rewrite mult_remove_not_in; trivial).
    rewrite mult_remove_in; trivial.
     (* x=b,  x<>a *)
    rewrite mult_remove_not_in; trivial.
    do 2 (rewrite mult_remove_in; trivial).
    rewrite mult_remove_not_in; trivial.
     (* x<>b, x<>a *)
    rewrite !mult_remove_not_in; trivial.
  Qed.

  Lemma diff_mult_comp : forall x N M M',
    M =mul= M' -> x / (M - N) = x / (M' - N).

  Proof.
    induction N.
    intros; apply meq_multeq; trivial.
    intros M M' MM'.
    simpl.
    apply IHN.
    apply multeq_meq.
    intro x'.
    case (eqA_dec x' a).
    intro xa; rewrite !mult_remove_in; trivial.
    rewrite (meq_multeq MM'); trivial.
    intro xna; rewrite !mult_remove_not_in; trivial.
    apply meq_multeq; trivial.
  Qed.

  Lemma diff_perm_single : forall x a b M N,
    x / (M - (a::b::N)) = x / (M - (b::a::N)).

  Proof.
    intros x a b M N.
    simpl; apply diff_mult_comp.
    apply multeq_meq.
    intro x'; apply remove_perm_single.
  Qed.

  Lemma diff_perm : forall M N a x,
    x / ((rem a M) - N) = x / (rem a (M - N)).

  Proof.
    intros M N; gen M; clear M.
    induction N.
    auto.
    intros M b x.
    change (rem b M - (a::N)) with (M - (b::a::N)).
    rewrite diff_perm_single.
    simpl; apply IHN.
  Qed.

  Lemma diff_mult_step_eq : forall M N a x,
    x =A= a -> x / (rem a M - N) = ((x / (M - N))%msets - 1)%nat.

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_in; trivial.
  Qed.

  Lemma diff_mult_step_neq : forall M N a x,
    ~ x =A= a -> x / (rem a M - N) = x / (M - N).

  Proof.
    intros M N a x x_a.
    rewrite diff_perm.
    rewrite mult_remove_not_in; trivial.
  Qed.

  Lemma diff_mult : forall M N x,
                      x / (M - N) = ((x / M)%msets - (x / N)%msets)%nat.

  Proof.
    induction N.
     (* induction base *)
    simpl; intros; omega.
     (* induction step *)
    intro x; simpl.
    destruct (eqA_dec x a); simpl.
     (* x = a *)
    fold rem.
    rewrite (diff_mult_step_eq M N e).
    rewrite (IHN x).
    omega.
     (* x <> a *)
    fold rem.
    rewrite (diff_mult_step_neq M N n).
    exact (IHN x).
  Qed.

  Definition intersection_mult := inter_as_diff_ok mult diff diff_mult.

  Lemma singleton_mult_in : forall x y, x =A= y -> x / {{y}} = 1.

  Proof.
    intros; compute.
    case (eqA_dec x y); [trivial | contr].
  Qed.

  Lemma singleton_mult_notin : forall x y, ~x =A= y -> x / {{y}} = 0.

  Proof.
    intros; compute.
    case (eqA_dec x y); [contr | trivial].
  Qed.

  Lemma rev_list_ind_type : forall P : Multiset -> Type,
    P nil -> (forall a l, P (rev l) -> P (rev (a :: l))) -> forall l, P (rev l).

  Proof.
    induction l; auto.
  Defined.

  Lemma rev_ind_type : forall P : Multiset -> Type,
    P nil -> (forall x l, P l -> P (l ++ x :: nil)) -> forall l, P l.

  Proof.
    intros.
    gen (rev_involutive l).
    intros E; rewrite <- E.
    apply (rev_list_ind_type P).
    auto.
    simpl in |- *.
    intros.
    apply (X0 a (rev l0)).
    auto.
  Defined.

  Lemma mset_ind_type : forall P : Multiset -> Type,
    P empty -> (forall M a, P M -> P (union M {{a}})) -> forall M, P M.

  Proof.
    induction M as [| x M] using rev_ind_type.
    exact X.
    exact (X0 M x IHM).
  Defined.

End SpecConformation.

  Hint Unfold meq
	      empty
              singleton
              mult
              union
              diff : multisets.

  Hint Resolve mult_eqA_compat
               meq_multeq
               multeq_meq
               empty_mult
               union_mult
               diff_mult
               intersection_mult
               singleton_mult_in
               singleton_mult_notin : multisets.

  Hint Rewrite empty_mult
               union_mult
	       diff_mult
	       intersection_mult using trivial : multisets.

End MultisetList.


Require Import CommonDefinitions.

Require Import Raft.

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

  Definition state_machine_safety_host net :=
    forall h h' e e',
      commit_recorded net h e ->
      commit_recorded net h' e' ->
      eIndex e = eIndex e' ->
      e = e'.

  Definition state_machine_safety_nw net :=
    forall h p t leaderId prevLogIndex prevLogTerm entries leaderCommit e,
      In p (nwPackets net) ->
      pBody p = AppendEntries t leaderId prevLogIndex prevLogTerm
                              entries leaderCommit ->
      t >= currentTerm (nwState net h) ->
      commit_recorded net h e ->
      (prevLogIndex > eIndex e \/
       (prevLogIndex = eIndex e /\ prevLogTerm = eTerm e) \/
       eIndex e > maxIndex entries \/
       In e entries).

  Definition state_machine_safety net :=
    state_machine_safety_host net /\ state_machine_safety_nw net.

  Class state_machine_safety_interface : Prop :=
    {
      state_machine_safety_invariant :
        forall net,
          raft_intermediate_reachable net ->
          state_machine_safety net
    }.

End StateMachineSafety.


Require Import VerifiedVerifier.Machine.
Require Import VerifiedVerifier.Maps.
Require Import Coq.Init.Nat.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListSet.
Require Import VerifiedVerifier.BinaryLattice.
Require Import VerifiedVerifier.AbstractAnalysis.
Require Import VerifiedVerifier.Semantics.
Require Import VerifiedVerifier.Coqlib.
Require Import Lia.

Definition is_heap_base_data (s : state) (i : data_ty) : BinarySet :=
if (Nat.eqb i s.(heap_base)) then bottom else top.

Definition is_heap_bounded_data (s : state) (i : data_ty) : BinarySet :=
if (ltb i (above_heap_guard_size s)) then bottom else top.

Definition is_cf_bounded_data (s : state) (i : data_ty) : BinarySet :=
if (ltb i (List.length (program s).(Funs))) then bottom else top.

Definition is_globals_base_data (s : state) (i : data_ty) : BinarySet :=
if (Nat.eqb i s.(globals_base)) then bottom else top.

Definition is_above_stack_bounded_data (s : state) (i : data_ty) : BinarySet :=
if (Nat.eqb i (above_stack_guard_size s)) then bottom else top.

Definition is_below_stack_bounded_data (s : state) (i : data_ty) : BinarySet :=
if (Nat.eqb i (below_stack_guard_size s)) then bottom else top.

Definition abstractify_data (s : state) (i : data_ty) : info :=
{| is_heap_base := is_heap_base_data s i;
   heap_bounded := is_heap_bounded_data s i;
   cf_bounded := is_cf_bounded_data s i;
   is_globals_base := is_globals_base_data s i;
   above_stack_bounded := is_above_stack_bounded_data s i;
   below_stack_bounded := is_below_stack_bounded_data s i;
|}.

Definition abstractify_list (s : state) (l : list data_ty) : list info :=
  map (abstractify_data s) l.

Definition abstractify_registers (s : state) (f : registers_ty) : abs_registers_ty :=
  fun r => (abstractify_data s (f r)).

Definition abstractify (s : state) : abs_state :=
{| abs_regs := abstractify_registers s s.(regs);
   abs_stack := abstractify_list s s.(stack);
   abs_lifted_state := sub_state;
   abs_heap_base := (heap_base s);
   abs_below_stack_guard_size := (below_stack_guard_size s);
   abs_above_stack_guard_size := (above_stack_guard_size s);
   abs_above_heap_guard_size := (above_heap_guard_size s);
   abs_globals_size := (globals_size s);
   abs_globals_base := (globals_base s);
   abs_program := Some s.(program);
   abs_frame_size := s.(frame_size);
   abs_call_stack := s.(call_stack);
   abs_rsp := get_register s rsp;
   abs_stack_base := s.(stack_base);
   abs_stack_size := s.(stack_size);
   abs_max_stack_size := s.(max_stack_size);
|}.

Lemma BinarySet_eqb_eq: forall a b,
  BinarySet_eqb a b = true <-> a = b.
Proof.
  intros. split.
  - intros. unfold BinarySet_eqb in H. destruct (BinarySet_eq_dec a b) eqn:H'; auto; inversion H.
  - intros. unfold BinarySet_eqb. inversion H. destruct (BinarySet_eq_dec b b); auto; inversion H.
Qed.

Lemma leq_abs_state_is_heap_base: forall abs_st abs_st' r,
  leq_abs_state abs_st' abs_st ->
  is_heap_base (get_register_info abs_st r) = bottom ->
  is_heap_base (get_register_info abs_st' r) = bottom.
Proof.
  intros abs_st abs_st' r Hleq H. inversion Hleq. auto. subst. inversion H. subst.
  specialize H6 with r. inversion H6. rewrite H20. auto.
  subst. inversion H18. auto. rewrite H in H18. inversion H18. auto.
Qed.

Lemma leq_abs_state_is_globals_base: forall abs_st abs_st' r,
  leq_abs_state abs_st' abs_st ->
  is_globals_base (get_register_info abs_st r) = bottom ->
  is_globals_base (get_register_info abs_st' r) = bottom.
Proof.
  intros abs_st abs_st' r Hleq H. inversion Hleq. auto. subst. inversion H. subst.
  specialize H6 with r. inversion H6. rewrite H20. auto.
  subst. inversion H21. auto. rewrite H in H21. inversion H21. auto.
Qed.

Lemma leq_abs_state_heap_bounded: forall abs_st abs_st' r,
  leq_abs_state abs_st' abs_st ->
  heap_bounded (get_register_info abs_st r) = bottom ->
  heap_bounded (get_register_info abs_st' r) = bottom.
Proof.
  intros abs_st abs_st' r Hleq H. inversion Hleq. auto. subst. inversion H. subst.
  specialize H6 with r. inversion H6. rewrite H20. auto.
  subst. inversion H19. auto. rewrite H in H19. inversion H19. auto.
Qed.

Lemma leq_abs_state_cf_bounded: forall abs_st abs_st' r,
  leq_abs_state abs_st' abs_st ->
  cf_bounded (get_register_info abs_st r) = bottom ->
  cf_bounded (get_register_info abs_st' r) = bottom.
Proof.
  intros abs_st abs_st' r Hleq H. inversion Hleq. auto. subst. inversion H. subst.
  specialize H6 with r. inversion H6. rewrite H20. auto.
  subst. inversion H20. auto. rewrite H in H20. inversion H20. auto.
Qed.

Lemma if_thn_true: forall (cond : bool),
  (if cond then bottom else top) = bottom ->
  cond = true.
Proof.
  intros. destruct cond; auto; inversion H.
Qed.

Definition first_block f :=
match (V f) with
| nil => nil
| h :: t => h
end.

Definition run_function p f :=
(first_block f, start_state p).

Lemma leq_abs_state_verifies : forall i abs_st abs_st',
  leq_abs_state abs_st' abs_st ->
  instr_class_verifier i abs_st = true ->
  instr_class_verifier i abs_st' = true.
Proof.
  intros i abs_st abs_st' Hleq Hv. inversion Hleq. auto. rewrite <- H0 in Hv. inversion Hv.
  destruct i eqn:Hi; unfold instr_class_verifier in *; rewrite H0 in Hv; rewrite H; eauto.
  - apply andb_prop in Hv as [Hbase Hv].
    apply andb_prop in Hv as [Hindex Hoffset]. apply BinarySet_eqb_eq in Hbase. apply BinarySet_eqb_eq in Hindex.
    apply BinarySet_eqb_eq in Hoffset. repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)).
    + eapply leq_abs_state_is_heap_base. apply Hleq. auto.
    + eapply leq_abs_state_heap_bounded. apply Hleq. auto.
    + eapply leq_abs_state_heap_bounded. apply Hleq. auto.
  - apply andb_prop in Hv as [Hbase Hv].
    apply andb_prop in Hv as [Hindex Hoffset]. apply BinarySet_eqb_eq in Hbase. apply BinarySet_eqb_eq in Hindex.
    apply BinarySet_eqb_eq in Hoffset. repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)).
    + eapply leq_abs_state_is_heap_base. apply Hleq. auto.
    + eapply leq_abs_state_heap_bounded. apply Hleq. auto.
    + eapply leq_abs_state_heap_bounded. apply Hleq. auto.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv3]. apply PeanoNat.Nat.ltb_lt in Hv3.
    apply andb_prop in Hv1. destruct Hv1 as [Hv1 Hv2].
    apply PeanoNat.Nat.ltb_lt in Hv1. apply PeanoNat.Nat.ltb_lt in Hv2.
    repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)); apply PeanoNat.Nat.ltb_lt.
    + rewrite H2. rewrite H7. assumption.
    + rewrite H12. rewrite H11. assumption.
    + rewrite H11. rewrite H12. rewrite H13. assumption.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv3]. apply PeanoNat.Nat.ltb_lt in Hv3.
    apply andb_prop in Hv1. destruct Hv1 as [Hv1 Hv2].
    apply PeanoNat.Nat.ltb_lt in Hv1. apply PeanoNat.Nat.ltb_lt in Hv2.
    repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)); apply PeanoNat.Nat.ltb_lt.
    + rewrite H7. assumption.
    + rewrite H12. rewrite H11. assumption.
    + rewrite H11. rewrite H12. rewrite H14. assumption.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv2].
    apply BinarySet_eqb_eq in Hv1. apply BinarySet_eqb_eq in Hv2.
    repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)).
    + specialize H5 with r. inversion H5.
      * rewrite H21. assumption.
      * inversion H21; auto.
        rewrite Hv1 in H27. discriminate.
    + specialize H5 with rdi. inversion H5.
      * rewrite H21. assumption.
      * inversion H19; auto.
        rewrite Hv2 in H27. discriminate.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv2]. apply BinarySet_eqb_eq in Hv2.
    repeat (apply andb_true_intro; split; try (apply BinarySet_eqb_eq)).
    + unfold AbstractAnalysis.get_function in *. rewrite H8. assumption.
    + specialize H5 with rdi. inversion H5.
      * rewrite H21. assumption.
      * inversion H19; auto.
        rewrite Hv2 in H27. discriminate.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv2].
    repeat (apply andb_true_intro; split).
    + unfold get_bb. unfold AbstractAnalysis.get_function.
      unfold get_bb in Hv1. unfold AbstractAnalysis.get_function in Hv1.
      rewrite H8. rewrite H10. assumption.
    + unfold get_bb. unfold AbstractAnalysis.get_function.
      unfold get_bb in Hv2. unfold AbstractAnalysis.get_function in Hv2.
      rewrite H8. rewrite H10. assumption.
  - unfold get_bb in *. unfold AbstractAnalysis.get_function in *.
    rewrite H8. rewrite H10. assumption.
  - apply BinarySet_eqb_eq. apply BinarySet_eqb_eq in Hv.
    eapply leq_abs_state_is_heap_base. eapply Hleq. auto.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv2]. apply BinarySet_eqb_eq in Hv1.
    apply PeanoNat.Nat.ltb_lt in Hv2. apply andb_true_intro; split.
    + apply BinarySet_eqb_eq. pose proof leq_abs_state_is_globals_base as Hglobal.
      specialize Hglobal with abs_st abs_st' r.
      apply Hglobal; auto.
    + apply PeanoNat.Nat.ltb_lt. rewrite H15. auto.
  - apply andb_prop in Hv. destruct Hv as [Hv1 Hv2]. apply BinarySet_eqb_eq in Hv1.
    apply PeanoNat.Nat.ltb_lt in Hv2. apply andb_true_intro; split.
    + apply BinarySet_eqb_eq. pose proof leq_abs_state_is_globals_base as Hglobal.
      specialize Hglobal with abs_st abs_st' r.
      apply Hglobal; auto.
    + apply PeanoNat.Nat.ltb_lt. rewrite H15. auto.
Qed.

Lemma unfold_binaryset_eqb: forall b1 b2 b3 b4,
  (BinarySet_eqb b1 b2 && BinarySet_eqb b3 b4)%bool = true ->
  b1 = b2 /\ b3 = b4.
Proof.
  intros. apply andb_prop in H as [H1 H2].
  apply BinarySet_eqb_eq in H1. apply BinarySet_eqb_eq in H2. auto.
Qed.

Lemma unfold_binaryset_eqb_3: forall b1 b2 b3 b4 b5 b6,
  (BinarySet_eqb b1 b2 && BinarySet_eqb b3 b4 && BinarySet_eqb b5 b6)%bool = true ->
  b1 = b2 /\ b3 = b4 /\ b5 = b6.
Proof.
  intros. apply andb_prop in H as [H1 H2]. apply unfold_binaryset_eqb in H1 as [H1 H1'].
  apply BinarySet_eqb_eq in H2. auto.
Qed.

Theorem get_function_concrete_abstract :
  forall s n f,
    Semantics.get_function s n = Some f ->
    AbstractAnalysis.get_function (abstractify s) n = Some f.
Proof.
  intros. unfold AbstractAnalysis.get_function. unfold get_function in H.
  unfold abstractify. unfold abs_program. apply H.
Qed.

Theorem get_function_abstract_concrete :
  forall s n f,
    AbstractAnalysis.get_function (abstractify s) n = Some f ->
    Semantics.get_function s n = Some f.
Proof.
  intros. unfold AbstractAnalysis.get_function in H. unfold get_function.
  unfold abstractify in H. unfold abs_program in H. apply H.
Qed.

Theorem get_bb_abstract_concrete :
  forall s n bb,
    get_bb (abstractify s) n = Some bb ->
    get_basic_block s n = Some bb.
Proof.
  intros. unfold get_basic_block. unfold get_bb in H. unfold abstractify in H.
  unfold abs_call_stack in H. unfold AbstractAnalysis.get_function in H.
  unfold abs_program in H. unfold get_function. apply H.
Qed.

Lemma verified_impl_istep : forall i is st,
  instr_class_verifier i.(instr) (abstractify st) = true ->
  exists is' st', (i :: is) / st i--> is' / st'.
Proof.
  intros. destruct i eqn:Hibase; destruct instr eqn:Hi; unfold instr_class_verifier in H; simpl in H.
  - apply andb_prop in H as [Hbase Hv]. apply andb_prop in Hv as [Hindex Hoffset].
    apply BinarySet_eqb_eq in Hbase. apply BinarySet_eqb_eq in Hindex.
    apply BinarySet_eqb_eq in Hoffset.
    remember ((get_register st r2) + (get_register st r1) + (get_register st r0)) as index.
    remember (ltb index ((heap_base st) + (max_heap_size st))) as valid_index.
    destruct valid_index.
    + apply eq_sym, PeanoNat.Nat.ltb_lt in Heqvalid_index. repeat eexists. eapply I_Heap_Read.
      apply Heqindex. unfold is_heap_base, get_register_info, abstractify in *. simpl in *.
      unfold is_heap_base_data, is_heap_bounded_data in *.
      apply if_thn_true, EqNat.beq_nat_true in Hbase. Search (_ <? _).
      apply if_thn_true, PeanoNat.Nat.ltb_lt in Hindex. apply if_thn_true, PeanoNat.Nat.ltb_lt in Hoffset.
      unfold get_register in *. lia. auto.
    + Search (_ <? _). apply eq_sym, PeanoNat.Nat.ltb_nlt in Heqvalid_index. repeat eexists. eapply I_Heap_Read_Guard.
      apply Heqindex. lia. unfold is_heap_base, get_register_info, abstractify in *. simpl in *.
      unfold is_heap_base_data, is_heap_bounded_data in *.
      apply if_thn_true, EqNat.beq_nat_true in Hbase. Search (_ <? _).
      apply if_thn_true, PeanoNat.Nat.ltb_lt in Hindex. apply if_thn_true, PeanoNat.Nat.ltb_lt in Hoffset.
      unfold get_register in *. pose proof (heap_size_eq_guard st) as H. lia.
  - apply andb_prop in H as [Hbase Hv]. apply andb_prop in Hv as [Hindex Hoffset].
    apply BinarySet_eqb_eq in Hbase. apply BinarySet_eqb_eq in Hindex.
    apply BinarySet_eqb_eq in Hoffset.
    remember ((get_register st r) + (get_register st r0) + (get_register st r1)) as index.
    remember (ltb index ((heap_base st) + (max_heap_size st))) as valid_index.
    destruct valid_index.
    + apply eq_sym, PeanoNat.Nat.ltb_lt in Heqvalid_index. repeat eexists. eapply I_Heap_Write.
      auto. unfold is_heap_base, get_register_info, abstractify in *. simpl in *.
      unfold is_heap_base_data, is_heap_bounded_data in *.
      apply if_thn_true, EqNat.beq_nat_true in Hbase. Search (_ <? _).
      apply if_thn_true, PeanoNat.Nat.ltb_lt in Hindex. apply if_thn_true, PeanoNat.Nat.ltb_lt in Hoffset.
      unfold get_register in *. lia. lia.
    + Search (_ <? _). apply eq_sym, PeanoNat.Nat.ltb_nlt in Heqvalid_index. repeat eexists. eapply I_Heap_Write_Guard.
      auto. lia. unfold is_heap_base, get_register_info, abstractify in *. simpl in *.
      unfold is_heap_base_data, is_heap_bounded_data in *.
      apply if_thn_true, EqNat.beq_nat_true in Hbase. Search (_ <? _).
      apply if_thn_true, PeanoNat.Nat.ltb_lt in Hindex. apply if_thn_true, PeanoNat.Nat.ltb_lt in Hoffset.
      unfold get_register in *. pose proof (heap_size_eq_guard st) as H. lia.
  - repeat eexists. apply I_Heap_Check.
  - destruct (get_register st r <? List.length (program st).(Funs)) eqn:valid_function.
    + repeat eexists. eapply I_Call_Check. apply PeanoNat.Nat.ltb_lt. auto.
    + repeat eexists. eapply I_Call_Check_Bad. apply PeanoNat.Nat.ltb_nlt in valid_function. apply Compare_dec.not_lt. auto.
  - repeat eexists. apply I_Reg_Move.
  - repeat eexists. apply I_Reg_Write.
  - repeat eexists. apply I_Stack_Expand_Static.
  - destruct (n + (stack_size st) <=? (max_stack_size st)) eqn:valid_expansion.
    + repeat eexists. eapply I_Stack_Expand_Dynamic. Search (_ <=? _). apply Compare_dec.leb_complete. auto.
    + repeat eexists. eapply I_Stack_Expand_Dynamic_Guard. apply Compare_dec.leb_complete_conv. auto.
  - repeat eexists. apply I_Stack_Contract.
  - repeat eexists. apply andb_prop in H. destruct H. apply andb_prop in H. destruct H.
    apply PeanoNat.Nat.ltb_lt in H. apply PeanoNat.Nat.ltb_lt in H1. apply PeanoNat.Nat.ltb_lt in H0.
    apply I_Stack_Read; auto.
  - repeat eexists. apply andb_prop in H. destruct H. apply andb_prop in H. destruct H.
    apply PeanoNat.Nat.ltb_lt in H. apply PeanoNat.Nat.ltb_lt in H1. apply PeanoNat.Nat.ltb_lt in H0.
    apply I_Stack_Write; auto.
  - repeat eexists. apply I_Op.
  - apply andb_prop in H as [Hcf Hheap]. apply BinarySet_eqb_eq in Hcf. apply BinarySet_eqb_eq in Hheap.
    unfold is_cf_bounded_data in Hcf. unfold is_heap_base_data in Hheap.
    apply if_thn_true in Hcf. apply if_thn_true in Hheap. apply PeanoNat.Nat.ltb_lt in Hcf.
    pose proof Coqlib.nth_error_lt as Hnth.
    specialize Hnth with ControlFlowGraph (get_register st r) (Funs (program st)).
    unfold get_register in Hnth. apply Hnth in Hcf. destruct Hcf.
    repeat eexists. apply I_Indirect_Call. unfold get_function. apply H.
  - apply andb_prop in H. destruct H.
    destruct (AbstractAnalysis.get_function (abstractify st) n) eqn: Hget.
    pose proof get_function_abstract_concrete as Habs.
    specialize Habs with st n f. apply Habs in Hget.
    repeat eexists. apply I_Direct_Call. apply Hget. inversion H.
  - case (run_conditional st c) eqn:Hcond.
    + apply andb_prop in H. destruct H. destruct (get_bb (abstractify st) l) eqn:Hget1; try inversion H.
      destruct (get_bb (abstractify st) l0) eqn:Hget2; try inversion H0.
      pose proof I_Branch_True. specialize H1 with st is c l l0 b b0 addr.
      repeat eexists. apply H1; auto.
    + apply andb_prop in H. destruct H. destruct (get_bb (abstractify st) l) eqn:Hget1; try inversion H.
      destruct (get_bb (abstractify st) l0) eqn:Hget2; try inversion H0.
      pose proof I_Branch_False. specialize H1 with st is c l l0 b b0 addr.
      repeat eexists. apply H1; auto.
  - destruct (get_bb (abstractify st) l) eqn: Hget; try inversion H.
    pose proof get_bb_abstract_concrete as Habs.
    specialize Habs with st l b. apply Habs in Hget.
    repeat eexists. apply I_Jmp. apply Hget.
  - apply BinarySet_eqb_eq in H. repeat eexists. eapply I_Get_Globals_Base.
    unfold is_heap_base_data in H. destruct (regs st r =? heap_base st) eqn:Hbase.
    + apply EqNat.beq_nat_true in Hbase. auto.
    + discriminate.
  - apply andb_prop in H as [Hbase Hindex]. apply BinarySet_eqb_eq in Hbase.
    apply PeanoNat.Nat.ltb_lt in Hindex. repeat eexists. eapply I_Globals_Read.
    unfold is_globals_base_data in Hbase. destruct (regs st r =? globals_base st) eqn:Hglobal.
    + apply EqNat.beq_nat_true in Hglobal. auto.
    + discriminate.
    + auto.
  - apply andb_prop in H as [Hbase Hindex]. apply BinarySet_eqb_eq in Hbase.
    apply PeanoNat.Nat.ltb_lt in Hindex. repeat eexists. eapply I_Globals_Write.
    unfold is_globals_base_data in Hbase. destruct (regs st r =? globals_base st) eqn:Hglobal.
    + apply EqNat.beq_nat_true in Hglobal. auto.
    + discriminate.
    + auto.
  - repeat eexists. apply I_Ret. apply EqNat.beq_nat_true in H. assumption.
Qed.

Lemma verified_program_impl_verified_function : forall p f,
  program_verifier p (abstractify (start_state p)) = true ->
  In f p.(Funs) ->
  function_verifier f (abstractify (start_state p)) = true.
Proof.
  intros. unfold program_verifier in H. rewrite forallb_forall in H.
  specialize H with f. apply H. apply H0.
Qed.

(* NOTE: This is, in general, a true statement about abstract analyses. It is
   admitted here because we assume the abstract analysis is implemented
   correctly and instead focus on proving facts about whether or not we have
   enough information to guarantee sfi properties. *)
(* TODO: update this to use the verifier fixpoint when we update the verifier
   to associate fixpoints with functions. *)
Theorem verifier_fixpoint_relation :
forall i,
  exists fixpoint,
  forall p f is st fuel,
    program_verifier p (abstractify (start_state p)) = true ->
    In f p.(Funs) ->
    imultistep_fuel ((run_function p f), fuel) (i :: is, st, 0) ->
    (leq_abs_state (abstractify st) fixpoint /\
     instr_class_verifier i.(instr) fixpoint = true).
Admitted.

Theorem verified_program_step :
  forall p f fuel is1 st1,
    program_verifier p (abstractify (start_state p)) = true ->
    In f p.(Funs) ->
    imultistep_fuel ((run_function p f), fuel) (is1, st1, 0) ->
    exists is' st',
      imultistep_fuel ((run_function p f), S fuel) (is', st', 0).
Proof.
  intros.
  unfold run_function. unfold run_function in H1.
  pose proof imultistep_finish' as Hfinish.
  destruct (first_block f) eqn:Hfirst.
  - repeat eexists. constructor. apply IFuel_End.
  - destruct is1 eqn:Hstream.
    + exists nil. exists st1.
      eapply imultistep_finish'. apply H1.
      constructor. apply IFuel_End.
    + pose proof verified_impl_istep as Hstep.
      specialize Hstep with i0 l0 st1.
      pose proof verifier_fixpoint_relation as Hfixpoint.
      specialize Hfixpoint with i0. destruct Hfixpoint as [fixpoint Hfixpoint].
      pose proof leq_abs_state_verifies as Hleq.
      specialize Hleq with i0.(instr) fixpoint (abstractify st1).
      specialize Hfixpoint with p f l0 st1 fuel.
      apply Hfixpoint in H as [].
      apply Hleq in H.
      apply Hstep in H. rewrite <- Hstream in H. destruct H as []. destruct H as [].
      eexists ?[is']. eexists ?[st'].
      specialize Hfinish with fuel (first_block f) (start_state p) is1 st1 ?is' ?st'.
      rewrite <- Hfirst. apply Hfinish. rewrite Hfirst. rewrite Hstream. apply H1.
      constructor. apply IFuel_Step.
      apply H.
      auto. auto. auto.
      unfold run_function. rewrite Hfirst. apply H1.
Qed.

Theorem verified_program :
  forall p f fuel,
    program_verifier p (abstractify (start_state p)) = true ->
    In f p.(Funs) ->
    exists is' st',
      imultistep_fuel ((run_function p f), fuel) (is', st', 0).
Proof.
  intros. induction fuel.
  - repeat eexists. constructor. apply IFuel_Base.
  - destruct IHfuel. destruct H1.
    eapply verified_program_step; auto.
    eapply H1.
Qed.


Require Import VST.floyd.proofauto.
Import ListNotations.
Local Open Scope logic.

Require Import hmacdrbg.HMAC_DRBG_algorithms.
Require Import hmacdrbg.spec_hmac_drbg.
Require Import sha.HMAC256_functional_prog.

Fixpoint HMAC_DRBG_update_round (HMAC: list byte -> list byte -> list byte) (provided_data K V: list byte) (round: nat): (list byte * list byte) :=
  match round with
    | O => (K, V)
    | S round' =>
      let (K, V) := HMAC_DRBG_update_round HMAC provided_data K V round' in
      let K := HMAC (V ++ [Byte.repr (Z.of_nat round')] ++ provided_data) K in
      let V := HMAC V K in
      (K, V)
  end.

Definition HMAC_DRBG_update_concrete (HMAC: list byte -> list byte -> list byte) (provided_data K V: list byte): (list byte * list byte) :=
  let rounds := match provided_data with
                  | [] => 1%nat
                  | _ => 2%nat
                end in
  HMAC_DRBG_update_round HMAC provided_data K V rounds.

Theorem HMAC_DRBG_update_concrete_correct:
  forall HMAC provided_data K V, HMAC_DRBG_update HMAC provided_data K V = HMAC_DRBG_update_concrete HMAC provided_data K V.
Proof.
  intros.
  destruct provided_data; reflexivity.
Qed.

Definition update_rounds (non_empty_additional: bool): Z :=
  if non_empty_additional then 2 else 1.

Lemma HMAC_DRBG_update_round_incremental:
  forall key V initial_state_abs contents n,
    (key, V) = HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) n ->
    (HMAC256 (V ++ Byte.repr (Z.of_nat n) :: contents) key,
     HMAC256 V (HMAC256 (V ++ Byte.repr (Z.of_nat n) :: contents) key)) =
    HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (n + 1).
Proof.
  intros.
  rewrite Nat.add_comm.
  simpl.
  rewrite <- H.
  reflexivity.
Qed.

Lemma HMAC_DRBG_update_round_incremental_Z:
  forall key V initial_state_abs contents i,
    0 <= i ->
    (key, V) = HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (Z.to_nat i) ->
    (HMAC256 (V ++ Byte.repr i :: contents) key,
     HMAC256 V (HMAC256 (V ++ Byte.repr i :: contents) key)) =
    HMAC_DRBG_update_round HMAC256 contents
                           (hmac256drbgabs_key initial_state_abs)
                           (hmac256drbgabs_value initial_state_abs) (Z.to_nat (i + 1)).
Proof.
  intros.
  specialize (HMAC_DRBG_update_round_incremental _ _ _ _ _ H0); intros. clear H0.
  rewrite (Z2Nat.id _ H) in H1.
  rewrite Z2Nat.inj_add; try assumption; lia.
Qed.

Lemma update_char add_len contents (HL:add_len = Zlength contents \/ add_len = 0)
       (key1 V0 : list byte) additional reseed_counter entropy_len prediction_resistance V key0
     reseed_interval
    (H : (key1, V0) =
    HMAC_DRBG_update_round HMAC256 (contents_with_add additional add_len contents) key0 V
      (Z.to_nat
         (if
           (negb (EqDec_val additional nullval) &&
            negb (EqDec_Z add_len 0))%bool
          then 2
          else 1))):
hmac256drbgabs_hmac_drbg_update
  (HMAC256DRBGabs key0 V reseed_counter entropy_len prediction_resistance
     reseed_interval) (contents_with_add additional add_len contents) =
HMAC256DRBGabs key1 V0 reseed_counter entropy_len prediction_resistance
  reseed_interval.
Proof. rename key0 into K. rename V0 into VV. rename key1 into KK.
unfold hmac256drbgabs_hmac_drbg_update, HMAC256_DRBG_functional_prog.HMAC256_DRBG_update.
rewrite HMAC_DRBG_update_concrete_correct. unfold HMAC_DRBG_update_concrete, contents_with_add in *; simpl in *.
destruct (EqDec_val additional nullval); simpl in *.
+ inv H; trivial.
+ destruct (EqDec_Z add_len 0).
  -  subst add_len. change (negb (left eq_refl)) with false in *.
     simpl in H. inv H; trivial.
  - change (negb (right n0)) with true in *. simpl.
    destruct HL; try lia; subst add_len.
    destruct contents. rewrite Zlength_nil in n0; lia.
    change  (Z.to_nat 2) with 2%nat in H.
    rewrite <- H; trivial.
Qed.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section Spec.

  Definition reset_last_run_info_spec (rec: Pointer) (adt: RData) : option RData :=
    rely (peq (base rec) buffer_loc);
    when gidx == (buffer (priv adt)) @ (offset rec);
    let gn := (gs (share adt)) @ gidx in
    rely (ref_accessible gn CPU_ID);
    rely (g_tag (ginfo gn) =? GRANULE_STATE_REC);
    let g' := gn {grec: (grec gn) {g_esr: 0}} in
    Some adt {share: (share adt) {gs: (gs (share adt)) # gidx == g'}}.

End Spec.


Require compcert.cfrontend.ClightBigstep.
Require EventsX.

Import Coqlib.
Import AST.
Import Globalenvs.
Import EventsX.
Import Ctypes.
Import Clight.
Export ClightBigstep.

Require Import ClightX.

Section WITHCONFIG.
Context `{external_calls_prf: ExternalCalls}.

Inductive bigstep_function_terminates' function_entry p i sg vargs (m: mem) t : Values.val * mem -> Prop :=
  | bigstep_function_terminates_intro b f targs tres cc vres m':
      let ge := Clight.globalenv p in
      Genv.find_symbol ge i = Some b ->
      Genv.find_funct_ptr ge b = Some f ->
      type_of_fundef f = Tfunction targs tres cc ->
      sg = signature_of_type targs tres cc ->
      eval_funcall ge function_entry m f vargs t m' vres ->
      bigstep_function_terminates' function_entry p i sg vargs m t (vres,  m').

Definition bigstep_function_terminates2 := bigstep_function_terminates' function_entry2.

Inductive bigstep_function_diverges' function_entry (p: program) i sg vargs m: traceinf -> Prop :=
  | bigstep_function_diverges_intro: forall b f targs tres cc t,
      let ge := globalenv p in
      Genv.find_symbol ge i = Some b ->
      Genv.find_funct_ptr ge b = Some f ->
      type_of_fundef f = Tfunction targs tres cc ->
      sg = signature_of_type targs tres cc ->
      evalinf_funcall ge function_entry m f vargs t ->
      bigstep_function_diverges' function_entry p i sg vargs m t.

Definition bigstep_function_diverges2 := bigstep_function_diverges' function_entry2.

Definition bigstep_function_semantics2 (p: program) i sg vargs m :=
  Smallstep.Bigstep_semantics
    (bigstep_function_terminates2 p i sg vargs m)
    (bigstep_function_diverges2 p i sg vargs m).

Theorem bigstep_function_semantics_sound prog i (sg: AST.signature) (vargs: list Values.val) m:
  Smallstep.bigstep_sound
    (bigstep_function_semantics2 prog i sg vargs m)
    (ClightX.semantics prog i m sg vargs).
Proof.
  constructor; simpl; intros.
(* termination *)
  inv H. econstructor; econstructor.
  split. econstructor; eauto.
  split. eapply eval_funcall_steps. eauto. red; auto.
  econstructor.
(* divergence *)
  inv H. econstructor.
  split. econstructor; eauto.
  eapply Smallstep.forever_N_forever with (order := order).
  red; intros. constructor; intros. red in H. elim H.
  eapply evalinf_funcall_forever; eauto.
Qed.

End WITHCONFIG.