Load loadpath.
Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq.
Require Import prelude heaps rels hprop domains secmod seclog seclogO examples.
Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(***********************************************************************)
(* Example 2 in the paper: controlling access and declassification.    *)
(*                                                                     *)
(* Alice keeps her salary in a local state. She allows free reading of *)
(* the salary, but writing is enabled only if the correct password     *)
(* provided. Declassification of the salary possible also upon correct *)
(* password authentication.                                            *)
(***********************************************************************)

(* signature *)

Module Type AliceSig1.
Parameter alice : Type.

Parameter sshape : d alice -> d nat -> d nat -> Pred (d heap).
Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Parameter srefl : 
  forall aa ss pp ii, ii \In sshape aa ss pp -> 
    ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.

Parameter new : 
  nat -> nat -> 
    STsec [:::] alice 
      (fun i => True, 
       fun ii aa mm => exists ss, exists pp, exists hh, 
                         mm = ii :++ hh /\ sshape aa ss pp hh). 

Parameter read_salary : 
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> mm = ii /\ yy = ss).

Parameter write_salary : 
  nat -> nat -> 
    STsec [:: alice] unit
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp).

Parameter declassify : forall p, 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2)).

End AliceSig1.

(* implementation *)

Module Alice1 : AliceSig1.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1, 
                 ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2,
                 ss.1 = ss.2 & pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl aa ss pp ii : 
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move: aa ss pp ii=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Program 
Definition new (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @0 [s];;
      halloc @ (fun x => [p]);; 
      ret @ (fun y x => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do ![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>x1 x2; v2step=>y1 y2; v2step=>_ _ _ _ _ _ _.
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2) /plus2.
by eexists (s, s), (p, p), (_, _); do !split=>//=; rewrite unC.
Qed.

(* let's try without tactics *)
Program 
Definition new' (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @0 [s];;
      halloc @ (fun x => [p]);; 
      ret @ (fun y x => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=.
- move=>i _. 
  apply: sbnd_push; apply: sbnd_inst; apply: sbnd_halloc=>x. 
  apply: sval_inst; apply: sbnd_push; apply: sbnd_inst; apply: sbnd_halloc=>y.
  by apply: sval_inst; apply: sval_inst; apply: sval_ret.
move=>i1 i2 _ _.
apply/vrfS1; apply: bnd_pushV; apply: bnd_instV; apply/vrfS1. 
apply/vrfS2; apply: bnd_pushV; apply: bnd_instV; apply/vrfS2.
apply: bnd_halloc=>x1 x2.
apply/vrfS1; apply: val_instV; apply: bnd_pushV; apply: bnd_instV; apply/vrfS1.
apply/vrfS2; apply: val_instV; apply: bnd_pushV; apply: bnd_instV; apply/vrfS2.
apply: bnd_halloc=>y1 y2.
apply/vrfS1; apply: val_instV; apply: val_instV; apply/vrfS1.
apply/vrfS2; apply: val_instV; apply: val_instV; apply/vrfS2.
apply: val_ret=>_ _ _ _ _ _ _.
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2) /plus2.
by eexists (s, s), (p, p), (_, _); do !split=>//=; rewrite unC.
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][/= -> _ _ _]; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
by move=>_ _; v2step.
Qed.

Program
Definition write_salary (s : nat) (p : nat) : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> 
     exists jj', exists ss', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss' pp) :=
  Do (read _ @ (fun a => [passwd a]);;
      Ifbool (fun x a => x == p) then 
        write @ (fun x a => [salary a, s])
      else ret @ (fun x a => [tt]) 
    with [::: nat; alice], unit, 
      (fun x a i => exists s, exists p, exists j, exists h, 
                      i = j :+ h /\ j \In shape a s p,
       fun xx aa ii yy mm => forall ss pp jj hh, 
         ii = jj :++ hh -> xx.1 = xx.2 -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp)).
Next Obligation.
rewrite !gh; split=>[[x][a][]|[x1][a1][][x2][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _].
  by case: ifP=>E; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> -> ->] _ _.
by case: ifP=>E; v2step; eexists (_, _), (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _].
  by do !sstep; ssimpl; apply: sval_do=>/=; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _; v2step; v2simpl.
apply: val_do=>[|_ _ m1 m2] /=; first by hhauto.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H.
Qed.

Program
Definition declassify (p : nat) : 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2)) :=
  Do (read nat @ (fun a => [passwd a]);;
      ret @ (fun x a => [p == x])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][q][j][h][->][/= -> _ _ _]; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
by move=>_ _; v2step; eexists (_, _).
Qed.

End Alice1.

(* a different implementation, where the salary is not kept low *)
(* showing that the spec does not leak info *)

Module Alice11 : AliceSig1.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1, 
                 ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2 & 
                 pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Program 
Definition new (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do ((* get a random location *)
      halloc @0 [s];; 
      dealloc @ (fun z => [z]);;
      (* store the random loc into the salary field *)
      halloc @ (fun _ z => [nat_ptr z]);; 
      (* store the password *)
      halloc @ (fun x _ z => [p]);; 
      ret @ (fun y x _ z => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do ![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>z1 z2; v2step=>x1 x2; v2step=>y1 y2; v2step. 
eexists (nat_ptr z1, nat_ptr z2), (p, p), (_, _). 
rewrite -(unC i1) -!(unCA i1) -(unC i2) -!(unCA i2) /plus2; 
by do !split=>//=; rewrite unC unh0.
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][/= -> _ _]; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> ->].
by move=>_ _; v2step.
Qed.

Program
Definition write_salary (s : nat) (p : nat) : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> 
     exists jj', exists ss', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss' pp) :=
  Do (read _ @ (fun a => [passwd a]);;
      Ifbool (fun x a => x == p) then 
        write @ (fun x a => [salary a, s])
      else ret @ (fun x a => [tt]) 
    with [::: nat; alice], unit, 
      (fun x a i => exists s, exists p, exists j, exists h, 
                      i = j :+ h /\ j \In shape a s p,
       fun xx aa ii yy mm => forall ss pp jj hh, 
         ii = jj :++ hh -> xx.1 = xx.2 -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp)).
Next Obligation.
rewrite !gh; split=>[[x][a][]|[x1][a1][][x2][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _]; rewrite -!unA.
  by case: ifP=>E; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> ->] _ _.
by case: ifP=>E; v2step; eexists (_, _), (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _].
  by sstep; ssimpl; apply: sval_do; hhauto.  
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> ->].
move=>_ _; v2step; v2simpl.
apply: val_do=>[|[] [] m1 m2] /=; first by hhauto. 
move/(_ (s1, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H.
Qed.

(* we declassify only if salary = 0, and loop otherwise *)

Program
Definition declassify (p : nat) : 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2)) :=
  Do (read nat @ (fun a => [passwd a]);;
      Ifbool (fun x a => p == x) then 
         read nat @ (fun x a => [salary a]);;
         Ifbool (fun s x a => s == 0) then 
            ret @ (fun s x a => [true])
         else diverge with 
           [::: nat; nat; alice], bool,
           (fun s x a i => exists j, exists h,
                             i = j :+ h /\ j \In shape a s x,
            fun ss xx aa ii yy mm => forall jj hh, p = xx.1 -> p = xx.2 ->
              ii = jj :++ hh -> jj \In sshape aa ss xx ->
            exists jj',
              mm = jj' :++ hh /\ jj' \In sshape aa ss xx /\ yy = (true, true) /\
              ss.1 = ss.2)
      else ret @ (fun x a => [false]) with
        [::: nat; alice], bool,
        (fun x a i => exists s, exists j, exists h,
                      i = j :+ h /\ j \In shape a s x,
         fun xx aa ii yy mm => forall ss jj hh, 
              ii = jj :++ hh -> jj \In sshape aa ss xx ->
            exists jj',
              mm = jj' :++ hh /\ jj' \In sshape aa ss xx /\ yy.1 = yy.2 /\
              yy = (p == xx.1, p == xx.2) /\ (yy.1 -> ss.1 = ss.2))).           
Next Obligation.
rewrite !gh; split=>[[s][x][a][]|[s1][x1][a1][][s2][x2][a2][]] /=.
- by move=>i [j][h][->] /= H; case: ifP=>E; [sstep | apply: sval_do].
move=>i1 i2 [[[]]][j1 j2][h1 h2][[[[]]]] -> -> [-> ->] /= H _ _.
case: ifP=>E1; case: ifP=>E2.
- by v2step=>_ _; exists (j1, j2); rewrite (eqP E1) (eqP E2) in H *.
- by apply/vrfS1; vstep=>_; apply: val_doV.
- by apply/vrfS2; vstep=>_; apply: val_doV.
by apply: val_do.
Qed.
Next Obligation.
rewrite !gh; split=>[[x][a][]|[x1][a1][][x2][a2][]] /=.
- move=>i [s][j][h][->][/= -> _ _].
  case: ifP=>E; sstep; last by [].
  by ssimpl; apply: sval_do; hhauto.
move=>i1 i2 [[[[]]]][s1 s2][j1 j2][h1 h2] /= [[[]]]. 
move=>-> -> H _ _; case: H (H)=>/= -> -> -> H.
case: eqP=>E; v2step; last by eexists (_, _).
v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=; first by hhauto. 
case/(_ (_, _) (_, _) E E (erefl _) H)=>[[t1 t2]][[-> ->]][H2][[-> ->]].
by eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s][q][j][h][->][/= -> _ _].
  by sstep; ssimpl; apply: sval_do; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][q1 q2][j1 j2][h1 h2][[-> ->]] H _ _.
case: H (H)=>/= -> -> -> H; v2step; v2simpl.
apply: val_do=>[|y1 y2 m1 m2] /=; first by hhauto.
case/(_ (_, _) (_, _) (_, _) (erefl _) H)=>[[t1 t2]][[-> ->]][H2][->][[-> _]].
by eexists (_, _).
Qed.

End Alice11.

(* yet another implementation where neither salary nor password are kept low *)
(* this shows that the spec does not leak niether the salary nor the passwd *)

Module Alice12 : AliceSig1.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 /\
             ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2].

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Program 
Definition new (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do ((* get a random location *)
      halloc @0 [s];; 
      dealloc @ (fun z => [z]);;
      (* store the random loc into the salary field *)
      halloc @ (fun _ z => [nat_ptr z]);; 
      (* store it again into the password *)
      halloc @ (fun x _ z => [nat_ptr z]);; 
      ret @ (fun y x _ z => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do ![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>z1 z2; v2step=>x1 x2; v2step=>y1 y2.
v2step=>_ _ _ _ _ _ _ _ _.
rewrite -(unC i1) -!(unCA i1) -(unC i2) -!(unCA i2) /plus2 !unh0.
eexists (nat_ptr z1, nat_ptr z2), (nat_ptr z1, nat_ptr z2), (_, _).
by do !split=>//=; rewrite unC.
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][/= -> _]; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> ->] _ _.
by v2step.
Qed.

(* write salary can just be the identity function *)

Program
Definition write_salary (s : nat) (p : nat) : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> 
     exists jj', exists ss', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss' pp) :=
  Do (ret @ (fun a => [tt])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i _; sstep.
move=>i1 i2 [[[[[]]]]] /= [s1 s2][p1 p2][j1 j2][h1 h2].
by case=>[[->->]] H _ _; v2step; eexists (j1, j2), (s1, s2).
Qed.

(* we never declassify, always loop *) 
(* hence, if we observe termination, the password must have been public *)
(* (which the spec grants anyway) *)
(* but we can never actually observe termination *)

Program
Definition declassify (p : nat) : 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2)) :=
  Do (diverge).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i _; apply: sval_do.
by move=>i1 i2 [[[[[]]]]] ss pp jj hh _ _ _; apply: val_do.
Qed.

End Alice12.

(**************************************************************************)
(* Example 3 in the paper: state-dependent policy                         *)
(*                                                                        *)
(* Writing into the salary field is as before, but reading can only be    *)
(* done if read access is granted via the grant function. the access can  *)
(* be revoked via revoke function.                                        *)
(*                                                                        *)
(* Example 4: erasure policy via higher-order functions and polymorpshism *)
(*                                                                        *)
(* Alice can grant access to Bob's computation via the (higher-order)     *)
(* function ratify, if Bob can first prove that he's not stealing the     *)
(* salary information.                                                    *)
(**************************************************************************)

Module Type AliceSig2.
Parameter alice : Type.

Parameter sshape : d alice -> d nat -> d nat -> Pred (d heap).
Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Parameter srefl : 
  forall aa ss pp ii, ii \In sshape aa ss pp -> 
    ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2. 

Parameter rreadable : d alice -> Pred (d heap). 
Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Parameter rrefl : 
  forall aa ii, ii \In rreadable aa -> 
                ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2. 

Parameter new : 
  nat -> nat -> 
    STsec [::] alice 
      (fun i => True, 
       fun ii aa mm => exists ss, exists pp, exists hh, 
                         mm = ii :++ hh /\ hh \In sshape aa ss pp). 

Parameter read_salary : 
  STsec [:: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
         jj \In rreadable aa -> mm = ii /\ yy = ss).

Parameter write_salary : 
  nat -> nat -> 
    STsec [:: alice] unit
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp /\
         (jj \In rreadable aa -> jj' \In rreadable aa)).

Parameter declassify : forall p, 
  STsec [:: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2) /\ 
       (jj \In rreadable aa -> jj' \In rreadable aa)).

Parameter grant : 
  STsec [:: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp ->  
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp /\ jj' \In rreadable aa).

Parameter revoke : 
  STsec [:: alice] unit
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp).

Section Ratify.
Variables bob G : Type.
Variables bbshape : d bob -> d G -> Pred (d heap).
Variables bcmp : G -> G.

Definition bshape b k : Pred heap := 
  fun t => (t, t) \In bbshape (b, b) (k, k). 

Definition breflP := 
  forall bb kk tt, tt \In bbshape bb kk -> 
    tt.1 \In bshape bb.1 kk.1 /\ tt.2 \In bshape bb.2 kk.2.

Definition epre a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (tt.1 = tt.2 -> tt'.1 = tt'.2). 

Parameter ratify : 
  breflP -> 
  STsec [::: alice; bob] nat 
    (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
     fun aa bb ii yy mm => 
       forall jj, rreadable aa jj -> epost aa bb jj yy ii mm) ->
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm).

End Ratify.

End AliceSig2.

Module Alice2 : AliceSig2.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1, 
                 ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2,
                 ss.1 = ss.2 & pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Definition rreadable (aa : d alice) : Pred (d heap) := 
  [Pred ii | exists ss:d nat, exists pp:d nat, 
               ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 /\
               ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2].

Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Lemma rrefl aa ii : 
        ii \In rreadable aa -> 
        ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2.
Proof.
move: aa ii=>[a1 a2][i1 i2][[s1 s2]][[p1 p2]][/= -> ->].
by split; [exists (s1, s1); exists (p1, p1) | 
           exists (s2, s2); exists (p2, p2)].
Qed.

Program 
Definition new (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @0 [s];;
      halloc @ (fun x => [p]);; 
      ret @ (fun y x => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do ![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>x1 x2; v2step=>y1 y2; v2step.
rewrite -(unC i1) -!(unCA i1) -(unC i2) -!(unCA i2) /plus2.
by eexists (s, s), (p, p), (_, _); do !split=>//=; rewrite unC.
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa -> 
         mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][[/= -> _ _ _]] _; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->].
by move=>_ _ _; v2step. 
Qed.

Program
Definition write_salary (s : nat) (p : nat) : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> 
     exists jj', exists ss', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss' pp /\ 
       (jj \In rreadable aa -> jj' \In rreadable aa)) :=
  Do (read _ @ (fun a => [passwd a]);;
      Ifbool (fun x a => x == p) then 
        write @ (fun x a => [salary a, s])
      else ret @ (fun x a => [tt]) 
    with [::: nat; alice], unit, 
      (fun x a i => exists s, exists p, exists j, exists h, 
                      i = j :+ h /\ j \In shape a s p,
       fun xx aa ii yy mm => forall ss pp jj hh, 
         ii = jj :++ hh -> xx.1 = xx.2 -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp /\ 
         (jj \In rreadable aa -> jj' \In rreadable aa))).
Next Obligation.
rewrite !gh; split=>[[x][a][]|[x1][a1][][x2][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _].
  by case: ifP=>E; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> -> ->] _ _; rewrite /plus2 /=.
case: ifP=>E; v2step; eexists (_, _), (_, _); do !split=>//=.
by move=>L; eexists (_, _), (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _].
  by sstep; ssimpl; apply: sval_do; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _; v2step; v2simpl; apply: val_do=>[|_ _ m1 m2 ] /=; first by hhauto.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)). 
by move=>H _ _; apply: H.
Qed.

Program
Definition declassify (p : nat) : 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2) /\ 
       (jj \In rreadable aa -> jj' \In rreadable aa)) :=
  Do (read nat @ (fun a => [passwd a]);;
      ret @ (fun x a => [p == x])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][q][j][h][->][/= -> _ _ _]; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
by move=>_ _; v2step; eexists (_, _).
Qed.

Program
Definition grant : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp ->  
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp /\ jj' \In rreadable aa) := 
  Do (ret @ (fun a => [tt])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][p][j][h][->][/= ->_ _ _]; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _; v2step; eexists (_, _); rewrite /plus2 /=; do !split=>//.
by eexists (_, _), (_, _).
Qed.

Program
Definition revoke : 
  STsec [::: alice] unit
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa ->
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp) := 
  Do (ret @ (fun a => [tt])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][p][j][h][->][[/= -> _ _ _]] _; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _; v2step; eexists (_, _).
Qed.
 
Section Ratify.
Variables bob G : Type.
Variables bbshape : d bob -> d G -> Pred (d heap).
Variables bcmp : G -> G.

Definition bshape b k : Pred heap := 
  fun t => (t, t) \In bbshape (b, b) (k, k). 

Definition breflP := 
  forall bb kk tt, tt \In bbshape bb kk -> 
    tt.1 \In bshape bb.1 kk.1 /\ tt.2 \In bshape bb.2 kk.2.

Definition epre a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (tt.1 = tt.2 -> tt'.1 = tt'.2). 

Program
Definition ratify (pf : breflP) 
  (e : STsec [::: alice; bob] nat 
         (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
          fun aa bb ii yy mm => 
            forall jj, rreadable aa jj -> epost aa bb jj yy ii mm)) : 
  STsec [:: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm) :=
   Do (e @ (fun a b => [a, b])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][s][p][k][t][h][->][/= -> _ _ _] H. 
  ssimpl; apply: sval_do=>/=; eexists _; split; last by exists s, p, k, t, h. 
  by exists (s, s), (p, p).
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>/= E1 E2 E3 E4 H _ _.
rewrite {s1}E3 {p1}E4 in E1 E2 H1 *. 
case: (pf _ _ _ H)=>/= H2 H3; rewrite E1 E2.
have H4 : (j1, j2) \In rreadable (a1, a2).
- by rewrite /rreadable E1 E2; eexists (_, _), (_, _).
v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=.
- by split; (eexists _; split; last by [hhauto; eauto];
             by eexists (_, _); eexists (_, _)).
move/(_ (j1, j2) H4 (s2, s2) (p2, p2) (k1, k2) (t1, t2) (h1, h2))=>L _ _.
by apply: L=>//; rewrite E1 E2.
Qed.

End Ratify.

End Alice2.

(* we can implementat grant and revoke using s stateful *)
(* boolean flag; this justifies calling the policy a state-based one *)

Module Alice21 : AliceSig2.
Definition alice : Type := (ptr * ptr * ptr) % type.
Definition salary (a : alice) := a.1.1.
Definition passwd (a : alice) := a.1.2.
Definition flag (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | 
     exists ff : d bool,
       [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 :+ 
                  flag aa.1 :-> ff.1, 
           ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2 :+
                  flag aa.2 :-> ff.2,
           ss.1 = ss.2, ff.1 = ff.2 & pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. 
move=>[a1 a2][s1 s2][p1 p2][i1 i2][[f1 f2]][/= -> -> E1 E2 E3]. 
by split; exists (f1, f2)=>/=; rewrite ?E1 E2 ?E3.
Qed.

Definition rreadable (aa : d alice) : Pred (d heap) := 
  [Pred ii | exists ss:d nat, exists pp:d nat, 
               ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 :+ 
                      flag aa.1 :-> true /\
               ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2 :+
                      flag aa.2 :-> true].

Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Lemma rrefl aa ii : 
        ii \In rreadable aa -> 
        ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2.
Proof.
move: aa ii=>[a1 a2][i1 i2][[s1 s2]][[p1 p2]][/= -> ->].
by split; [exists (s1, s1); exists (p1, p1) | 
           exists (s2, s2); exists (p2, p2)].
Qed.

Lemma rreadableP (a1 a2 : alice) (s1 s2 s3 s4 : nat) 
                (p1 p2 p3 p4 : nat) (f1 f2 f3 f4 : bool) :
        def (salary a1 :-> s1 :+ passwd a1 :-> p1 :+ flag a1 :-> f1) -> 
        def (salary a2 :-> s2 :+ passwd a2 :-> p2 :+ flag a2 :-> f2) -> 
        (salary a1 :-> s3 :+ passwd a1 :-> p3 :+ flag a1 :-> f3,
         salary a2 :-> s4 :+ passwd a2 :-> p4 :+ flag a2 :-> f4) \In
        rreadable (a1, a2) -> f3 /\ f4.
Proof.
move=>D1 D2; case=>[[ss1 ss2]][[pp1 pp2]] /= [].
have D3: def (salary a1 :-> s3 :+ passwd a1 :-> p3 :+ flag a1 :-> f3).
- have L : dom (passwd a1 :-> p3 :+ flag a1 :-> f3) =i 
           dom (passwd a1 :-> p1 :+ flag a1 :-> f1).
  - by move=>i; rewrite !domPtUn !inE /= !domPt !defPtUn !defPt !domPt.
  by rewrite -!unA !defPtUn L !defPt !domPt in D1 *.
have D4: def (salary a2 :-> s4 :+ passwd a2 :-> p4 :+ flag a2 :-> f4).
- have L : dom (passwd a2 :-> p4 :+ flag a2 :-> f4) =i 
           dom (passwd a2 :-> p2 :+ flag a2 :-> f2).
  - by move=>i; rewrite !domPtUn !inE /= !domPt !defPtUn !defPt !domPt.
  by rewrite -!unA !defPtUn L !defPt !domPt in D2 *.
by do 2![heap_cancel=>// _ _ _ _ ->].
Qed. 

Lemma readableP a (s1 s2 p1 p2 : nat) (f1 f2 : bool) : 
        def (salary a :-> s1 :+ passwd a :-> p1 :+ flag a :-> f1) -> 
        salary a :-> s2 :+ passwd a :-> p2 :+ 
          flag a :-> f2 \In readable a -> f2.
Proof. by move=>D; case/(rreadableP D D). Qed.

Program 
Definition new (s : nat) (p : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii aa mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @0 [s];;
      halloc @ (fun x => [p]);; 
      halloc @ (fun y x => [false]);;
      ret @ (fun z y x => [(x, y, z)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do ![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>x1 x2; v2step=>y1 y2; v2step=>f1 f2; v2step. 
rewrite !(push x1) !(push x2) !(push y1) !(push y2) !(push f1) !(push f2).
eexists (s, s), (p, p), (_, _); rewrite /plus2; split=>//=.
by exists (false, false); split=>//=; rewrite unA. 
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa -> 
         mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [flag a]);;
      Ifbool (fun f a => f) then 
        read _ @ (fun f a => [salary a])
      else diverge with
        [:: bool; alice], nat,
        (fun f a i => exists s, exists p, exists j, exists h, 
                        f /\ i = j :+ h /\ j \In shape a s p, 
         fun ff aa ii yy mm => forall ss pp jj hh, ff.1 = ff.2 -> ff.1 ->
           ii = jj :++ hh -> jj \In sshape aa ss pp -> 
           mm = ii /\ yy = ss)).
Next Obligation.
rewrite !gh; split=>[[f][a][]|[f1][a1][][f2][a2][]] /=.
- by move=>i [s][p][j][h][->][->][[/= f1 f2]][-> _ _ -> _]; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
by case=>[[[[]]]] -> -> [-> ->][[/= g1 g2]][-> ->] -> -> -> _ _; v2step.
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s][p][j][h][->][[[/= f1 f2]]][-> _ _ -> _] E.
  sstep; ssimpl; apply: sval_do=>/=; move=>D; move: (D).
  move/defUnl: D=>D; move/(readableP D): E=>F.
  by eexists s, p, _, _; do !split=>//; exists (f2, f2).
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]][[/= f1 f2]][-> -> -> -> ->] E _ _.
apply: vrf2D; move/defUnl=>D1; move/defUnl=>D2.
case/(rreadableP D1 D2): E=>/= _ F. 
v2step; v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=.
- by split; eexists s2, p2, _, _; do !split=>//; exists (f2, f2).
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) F (erefl _))=>L _ _.
by apply: L; exists (f2, f2).
Qed.

Program
Definition write_salary (s : nat) (p : nat) : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h,
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> 
     exists jj', exists ss', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss' pp /\ 
       (jj \In rreadable aa -> jj' \In rreadable aa)) :=
  Do (read _ @ (fun a => [passwd a]);;
      Ifbool (fun x a => x == p) then 
        write @ (fun x a => [salary a, s])
      else ret @ (fun x a => [tt]) 
    with [::: nat; alice], unit, 
      (fun x a i => exists s, exists p, exists j, exists h, 
                      i = j :+ h /\ j \In shape a s p,
       fun xx aa ii yy mm => forall ss pp jj hh, 
         ii = jj :++ hh -> xx.1 = xx.2 -> jj \In sshape aa ss pp -> 
       exists jj', exists ss', 
         mm = jj' :++ hh /\ jj' \In sshape aa ss' pp /\ 
         (jj \In rreadable aa -> jj' \In rreadable aa))).
Next Obligation.
rewrite !gh; split=>[[x][a][]|[x1][a1][][x2][a2][]] /=.
- move=>i [s'][p'][j][h][->][[/= f1 f2]][-> _ _ -> _].
  by case: ifP=>E; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [[/= f1 f2]][-> -> -> -> ->] _ _.
case: ifP=>E; v2step; move/defUnl=>D1; move/defUnl=>D2.
- eexists (_, _), (s, s); rewrite /plus2=>/=; do !split=>//.
  - by exists (f2, f2).
  case/(rreadableP D1 D2)=>F _. 
  by exists (s, s), (p2, p2); rewrite /= F.
eexists (_, _), (s2, s2)=>/=; rewrite /plus2=>/=.
by do !split=>//; exists (f2, f2).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][[/= f1 f2]][-> _ _ -> _].
  sstep; ssimpl; apply: sval_do=>/=.
  by do 4![eexists _]; split=>//; exists (f2, f2).
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[-> ->]][[/= f1 f2]][-> -> -> -> ->] _ _.
v2step; v2simpl; apply: val_do=>[|_ _ m1 m2] /=. 
- by split; do 4![eexists _]; split=>//; exists (f2, f2).
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H; exists (f2, f2).
Qed.

Program
Definition declassify (p : nat) : 
  STsec [::: alice] bool
    (fun a i => exists s, exists q, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s q,
     fun aa ii yy mm => forall ss qq jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss qq -> 
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss qq /\ yy.1 = yy.2 /\
       yy = (p == qq.1, p == qq.2) /\ (yy.1 -> ss.1 = ss.2) /\ 
       (jj \In rreadable aa -> jj' \In rreadable aa)) :=
  Do (read nat @ (fun a => [passwd a]);;
      ret @ (fun x a => [p == x])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][q][j][h][->][[/= f1 f2]][-> _ _ -> _]; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[-> ->]][[/= f1 f2]][-> -> -> -> ->] _ _; v2step=>_ _.
by eexists (_, _); rewrite /plus2 /=; do !split=>//; exists (f2, f2).
Qed.

Program
Definition grant : 
  STsec [::: alice] unit 
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp ->  
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp /\ jj' \In rreadable aa) := 
  Do (write @ (fun a => [flag a, true])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][p][j][h][->][[/= f1 f2]][-> _ _ -> _]; sstep. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[-> ->]][[/= f1 f2]][-> -> -> -> ->] _ _; v2step=>_ _.
eexists (_, _); rewrite /plus2 /=; do !split=>//; 
by [exists (true, true) | exists (s2, s2), (p2, p2)].
Qed.

Program
Definition revoke : 
  STsec [::: alice] unit
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a,
     fun aa ii yy mm => forall ss pp jj hh, 
       ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa ->
     exists jj', 
       mm = jj' :++ hh /\ jj' \In sshape aa ss pp) := 
  Do (write @ (fun a => [flag a, false])). 
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][p][j][h][->][[[/= f1 f2]]][-> _ _ -> _] _; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]][[/= f1 f2]][-> -> -> -> ->] L _ _; v2step.
by eexists (_, _); rewrite /plus2; do !split=>//=; exists (false, false).
Qed.
 
Section Ratify.
Variables bob G : Type.
Variables bbshape : d bob -> d G -> Pred (d heap).
Variables bcmp : G -> G.

Definition bshape b k : Pred heap := 
  fun t => (t, t) \In bbshape (b, b) (k, k). 

Definition breflP := 
  forall bb kk tt, tt \In bbshape bb kk -> 
    tt.1 \In bshape bb.1 kk.1 /\ tt.2 \In bshape bb.2 kk.2.

Definition epre a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (tt.1 = tt.2 -> tt'.1 = tt'.2). 

Program
Definition ratify (pf : breflP) 
  (e : STsec [::: alice; bob] nat 
         (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
          fun aa bb ii yy mm => 
            forall jj, rreadable aa jj -> epost aa bb jj yy ii mm)) : 
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm) :=
   Do (grant @ (fun a b => [a]);;
       e @ (fun _ a b => [a, b])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][s][p][k][t][h][->][[/= f1 f2]][-> _ _ -> _] H.
  ssimpl; apply: sbnd_do=>[|y m] /=; rewrite -unA.  
  - by eexists s, p, _, _; split=>//; exists (f2, f2).
  have L: (salary a :-> s :+ passwd a :-> p :+ flag a :-> f2,
           salary a :-> s :+ passwd a :-> p :+ flag a :-> f2) \In
          sshape (a, a) (s, s) (p, p) by exists (f2, f2). 
  move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) L). 
  case=>[[j1' j2']][[-> E]][H1] H2.
  ssimpl; apply: sval_do=>/=.
  exists j1'; split; first by case/rrefl: H2.
  by exists s, p, k, t, h; rewrite unA; case/srefl: H1.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>[[/= f1 f2]][E1 E2 E3 E4 E5] H _ _.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=.
- split; case/srefl: H1=>/= H1 L1; rewrite -unA.
  - by eexists s1, p1, _, _.
  by eexists s2, p2, _, _.
have L: (j1, j2) \In sshape (a1, a2) (s1, s2) (p1, p2).
- by exists (f1, f2).
rewrite -(unA j1) -(unA j2).
move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) L).
case=>[[j1' j2']][[-> ->]][H2] H3.
v2simpl; apply: val_do=>[|z1 z2 n1 n2] /=.
- case/rrefl: H3=>/= H4 H5; case/srefl: H2=>/= H6 H7. 
  case/pf: H=>/= H8 H9; split; rewrite unA.
  - by exists j1'; split=>//; exists s1, p1, k1; hhauto.
  by exists j2'; split=>//; exists s2, p2, k2; hhauto.
move/(_ (j1', j2') H3 (s1, s2) (p1, p2) (k1, k2) (t1, t2) (h1, h2))=>P _ _.
by apply: P=>//; rewrite !unA.
Qed.

End Ratify.

End Alice21.

(* Two very different clients for the above code                    *)
(* We show that both can be dealt with using the polymorphic ratify *)

(* first a client with no local state *)

Module EmptyState.
Definition bob := unit.
Definition G := unit.
Definition bbshape (bb : d bob) (kk : d G) := fun mm => mm = (empty, empty). 
Definition bcmp : G -> G := fun x => tt.

Lemma brefl : Alice2.breflP bbshape.
Proof. by move=>[b1 b2][k1 k2][t1 t2][-> ->]. Qed. 

Program
Definition empty_client := 
  Alice2.ratify (bcmp := bcmp) brefl
    (Do (Alice2.read_salary @ (fun a b => [a]);;
         ret @ (fun x a b => [x./2]))).
Next Obligation.
rewrite /Alice2.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [-> _]; rewrite unh0.
  ssimpl; apply: sbnd_do=>/=; first by eauto 10.
  by move=>y m _; sstep. 
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=. 
move=>[[[R]]][-> ->] S [-> ->] _ _.
case/Alice2.srefl: (S)=>/= S1 S2; case/Alice2.rrefl: (R)=>/= R1 R2.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; rewrite !unh0.
- by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>[[-> ->]][-> ->].
by v2step=>_ _; exists (j1, j2); exists (empty, empty); rewrite unh02.
Qed.

End EmptyState.

(* second client keeps the count of how many times it has been called *)
(* but it keeps nothing else; hence no theft occurs *)

Module CountingClient.
Definition bob := ptr.
Definition G := nat.
Definition bbshape (bb : d bob) (kk : d G) := 
  [Pred ii | ii.1 = bb.1 :-> kk.1 /\ ii.2 = bb.2 :-> kk.2].
Definition bcmp : G -> G := fun k => k.+1. 

Lemma brefl : Alice2.breflP bbshape.
Proof. by move=>[b1 b2][k1 k2][t1 t2][-> ->]. Qed.

Program
Definition counting_client :=
  Alice2.ratify (bcmp := bcmp) brefl
    (Do (Alice2.read_salary @ (fun a b => [a]);;
         read _ @ (fun x a b => [b]);;
         write @ (fun k x a b => [b, k.+1]);;
         ret @ (fun _ k x a b => [x./2]))).
Next Obligation.
rewrite /Alice2.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [/= -> _]. rewrite -!unA.
  ssimpl; apply: sbnd_do=>[|y m] /=; first by eauto 10.
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2 H1)=>[[-> _]][-> _].
  by sstep.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [/= -> ->] _ _. 
apply: vrf2D; move/defUnl; move/defUnr=>D _; rewrite -!unA.
case/Alice2.srefl: (S)=>/= S1 S2; case/Alice2.rrefl: (R)=>/= R1 R2.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>[[-> ->]][-> ->].
v2step=>_ _; rewrite !unA. 
exists (j1, j2), (b1 :-> k1.+1, b2 :-> k2.+1); do !split=>//=.
by move=>E; case/(pts_injP D): E (E)=><- _; case/(pts_inj D)=><-.
Qed.
 
End CountingClient.

(* third client shows that the specification can be satisfied *)
(* if we didn't steal the salary, but if we overwrite the *)
(* stolen fields with some public info *)

Module ErasingClient.
Definition bob := ptr.
Definition G := nat.
Definition bbshape (bb : d bob) (kk : d G) := 
  [Pred ii | ii.1 = bb.1 :-> kk.1 /\ ii.2 = bb.2 :-> kk.2].
Definition bcmp : G -> G := fun k => k.+1. 

Lemma brefl : Alice2.breflP bbshape.
Proof. by move=>[b1 b2][k1 k2][t1 t2][-> ->]. Qed.

Program
Definition erasing_client :=
  Alice2.ratify (bcmp := bcmp) brefl
    (Do (Alice2.read_salary @ (fun a b => [a]);;
         read _ @ (fun x a b => [b]);;
         write @ (fun k x a b => [b, x]);;
         write @ (fun _ k x a b => [b, k.+1]);;
         ret @ (fun _ _ k x a b => [x./2]))).
Next Obligation.
rewrite /Alice2.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [/= -> _]; rewrite -!unA.
  ssimpl; apply: sbnd_do=>[|y m] /=; first by eauto 10.
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2 H1)=>[[-> _]][-> _].
  by sstep.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [/= -> ->] _ _.
apply: vrf2D; move/defUnl; move/defUnr=>D _; rewrite -!unA.
case/Alice2.srefl: (S)=>/= S1 S2; case/Alice2.rrefl: (R)=>/= R1 R2.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>[[-> ->]][-> ->].
v2step=>_ _; rewrite !unA.
exists (j1, j2), (b1 :-> k1.+1, b2 :-> k2.+1); do !split=>//=.
by move=>E; case/(pts_injP D): E (E)=><- _; case/(pts_inj D)=><-.
Qed.
 
End ErasingClient.
