(*

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

  This file is part of Velisarios.

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

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

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

  Authors: Vincent Rahli
           Ivana Vukotic

*)

Require Export 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   (src : Rep)    : pbft_sending_key   := pbft_sending_key_stub.
  Definition pbft_lookup_replica_receiving_key (dst : Rep)    : pbft_receiving_key := pbft_receiving_key_stub.
  Definition pbft_lookup_client_receiving_key  (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
        [MkDSKey (map PBFTreplica reps) (pbft_lookup_replica_sending_key i)]
        (List.app
           (map (fun c => MkDRKey [PBFTclient  c] (pbft_lookup_client_receiving_key  c)) clients)
           (map (fun m => MkDRKey [PBFTreplica m] (pbft_lookup_replica_receiving_key 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) "".

  (* Fix: to finish *)
  Definition tokens2string (toks : Tokens) : string := "-".

  (* 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)".

(* lists *)
Extract Inlined Constant forallb => "List.for_all".
Extract Inlined Constant existsb => "List.exists".
Extract Inlined Constant length  => "List.length".
Extract Inlined Constant app     => "List.append".
Extract Inlined Constant map     => "List.map".
Extract Inlined Constant filter  => "List.filter".

(* 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   => "Nocrypto.Rsa.priv".
Extract Inlined Constant pbft_receiving_key => "Nocrypto.Rsa.pub".
Extract Inlined Constant pbft_lookup_replica_sending_key   => "RsaKeyFun.lookup_replica_sending_key".
Extract Inlined Constant pbft_lookup_replica_receiving_key => "RsaKeyFun.lookup_replica_receiving_key".
Extract Inlined Constant pbft_lookup_client_receiving_key  => "RsaKeyFun.lookup_client_receiving_key".

Extract Inlined Constant pbft_create_signature => "RsaKeyFun.sign_list".
Extract Inlined Constant pbft_verify_signature => "RsaKeyFun.verify_one".
Extract Inlined Constant pbft_token => "Cstruct.t".
Extract Inlined Constant pbft_token_deq => "(=)".
(* === --- === *)

(* == 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 "pbft/PbftReplicaEx.ml" pbft_state2string lrun_sm MonoSimulationState2string PBFTdummySM local_replica.


Require Export DTimeQ.
Require Export MicroBFTheader.
Require Export ComponentSM.
Require Export ComponentSM2.
Require Export toString.

Section MicroBFT.

  Local Open Scope eo.
  Local Open Scope proc.

  Context { dtc : DTimeContext }.

  Context { microbft_context : MicroBFT_context }.
  Context { m_initial_keys   : MicroBFT_initial_keys }.
  Context { u_initial_keys   : USIG_initial_keys }.

  (* ===============================================================
     USIG
     =============================================================== *)

  Record USIG_state :=
    Build_USIG
      {
        usig_id            : MicroBFT_node;
        usig_counter       : nat;
        usig_local_keys    : local_key_map;
      }.

  Record preUI :=
    Build_preUI
      {
        pre_ui_id      : MicroBFT_node;
        pre_ui_counter : nat;
      }.

  Record UI :=
    Build_UI
      {
        ui_pre     :> preUI;
        ui_digest  : MicroBFT_digest;
      }.

  Definition UIs := list UI.

  Definition ui2rep     (ui : UI) : MicroBFT_node := pre_ui_id (ui_pre ui).
  Definition ui2counter (ui : UI) : nat := pre_ui_counter (ui_pre ui).
  Definition ui2digest  (ui : UI) : MicroBFT_digest := ui_digest ui.

  (* ===============================================================
     Bare messages
     =============================================================== *)

  Record Commit :=
    commit
      {
        commit_n  : nat;
        commit_ui : UI
      }.

  Record Accept :=
    accept
      {
        accept_r : nat;
        accept_c : nat;
      }.

  Definition commit2sender (c : Commit) : MicroBFT_node :=
    pre_ui_id (commit_ui c).

  (* ===============================================================
     Bare message type
     =============================================================== *)

  Inductive MicroBFT_Bare_Msg : Set :=
  | MicroBFT_msg_bare_request (n : nat) (pui : preUI).

  (* =========== Msg type =========== *)

  Inductive MicroBFT_msg :=
  | MicroBFT_request (n : nat)
  | MicroBFT_commit  (c : Commit)
  | MicroBFT_accept  (a : Accept).

  Global Instance MicroBFT_I_Msg : Msg := MkMsg MicroBFT_msg.

  Definition MicroBFTmsg2status (m : MicroBFT_msg) : msg_status :=
    match m with
    | MicroBFT_request _ => MSG_STATUS_EXTERNAL
    | MicroBFT_commit  _ => MSG_STATUS_PROTOCOL
    | MicroBFT_accept  _ => MSG_STATUS_INTERNAL
    end.

  Global Instance MicroBFT_I_MsgStatus : MsgStatus := MkMsgStatus MicroBFTmsg2status.

  (* back to the definition of usig *)

  Record HashData :=
    Build_HashData
      {
        hd_msg : nat;
        hd_pre : preUI;
      }.

  (* hash of the whole usig *)
  Class USIG_hash :=
    MkMicroBFThash
      {
        create_hash_usig  : HashData -> local_key_map -> MicroBFT_digest;
        verify_hash_usig  : HashData -> MicroBFT_digest -> local_key_map -> bool;
        verify_create_hash_usig :
          forall (hd : HashData) (keys : local_key_map),
            verify_hash_usig hd (create_hash_usig hd keys) keys = true;
      }.
  Context { usig_hash : USIG_hash }.
  Hint Rewrite verify_create_hash_usig : microbft.

  Definition USIG_initial (r : MicroBFT_node) : USIG_state :=
    Build_USIG
      r
      0
      (usig_initial_keys r).

  Definition getReplicaId (u : USIG_state) : MicroBFT_node := usig_id u.

  Definition increment_USIG (u : USIG_state) : USIG_state :=
    Build_USIG
      (usig_id         u)
      (S               (usig_counter u))
      (usig_local_keys u).

  (* 1st USIG counter will be [1] *)
  Definition create_UI (msg : nat) (u : USIG_state) : USIG_state * UI :=
    (* increment current counter of the usig *)
    let u' := increment_USIG u in
    (* creates the data to hash *)
    let pre := Build_preUI (usig_id u') (usig_counter u') in
    let hd := Build_HashData msg pre in
    (* hashes the data *)
    let d  := create_hash_usig hd (usig_local_keys u') in
    (* builds UI *)
    let ui := Build_UI pre d in
    (u', ui).

  Definition verify_UI (msg : nat) (ui : UI) (u : USIG_state) : bool :=
    (* creates the data to hash *)
    let hd  := Build_HashData msg (ui_pre ui) in
    (* the keys are supposed to be the receiving keys for [ui_id ui] *)
    verify_hash_usig hd (ui2digest ui) (usig_local_keys u).

  Inductive USIG_input_interface :=
  | create_ui_in (msg   : nat)
  | verify_ui_in (msgui : nat * UI).

  Inductive USIG_output_interface :=
  | create_ui_out (ui : UI)
  | verify_ui_out (b  : bool)
  (* default output *)
  | verify_ui_out_def.

  Definition CIOusig : ComponentIO :=
    MkComponentIO USIG_input_interface USIG_output_interface verify_ui_out_def.

  (* ===============================================================
     Crypto
     =============================================================== *)

  Global Instance MicroBFT_I_Data : Data := MkData MicroBFT_Bare_Msg.

  Class MicroBFT_auth :=
    MkMicroBFT_auth
      {
        MicroBFT_create : data -> sending_keys -> list MicroBFT_digest;
        MicroBFT_verify : data -> name -> receiving_key -> MicroBFT_digest -> bool
      }.

  Context { microbft_auth : MicroBFT_auth }.

  Global Instance MicroBFT_I_AuthFun : AuthFun :=
    MkAuthFun
      MicroBFT_create
      MicroBFT_verify.

  (* ===============================================================
        Authenticated Messages
        =============================================================== *)

  (* we are here extracting the sender of the message *)
  Definition MicroBFT_msg_auth (m : msg) : option  name :=
    match m with
    | MicroBFT_request _ => None
    | MicroBFT_commit  c => Some (commit2sender c)
    | MicroBFT_accept  a => None
    end.

  (* FIX : Why do we need n here? *)
  Definition MicroBFT_data_auth (n : name) (d : data) : option name :=
    match d with
    | MicroBFT_msg_bare_request n pui => Some (pre_ui_id pui)
    end.

  Global Instance MicroBFT_I_DataAuth : DataAuth := MkDataAuth MicroBFT_data_auth.

  Definition commit2auth_data (c : Commit) : AuthenticatedData :=
    match c with
    | commit n ui => MkAuthData (MicroBFT_msg_bare_request n ui) [ui_digest ui]
    end.

  Definition MicroBFT_get_contained_auth_data (m : msg) : list AuthenticatedData :=
    match m with
    | MicroBFT_request _ => []
    | MicroBFT_commit  c => [commit2auth_data c]
    | MicroBFT_accept  a => []
    end.

  Global Instance MicroBFT_I_ContainedAuthData : ContainedAuthData :=
    MkContainedAuthData MicroBFT_get_contained_auth_data.

  (* ===============================================================
     Decidability for different types of messages
     =============================================================== *)

  Definition UI_dec : Deq UI.
  Proof.
    introv.
    destruct x as [p1 d1], y as [p2 d2], p1 as [i1 c1], p2 as [i2 c2].
    destruct (MicroBFT_nodeDeq i1 i2); subst; prove_dec.
    destruct (deq_nat c1 c2); subst; prove_dec.
    destruct (MicroBFT_digestdeq d1 d2); subst; prove_dec.
  Defined.

  (****************************************************************************)

  Definition broadcast2others F : DirectedMsg :=
    F [MicroBFT_backup1, MicroBFT_backup2].

  (* ===============================================================
     Sending functions
     =============================================================== *)

  Definition send_commit (c : Commit) (n : list name) : DirectedMsg :=
    MkDMsg (MicroBFT_commit c) n ('0).

  Definition send_accept (a : Accept) (n : list name) : DirectedMsg :=
    MkDMsg (MicroBFT_accept a) n ('0).

  (* ===============================================================
     Log
     =============================================================== *)

  Definition LOG_state := list Commit.

  Definition LOG_initial : LOG_state := [].

  Inductive LOG_input_interface :=
  | log_new (c : Commit).

  Inductive LOG_output_interface :=
  | log_out (b : bool).

  Definition CIOlog : ComponentIO :=
    MkComponentIO LOG_input_interface LOG_output_interface (log_out true).

  (* ===============================================================
     State of some replica
     =============================================================== *)

  Definition update_highest_received_counter_value (ui : UI) (n : nat) : nat :=
    if n <? ui2counter ui
    then ui2counter ui
    else n.

  Record MAIN_state :=
    Build_State
      {

        (* state of the local state machine *)
        sm_state : nat;

        (* the highest sequence number received from the primary *)
        prim     : nat;

      }.

  Definition initial_state : MAIN_state :=
    Build_State 0 0.

  Definition update_sm_state
             (s : MAIN_state)
             (x : nat) : MAIN_state :=
    Build_State (sm_state s + x) (prim s).

  Global Instance MicroBFT_I_baseFunIO : baseFunIO :=
    MkBaseFunIO (fun nm =>
                   if CompNameKindDeq (comp_name_kind nm) "USIG" then CIOusig
                   else if CompNameKindDeq (comp_name_kind nm) "LOG" then CIOlog
                        else CIOdef).

  Definition preUSIGname : PreCompName := MkPreCompName "USIG" 0.
  Definition USIGname : CompName := MkCN "USIG" 0 true.

  Global Instance MicroBFT_I_baseStateFun : baseStateFun :=
    MkBaseStateFun (fun nm =>
                      if CompNameKindDeq (comp_name_kind nm) "USIG" then USIG_state
                      else if CompNameKindDeq (comp_name_kind nm) "LOG" then LOG_state
                           else if CompNameKindDeq (comp_name_kind nm) msg_comp_name_kind
                                then MAIN_state
                                else unit).

  Global Instance MicroBFT_I_IOTrustedFun : IOTrustedFun :=
    MkIOTrustedFun
      (fun _ =>
         MkIOTrusted
           USIG_input_interface
           USIG_output_interface
           verify_ui_out_def).

  Global Instance MicroBFT_I_trustedStateFun : trustedStateFun :=
    MkTrustedStateFun (fun _ => USIG_state).

  Definition USIG_update : M_Update 0 USIGname _ :=
    fun (s : USIG_state) (m : USIG_input_interface) =>
      interp_s_proc
        (match m with
         | create_ui_in r =>
           let (s', ui) := create_UI r s in
           [R] (s', create_ui_out ui)
         | verify_ui_in (r,ui) =>
           let b := verify_UI r ui s in
           [R] (s, verify_ui_out b)
         end).

  Definition USIG_comp (n : MicroBFT_node) : M_StateMachine 1 USIGname :=
    build_m_sm USIG_update (USIG_initial n).

  Definition LOGname : CompName := MkCN "LOG" 0 false.

  Definition LOG_update : M_Update 0 LOGname _ :=
    fun (l : LOG_state) (m : LOG_input_interface) =>
      interp_s_proc
        (match m with
         | log_new r =>
           let l' := r :: l in
           [R] (l', log_out true)
         end).

  Definition LOG_comp : M_StateMachine 1 LOGname :=
    build_m_sm LOG_update LOG_initial.

  (******************************************************************************)

  Definition on_create_ui_out {A} (f : UI -> A) (d : unit -> A) (out : USIG_output_interface) : A :=
    match out with
    | create_ui_out ui => f ui
    | _ => d tt
    end.

  Definition call_create_ui {A} (m : nat) (d : unit -> Proc A) (f : UI -> Proc A) :=
    (USIGname [C] (create_ui_in m))
      [>>=] on_create_ui_out f d.

  Notation "a >>cui>>=( d ) f" := (call_create_ui a d f) (at level 80, right associativity).

  Definition if_true_verify_ui_out {A} (f d : unit -> A) (out : USIG_output_interface) : A :=
    match out with
    | verify_ui_out b => if b then f tt else d tt
    | _ => d tt
    end.

  Definition call_verify_ui {A} (mui : nat * UI) (d f : unit -> Proc A) :=
    (USIGname [C] (verify_ui_in mui))
      [>>=] if_true_verify_ui_out f d.

  Notation " a >>vui>>=( d ) f" := (call_verify_ui a d f) (at level 80, right associativity).

  Definition on_data_message {A} (m : MicroBFT_msg) (d : unit -> Proc A) (f : nat -> Proc A) : Proc A :=
    match m with
    | MicroBFT_request m => f m
    | _ => d tt
    end.

  Notation "a >>odm>>=( d ) f" := (on_data_message a d f) (at level 80, right associativity).

  Definition on_commit {A} (m : MicroBFT_msg) (d : unit -> Proc A) (f : Commit -> Proc A) : Proc A :=
    match m with
    | MicroBFT_commit c => f c
    | _ => d tt
    end.

  Notation "a >>oc>>=( d ) f" := (on_commit a d f) (at level 80, right associativity).

  Definition MAINname := msg_comp_name 0.

  Definition received_prior_counter (ui : UI) (s : MAIN_state) : bool :=
    match ui2counter ui with
    | 0 => false (* 0 is not a valid counter *)
    | 1 => true (* 1st counter *)
    | S n => if deq_nat n (prim s) then true else false
    end.

  Definition is_primary (n : MicroBFT_node) : bool :=
    if MicroBFT_nodeDeq n MicroBFT_primary then true else false.

  Definition not_primary (n : MicroBFT_node) : bool :=
    negb (is_primary n).

  Definition valid_commit
             (slf : MicroBFT_node)
             (c   : Commit)
             (s   : MAIN_state) : bool :=
    is_primary (commit2sender c)
      && not_primary slf
      && received_prior_counter (commit_ui c) s.

  Definition invalid_commit
             (slf : MicroBFT_node)
             (c   : Commit)
             (s   : MAIN_state) : bool :=
    negb (valid_commit slf c s).

  Definition update_highest_received_counter (ui : UI) (s : MAIN_state) : MAIN_state :=
    Build_State
      (sm_state          s)
      (update_highest_received_counter_value ui (prim s)).

  Definition handle_request (slf : MicroBFT_node) : UProc MAINname _ :=
    (* in case M_Update 0 _ := is output type it complains that "The term "m" has type "cio_I" while it is expected to have type "data_message"." *)
    fun state m =>
      if not_primary slf then [R] (state, []) else

      m >>odm>>=(fun _ => [R] (state,[])) fun m =>

      let state1 := update_sm_state state m in
      let m' := sm_state state1 in

      (* create_UI and update of the current state *)
      m' >>cui>>=(fun _ => [R](state1, [])) fun ui =>

      (* create request *)
      let c := commit m' ui in

      (* we log this request *)
      (LOGname [C] (log_new c)) [>>=] fun _ =>

      (* we broadcast the request message to all replicas *)
      [R] (state1, [broadcast2others (send_commit c)]).

  Definition handle_commit (slf : MicroBFT_node) : UProc MAINname _ :=
    fun state m =>
      m >>oc>>=(fun _ => [R] (state,[])) fun c =>
      if invalid_commit slf c state then [R] (state, []) else

      (* we check whether the ui is created by some usig *)
      let n  := commit_n c in
      let ui := commit_ui c in
      (n,ui) >>vui>>=(fun _ => [R] (state, [])) fun _ =>

      let state1 := update_highest_received_counter (commit_ui c) state in

      (* we log this request *)
      (LOGname [C] (log_new c)) [>>=] fun _ =>

      (* we broadcast the commit message to all replicas *)
      let acc := accept n (ui2counter ui) in
      [R] (state1, [send_accept acc [slf]]).

  Definition handle_accept (slf : MicroBFT_node) : UProc MAINname _ :=
    fun (state : MAIN_state) m => [R](state,[]).

  Definition MAIN_update (slf : MicroBFT_node) : M_Update 1 MAINname _ :=
    fun (s : MAIN_state) m =>
      interp_s_proc
        (match m with
         | MicroBFT_request _ => handle_request slf s m
         | MicroBFT_commit  _ => handle_commit  slf s m
         | MicroBFT_accept  _ => handle_accept  slf s m
         end).

  Definition MAIN_comp (slf : MicroBFT_node) : n_proc 2 MAINname :=
    build_m_sm (MAIN_update slf) initial_state.

  (*Definition MicroBFT_nstate (n : name) :=
    match n with
    | MicroBFT_replica _ => MAIN_state
    | _ => unit
    end.*)

  Definition MicroBFTsubs (n : MicroBFT_node) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname LOG_comp
    ].

  Definition MicroBFTsubs_new (s1 : USIG_state) (s2 : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update s1),
      MkPProc LOGname  (build_m_sm LOG_update s2)
    ].

  Definition MicroBFTsubs_new_u (u : USIG_state) : n_procs _ :=
    [
      MkPProc USIGname (build_m_sm USIG_update u),
      MkPProc LOGname  LOG_comp
    ].

  Definition MicroBFTsubs_new_l n (l : LOG_state) : n_procs _ :=
    [
      MkPProc USIGname (USIG_comp n),
      MkPProc LOGname  (build_m_sm LOG_update l)
    ].

  Definition MicroBFT_replicaSM_new (r : MicroBFT_node) (s : MAIN_state) : n_proc 2 MAINname :=
    build_m_sm (MAIN_update r) s.

  Notation MicroBFTls := (LocalSystem 2 0).

  Definition MicroBFTlocalSys (slf : MicroBFT_node) : MicroBFTls :=
    MkPProc _ (MAIN_comp slf) :: incr_n_procs (MicroBFTsubs slf).

  Definition MicroBFTlocalSys_new
             (n  : MicroBFT_node)
             (s  : MAIN_state)
             (s1 : USIG_state)
             (s2 : LOG_state) : MicroBFTls :=
    MkPProc _ (MicroBFT_replicaSM_new n s) :: incr_n_procs (MicroBFTsubs_new s1 s2).

  Definition MicroBFTfunLevelSpace :=
    MkFunLevelSpace
      (fun n => 2)
      (fun n => 0).

  Definition MicroBFTsys : M_USystem MicroBFTfunLevelSpace (*name -> M_StateMachine 2 msg_comp_name*) :=
    MicroBFTlocalSys.

  Lemma eq_cons :
    forall {T} (x1 x2 : T) l1 l2,
      x1 :: l1 = x2 :: l2 -> x1 = x2 /\ l1 = l2.
  Proof.
    introv h; inversion h; auto.
  Qed.

  Lemma MicroBFTsubs_new_inj :
    forall a b c d,
      MicroBFTsubs_new a b = MicroBFTsubs_new c d
      -> a = c /\ b = d.
  Proof.
    introv h.
    repeat (apply eq_cons in h; repnd); GC.
    apply decomp_p_nproc in h0.
    apply decomp_p_nproc in h1.
    inversion h0; inversion h1; subst; simpl in *; auto.
  Qed.

  Lemma MicroBFTlocalSys_new_inj :
    forall a1 a2 b1 b2 c1 c2 d1 d2,
      MicroBFTlocalSys_new a1 b1 c1 d1 = MicroBFTlocalSys_new a2 b2 c2 d2
      -> b1 = b2 /\ c1 = c2 /\ d1 = d2.
  Proof.
    introv h.
    apply eq_cons in h; repnd.
    apply decomp_p_nproc in h0.
    inversion h0; subst.
    apply incr_n_procs_inj in h.
    apply MicroBFTsubs_new_inj in h; repnd; subst; tcsp.
  Qed.

  Lemma MicroBFTlocalSys_as_new :
    forall (r  : MicroBFT_node),
      MicroBFTlocalSys r
      = MicroBFTlocalSys_new
          r
          initial_state
          (USIG_initial r)
          LOG_initial.
  Proof.
    introv; eauto.
  Qed.

  Definition USIGlocalSys (s : USIG_state) : LocalSystem 1 0 :=
    [MkPProc _ (build_m_sm USIG_update s)].

  Definition LOGlocalSys (s : LOG_state) : LocalSystem 1 0 :=
    [MkPProc _ (build_m_sm LOG_update s)].

End MicroBFT.

Hint Rewrite @verify_create_hash_usig : microbft.

Notation MicroBFTls := (LocalSystem 2 0).


Require Import Lia.
Require Import Relations.
Require Import Logic.FunctionalExtensionality.
Require Import Lists.List.
Import ListNotations.
Require Import String.
Require Import Cop.Copland.
Import Copland.Term.
Require Import Utils.Utilities.

Module Manifest.

(** ****************************
  * FORMALIZATION OF ATTESTATION PROTOCOL NEGOTIATION
  By: Anna Fritz and
      Dr. Perry Alexander
  Date: January 6th, 2023
************************************)

(** * Manifests
    [Manifest] defines a single attestation manger and its interconnections.
    Information includes:
  asps:  a list of ASPs (measurement operations the AM can preform),
  M : can measure relation (other AMs the current AM knows of),
  C : context relation (other AMs the current AM depends on),
  Policy : local policy specific to the current AM.
           Minimally includes privacy policy and may possibly include selection policy
  Other information not necessary for reasoning includes:
  [key] simulates public key
  [address] simulates address information and
  [tpm] simulates cruft necessary to initialize its TPM
*)
Record Manifest := {

   asps : list ASP ;
   K : list Plc ;
   C : list Plc ;
   Policy : ASP -> Plc -> Prop ;

(*
   ; key : string
   ; address : nat
   ; tpm_init : nat
*)
 }.

(** [Environment] is a set of AM's each defined by a [Manifest].
  The domain of an [Environment] provides names for each [Manifest].
  Names should be the hash of their public key, but this restriction
  is not enforced here.
*)

Definition Environment : Type :=  Plc -> (option Manifest).

Definition e_empty : Environment := (fun _ => None).

Definition e_update (m : Environment) (x : Plc) (v : (option Manifest)) :=
  fun x' => if plc_dec x x' then v else m x'.

Theorem e_update_reduce: forall m x v y, x<>y -> (e_update m x v) y = m y.
Proof.
  intros m x v y H; unfold e_update.
  destruct (plc_dec x y).
  + contradiction.
  + auto.
Qed.

(** A [System] is all attestation managers in the enviornement *)

Definition System := list Environment.

(** ****************************
  * REASONING ABOUT MANIFESTS
*****************************)

(** Within the enviornment [e], does the AM at place [k] have ASP [a]? *)

Definition hasASPe(k:Plc)(e:Environment)(a:ASP):Prop :=
match (e k) with
| None => False
| Some m => In a m.(asps)
end.

(** Within the system [s], does the AM located at place [k] have ASP [a]? *)

Fixpoint hasASPs(k:Plc)(s:System)(a:ASP):Prop :=
    match s with
    | [] => False
    | s1 :: s2 => (hasASPe k s1 a) \/ (hasASPs k s2 a)
    end.

(** Proof that hasASPe is decidable. This means, for any enviornment [e]
   either the ASP [a] is present or it's not. *)

Theorem hasASPe_dec: forall k e a, {hasASPe k e a}+{~hasASPe k e a}.
Proof.
  intros k e a.
  unfold hasASPe.
  destruct (e k).
  + induction (asps m).
  ++ auto.
  ++ inverts IHl.
  +++ simpl. left. right. apply H.
  +++ simpl. assert (asp_dec : {a = a0} + {a<>a0}).
           { repeat decide equality. }
      inverts asp_dec.
  ++++ left. auto.
  ++++ right. unfold not. intros. inverts H1; auto.
  + auto.
Defined.

(** prove hasASPs is decidable. This means, for any system [s]
   either the ASP [a] is present or it's not. *)

Theorem hasASPs_dec: forall k e a, {hasASPs k e a}+{~hasASPs k e a}.
Proof.
  intros k e a.
  induction e.
  + simpl in *. right. unfold not. intros. apply H.
  + simpl in *. pose proof hasASPe_dec k a0 a. inverts H.
  ++ left. left. apply H0.
  ++ inverts IHe.
  +++ left. right. apply H.
  +++ right. unfold not. intros. inverts H1; auto.
Defined.

(** Determine if manifest [k] from [e] knows how to
   communicate from [k] to [p]
*)

Definition knowsOfe(k:Plc)(e:Environment)(p:Plc):Prop :=
match (e k) with
| None => False
| Some m => In p m.(K)
end.

Print System.
Print Environment.

(** Determine if place [k] within the system [s] knows of [p] *)

Fixpoint knowsOfs(k:Plc)(s:System)(p:Plc):Prop :=
match s with
| [] => False
| s1 :: ss => (knowsOfe k s1 p) \/ (knowsOfs k ss p)
end.
(* need this second k to change.... *)

(** Prove knowsOfe is decidable. This means, for any enviornment [e]
   either the current place [p] is aware of place [p] or it's not.  *)

Theorem knowsOfe_dec:forall k e p, {(knowsOfe k e p)}+{~(knowsOfe k e p)}.
Proof.
  intros k e p.
  unfold knowsOfe.
  destruct (e k); auto.
  + induction (K m).
  ++ auto.
  ++ assert (H: {p = a} + {p <> a}). {repeat decide equality. }
     inversion H.
  +++ simpl. left. auto.
  +++ simpl. inverts IHl; auto. right. unfold not. intros. inverts H2; auto.
Defined.

(** decidability of knowsOfs. For any system [s], either [k] knows
   of [p] within the system or they do not. *)

Theorem knowsOfs_dec:forall k s p, {(knowsOfs k s p)}+{~(knowsOfs k s p)}.
Proof.
    intros k s p.
    induction s; simpl in *.
    + right. unfold not. intros. inversion H.
    + pose proof knowsOfe_dec k a p. inverts H.
    ++ left. left. apply H0.
    ++ inverts IHs.
    +++ left. right. apply H.
    +++ right. unfold not. intros. inversion H1; auto.
Defined.

(** Determine if place [k] within the environment [e]
    depends on place [p] (the context relation) *)
Definition dependsOne (k:Plc)(e:Environment)(p:Plc):Prop :=
match (e k) with
| None => False
| Some m => In p m.(C)
end.

(** Determine if place [k] within the system [s] depends on place [p] (the context relation) *)

Fixpoint dependsOns (k:Plc)(s:System)(p:Plc):Prop :=
match s with
| [] => False
| s1 :: ss => (dependsOne k s1 p) \/ (dependsOns k ss p)
end.

(** decidability of dependsOne. For any enviornment [e], either the AM at place
   [k] depends on something at place [p] or it does not. *)

Theorem dependsOne_dec : forall k e p, {(dependsOne k e p)}+{~(dependsOne k e p)}.
Proof.
  intros k e p.
  unfold dependsOne.
  destruct (e k).
  +  induction (C m).
  ++ auto.
  ++ simpl. inversion IHl.
  +++  auto.
  +++ assert (H': {a = p } + { a <> p}). {repeat decide equality. } inversion H'.
  ++++ left. left. apply H0.
  ++++ right. unfold not. intros. inversion H1; auto.
  + auto.
Defined.

(** decidability of dependsOns. For any system [s], either the AM at place [k] depends on something at place [p] or it does not. *)

Theorem dependsOns_dec : forall k s p, {dependsOns k s p} + {~ dependsOns k s p}.
Proof.
  intros. induction s.
  + simpl. auto.
  + simpl. pose proof dependsOne_dec k a p. inversion IHs.
  ++ left. right. apply H0.
  ++ inversion H.
  +++ left. left. apply H1.
  +++ right. unfold not. intros. inversion H2; auto.
Defined.

(** ***************************
    * EXECUTABILITY
*****************************)

(** Is term [t] exectuable on the attestation manager named [k] in
    environment [e]?  Are ASPs available at the right attesation managers
    and are necessary communications allowed? *)

Fixpoint executable(t:Term)(k:Plc)(e:Environment):Prop :=
match t with
| asp a  => hasASPe k e a
| att p t => knowsOfe k e p -> executable t p e
| lseq t1 t2 => executable t1 k e /\ executable t2 k e
| bseq _ t1 t2 => executable t1 k e /\ executable t2 k e
| bpar _ t1 t2 => executable t1 k e /\ executable t2 k e
end.

(* Ltac right_dest_contr H := right; unfold not; intros H; destruct H; contradiction.
Ltac right_dest_inverts := right; unfold not; intros H; inverts H. *)

(** executability of a term is decidable *)

Theorem executable_dec:forall t k e,{(executable t k e)}+{~(executable t k e)}.
intros.  generalize k. induction t; intros.
+ unfold executable. apply hasASPe_dec.
+ simpl. pose proof knowsOfe_dec k0 e p. destruct H.
++ destruct (IHt p).
+++ left; auto.
+++ right. unfold not. intros; auto.
++ destruct (IHt p).
+++ left; auto.
+++ left. intros. congruence.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0.
  destruct IHt1,IHt2; try right_dest_contr H.
++ left. split ; assumption.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0. destruct IHt1,IHt2; try right_dest_contr H.
++ left. split ; assumption.
+ simpl. specialize IHt1 with k0. specialize IHt2 with k0. destruct IHt1,IHt2; try right_dest_contr H.
++  left. split ; assumption.
Defined.

(** Is term [t] executable on the attestation mnanager named [k] in
  system [s]?  Are ASPs available at the right attestation managers
  and are necessary communications allowed? *)
Fixpoint executables(t:Term)(k:Plc)(s:System):Prop :=
  match t with
  | asp a  => hasASPs k s a
  | att p t => knowsOfs k s p -> executables t p s
  | lseq t1 t2 => executables t1 k s /\ executables t2 k s
  | bseq _ t1 t2 => executables t1 k s /\ executables t2 k s
  | bpar _ t1 t2 => executables t1 k s /\ executables t2 k s
end.

Ltac prove_exec :=
    match goal with
    | |- {executables (asp _) _ _} + {_} => unfold executables; apply hasASPs_dec
    | IHt1 : _ , IHt2 : _ |- {executables _ ?k ?s} + {_} => simpl; specialize IHt1 with k s; specialize IHt2 with k s; destruct IHt1,IHt2 ; try( left; split ; assumption)
    end.

Theorem executables_dec : forall t k s, {executables t k s} + {~executables t k s}.
Proof.
intros.  generalize k s. induction t; intros; try prove_exec; try right_dest_contr H.
+ simpl. destruct (IHt p s0).
++ auto.
++ pose proof knowsOfs_dec k0 s0 p. destruct H.
+++ right. unfold not; intros. intuition.
+++ left. intros. congruence.
Defined.

(******************************
*        POLICY
*******************************)

(** Check environment [e] and see if place [p] has some policy
 *  where the Policy allows p to run a. *)
Definition checkASPPolicy(p:Plc)(e:Environment)(a:ASP):Prop :=
match (e p) with (* Look for p in the environment *)
| None => False
| Some m => (Policy m a p) (* Policy from m allows p to run a *)
end.

(** Recursive policy check. *)
Fixpoint checkTermPolicy(t:Term)(k:Plc)(e:Environment):Prop :=
  match t with
  | asp a  => checkASPPolicy k e a
  | att r t0 => checkTermPolicy t0 k e
  | lseq t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  | bseq _ t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  | bpar _ t1 t2 => checkTermPolicy t1 k e /\ checkTermPolicy t2 k e
  end.

(** Proving policy check is decidable.
  * This is true if ASP policy is decidable. *)
Theorem checkTermPolicy_dec:forall t k e,
    (forall p0 a0, {(checkASPPolicy p0 e a0)} + {~(checkASPPolicy p0 e a0)}) ->
    {(checkTermPolicy t k e)}+{~(checkTermPolicy t k e)}.
Proof.
  intros t k e.
  intros H.
  induction t.
  + simpl. apply H.
  + simpl. assumption.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  + simpl; destruct IHt1,IHt2.
  ++ left. split; assumption.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
  ++ right_dest_contr H'.
Defined.

(** ***************************
 * SOUND
 *****************************)

(** Soundness is executability and policy adherence *)

Definition sound (t:Term)(k:Plc)(e:Environment) :=
  (executable t k e) /\ (checkTermPolicy t k e).

(** Prove soundness is decidable with the assumption necessary for policy
 * adherence decidability.
 *)

 Theorem sound_dec: forall t p e,
 (forall p0 a0, {(checkASPPolicy p0 e a0)} + {~(checkASPPolicy p0 e a0)})
 -> {sound t p e}+{~(sound t p e)}.
Proof.
  intros t p e.
  intros H.
  unfold sound.
  assert ({executable t p e}+{~(executable t p e)}). apply executable_dec.
  assert ({checkTermPolicy t p e}+{~(checkTermPolicy t p e)}). { apply checkTermPolicy_dec. intros. apply H. }
  destruct H0,H1.
  + left. split; assumption.
  + right_dest_contr H'.
  + right_dest_contr H'.
  + right_dest_contr H'.
Defined.

(** ***************************
 * EXAMPLE SYSTEM
 *****************************)

(** Motivated by the Flexible Mechanisms for Remote Attestation,
 * we have three present parties in this attestation scheme.
 * These are used for example purposes.
 *)

Notation P0 := "P0"%string.
Notation P1 := "P1"%string.
Notation P2 := "P2"%string.

(** Introducing three asps for testing purposes. *)
Notation aVC :=
  (ASPC ALL EXTD (asp_paramsC "aVC"%string ["x"%string] P1 P1)).
Notation aHSH :=
  (ASPC ALL EXTD (asp_paramsC "aHSH"%string ["x"%string] P1 P1)).
Notation aSFS :=
  (ASPC ALL EXTD (asp_paramsC "aSFS"%string ["x"%string] P2 P2)).

(** Below are relational definitions of Policy. Within the definition, we
 * list each ASP on the AM and state who can recieve a measurement of said
 * ASP (ie doesn't expose sensitive information in the context).
 *
 * The relying party (P0) has no measurement to write policy over.
 * P1 can share the measurement aHSH and aVC with P0
 * P2 can share a measurement using aSFS with P1
*)

Inductive tar_Policy : ASP -> Plc -> Prop :=
| p_aHSH : tar_Policy aHSH P2
| p_SIG : forall p, tar_Policy SIG p.

Inductive P0_Policy : ASP -> Plc -> Prop :=.

Inductive P1_Policy : ASP -> Plc -> Prop :=
| aVC_p: P1_Policy aVC P0
| aHSH_p: P1_Policy aHSH P0.

Inductive P2_Policy : ASP -> Plc -> Prop :=
| aSFS_pL: P2_Policy aSFS P1.

Global Hint Constructors P0_Policy : core.
Global Hint Constructors P1_Policy : core.
Global Hint Constructors P2_Policy : core.

(** Definition of environments for use in examples and proofs.
 * Note there are 3 communicating peer's present...
 * P0, P1, and P2.
 *)

Definition e0 := e_empty.
Definition e_P0 :=
    e_update e_empty P0 (Some {| asps := []; K:= [P1] ; C := [] ; Policy := P0_Policy |}).
Definition e_P1 :=
    e_update e_P0 P1 (Some {| asps := [aVC;  aHSH]; K:= [P2] ; C := [] ; Policy := P1_Policy|}).
Definition e_P2 :=
    e_update e_P1 P2 (Some {| asps := [aSFS] ; K:= [] ; C := [P1] ; Policy := P2_Policy |}).

(** In our example, the system includes the relying party, the target,
 * and the appraiser
 *)

Definition example_sys_1 := [e_P0; e_P1; e_P2].

(** ***************************
  * EXAMPLE SYSTEM PROPERTIES
  *****************************)

(** Prove the P0 knows of P1 in P0's enviornment *)

Example ex1: knowsOfe P0 e_P0 P1.
Proof. unfold knowsOfe. simpl. left. reflexivity. Qed.

(** relying party does not have the ASP aVC *)

Example ex2: hasASPe P0 e_P0 aVC -> False.
Proof. unfold hasASPe. simpl. intros. inverts H. Qed.

(** Prove the P1 can generate a term with aHSH within the system *)

Example ex3: hasASPs P1 (example_sys_1) aVC.
Proof. simpl. unfold hasASPe. simpl. auto. Qed.

(** the P0 knows of the target within system 1
 *)

Example ex4: knowsOfs P0 example_sys_1 P1.
Proof.
unfold knowsOfs. simpl. left. unfold knowsOfe. simpl.  auto.
Qed.

(** the P0 does not directly know of the appraiser
 *)

Example ex5: knowsOfe P0 e_P2 P2 -> False.
Proof.
  unfold knowsOfe. simpl. intros. destruct H. inversion H. assumption.
Qed.

(** the P0 does not knows of the P2 within the system...
 * should be that P0 knows of P1 and P1
 * knows of P2....
 *)

Example ex6: knowsOfs P0 example_sys_1 P2 -> False.
Proof.
unfold knowsOfs. simpl. unfold knowsOfe. simpl. intros. inverts H. inverts H0. inverts H. apply H. inverts H0. destruct H. inverts H. apply H. destruct H. inverts H. inverts H0. apply H0. apply H.
Qed.

(** if the P0 was it's own system, it would still be aware of
 *  P1 *)

Example ex7: knowsOfs P0 [e_P0] P1.
Proof.
unfold knowsOfs,knowsOfe. simpl. auto.
Qed.

(** Proof tactic for executability
 *)
Ltac prove_exec' :=
    simpl; auto; match goal with
                 | |- hasASPe _ _ _ => cbv; left; reflexivity
                 | |- knowsOfe _ _ _ => unfold knowsOfe; simpl; left; reflexivity
                 | |- _ /\ _ => split; prove_exec'
                 | |- ?A => idtac A
                 end.

(** Is asp aVC executable on the P1 in the P1s's
 * enviornement?
 *)

Example ex8: (executable (asp aVC) P1 e_P1).
Proof. prove_exec'. Qed.

(** aSFS is not executable on P1 even if in P2's environment
 *)

Example ex9: (executable (asp aSFS) P1 e_P2) -> False.
Proof.
  intros Hcontra; cbv in *; destruct Hcontra. inverts H. destruct H. inverts H. apply H.
Qed.

(** two aHSH operations are executable on the P1
 *)

Example ex10: (executable (lseq (asp aHSH) (asp aHSH)) P1 e_P1).
Proof. prove_exec'; cbv; auto. Qed.

(** the relying party can ask the target to run aVC and signature
 * operations within system 1
 *)

Example ex11: (executables (lseq (asp aVC) (att P1 (lseq (asp aHSH) (asp aHSH)))) P1 example_sys_1).
Proof.
  prove_exec'; cbv; auto. intros. split; auto.
Qed.

(* A few decidability proofs... useful later*)
Theorem string_dec: forall (s s':string), {s=s'}+{s<>s'}.
Proof.
  intros s s'.
  repeat decide equality.
Defined.

Theorem plc_dec: forall (p p':Plc),{p=p'}+{p<>p'}.
Proof.
  intros p p'.
  apply string_dec.
Defined.

(** A proof that [tar_Policy] is decidable.  If we can show all policies are
* decidable, life is good.  This is a start.
*)
Theorem tar_Policy_dec: forall (asp:ASP)(plc:Plc), {(tar_Policy asp plc)}+{~(tar_Policy asp plc)}.
Proof.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aHSH.
    pose proof plc_dec plc P2.
    destruct H; destruct H0.
  ++ subst. left. rewrite e. apply p_aHSH.
  ++ right. rewrite e. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  ++ right. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  ++ right. unfold not in *. intros Hneg. apply n. inversion Hneg. reflexivity.
  + left. apply p_SIG.
  + right_dest_inverts.
Defined.

(* Policy P0 is decidable *)
Theorem P0_Policy_dec: forall (asp:ASP)(plc:Plc), {(P0_Policy asp plc)}+{~(P0_Policy asp plc)}.
Proof.
  intros asp; intros plc; destruct asp; right_dest_inverts.
Defined.

(* Policy P1 is decidable *)
Theorem P1_Policy_dec: forall (asp:ASP)(plc:Plc), {(P1_Policy asp plc)}+{~(P1_Policy asp plc)}.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aHSH.
    pose proof ASP_dec (ASPC s f a) aVC.
    pose proof plc_dec plc P0.
    destruct H; destruct H0; destruct H1; subst.
  ++ rewrite e in e1. inversion e1.
  ++ rewrite e in e1. inversion e1.
  ++ rewrite e. auto.
  ++ right_dest_inverts. contradiction. contradiction.
  ++ rewrite e. left. auto.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  + right_dest_inverts.
  + right_dest_inverts.
Defined.

(* Policy P2 is decidable *)
Theorem P2_Policy_dec: forall (asp:ASP)(plc:Plc), {(P2_Policy asp plc)}+{~(P2_Policy asp plc)}.
Proof.
  intros asp.
  intros plc.
  destruct asp.
  + right_dest_inverts.
  + right_dest_inverts.
  + pose proof ASP_dec (ASPC s f a) aSFS.
    pose proof plc_dec plc P1.
    destruct H,H0.
  ++ left. subst. rewrite e. auto.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  ++ right_dest_inverts; contradiction.
  + right_dest_inverts.
  + right_dest_inverts.
Defined.

Ltac map_update_eq := unfold e_P2; apply e_update_reduce; unfold not; intros Hneg; rewrite Hneg in *; contradiction.

(* With Policy, we can now prove the system (e_P2) is sound. *)
Theorem sound_local_policies: (forall p0 a0, {(checkASPPolicy p0 e_P2 a0)} + {~(checkASPPolicy p0 e_P2 a0)}).
Proof.
  intros p a.
  pose proof plc_dec p P0.
  pose proof plc_dec p P1.
  pose proof plc_dec p P2.
  destruct H, H0, H1.
  + rewrite e in e1. inversion e1.
  + rewrite e in e1. inversion e1.
  + rewrite e in e1. inversion e1.
  + rewrite e. unfold checkASPPolicy. simpl. apply P0_Policy_dec.
  + rewrite e in e1. inversion e1.
  + rewrite e. unfold checkASPPolicy. simpl. apply P1_Policy_dec.
  + rewrite e. unfold checkASPPolicy. simpl. apply P2_Policy_dec.
  + right. unfold checkASPPolicy.
   assert (H: e_P2 p = e_P1 p). { map_update_eq. }
   assert (H0: e_P1 p = e_P0 p). { map_update_eq. }
   assert (H1: e_P0 p = e_empty p). { map_update_eq. }
   unfold not. intros Hneg. rewrite <- H in *. rewrite <- H0 in *. rewrite H1 in *. auto.
Defined.

(* Proof that the system described by e_P2 is sound. *)
Theorem sound_system_dec: forall t p, {sound t p e_P2}+{~(sound t p e_P2)}.
Proof.
  intros t p.
  apply sound_dec.
  intros p0 a0.
  apply sound_local_policies.
Defined.

Compute sound_system_dec (asp aHSH) P1.
Compute sound_system_dec (asp aSFS) P2.

End Manifest.

(* END OF FILE *)