Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq.
Require Import heaps rels hprop domains stmod stcont stlog examples.
Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

(* 
This is a file with an alternative spec for Alice, where the readable
predicates have been removed from the postconditions of grant and
revoke in the example on stateful policiies.
*)

(***********************************************************************)
(* Example 1: 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 aa ii 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, 
     fun aa yy ii 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 yy ii 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 yy ii 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 : 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 aa ii mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @ [s];;
      halloc @@ (fun x => [p]);; 
      ret @@ (fun y x => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; sauto=>x; sauto=>y; sauto. 
move=>i1 i2 _ _ _ _; vauto=>x1 x2; vauto=>y1 y2; vauto=>_ _ _ _ _ _ _.
exists (s, s); exists (p, p). 
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2).
eexists (_, _); split; first by rewrite /plus2 /=.
by rewrite /sshape -toPredE /=; 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 yy ii 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][->][/= -> _ _ _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
by move=>_ _ _ _; rewrite -!unA; vauto.
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 yy ii 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:Type; 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 yy ii 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; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> -> ->] _ _ _ _; rewrite -!unA.
by case: ifP=>_; vauto; rewrite !unA; do 2![eexists (_, _)].
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _]; rewrite -unA.
  by sauto; apply: sval_do; rewrite unA; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _ _ _; rewrite -!unA; vauto.
apply: val_do=>/=; first by split; rewrite unA; hhauto.
move=>_ _ m1 m2; rewrite /= 2!unA.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H; split=>//; rewrite /= unC.
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 yy ii 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][->][/= -> _ _ _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _ _ _; rewrite -!unA; vauto=>_ _; rewrite !unA.
by eexists (_, _); hhauto.
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 aa ii mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @ [s];; (* get a random location *)
      dealloc @@ (fun z => [z]);;
      halloc @@ (fun _ z => [nat_ptr z]);; (* store the random loc into the salary field *)
      halloc @@ (fun x _ z => [p]);; (* store the password *)
      ret @@ (fun y x _ z => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do !sauto=>?.
move=>i1 i2 _ _ _ _; vauto=>z1 z2; vauto=>x1 x2; vauto=>y1 y2.
vauto=>_ _ _ _ _ _ _ _ _.
exists (nat_ptr z1, nat_ptr z2); exists (p, p). 
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2).
eexists (_, _); split; first by rewrite /plus2 /=.
by rewrite /sshape -toPredE /=; 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 yy ii 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][->][/= -> _ _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> ->].
by move=>_ _ _ _; rewrite -!unA; vauto.
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 yy ii 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:Type; 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 yy ii 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; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> ->] _ _ _ _; rewrite -!unA.
by case: ifP=>_; vauto; rewrite !unA; do 2![eexists (_, _)].
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _]; rewrite -unA.
  by sauto; apply: sval_do; rewrite unA; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> ->].
move=>_ _ _ _; rewrite -!unA; vauto.
apply: val_do=>/=; first by split; rewrite unA; hhauto.
move=>_ _ m1 m2; rewrite /= 2!unA.
move/(_ (s1, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H; split=>//; rewrite /= unC.
Qed.

(* we can 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 yy ii 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:Type; nat:Type; alice], bool,
           (fun s x a i => exists j, exists h,
                             i = j :+ h /\ j \In shape a s x,
            fun ss xx aa yy ii 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:Type; alice], bool,
        (fun x a i => exists s, exists j, exists h,
                      i = j :+ h /\ j \In shape a s x,
         fun xx aa yy ii 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; [sauto | apply: sval_do].
move=>i1 i2 [[[]]][j1 j2][h1 h2][[[[]]]] -> -> [-> ->] /= H _ _ _ _.
case: ifP=>E1; case: ifP=>E2.
- by vauto=>_ _; exists (j1, j2); rewrite /= (eqP E1) (eqP E2) in H *.
- by lauto; apply: val_doV.
- by apply/vrfC; lauto; 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; last by sauto. 
  by rewrite -!unA; sauto; apply: sval_do; rewrite /= unA; hhauto.
move=>i1 i2 [[[[]]]][s1 s2][j1 j2][h1 h2] /= [[[]]]. 
move=>-> -> H _ _ _ _; case: H (H)=>/= -> -> -> H; rewrite -!unA.
case: eqP=>E; last by vauto=>_ _; rewrite !unA; eexists (_, _); hhauto.
vauto; apply: val_do=>[|y1 y2 m1 m2] /=; rewrite !unA; first by hhauto.
case/(_ (_, _) (_, _) E E (erefl _) H)=>[[t1 t2]][[-> ->]][H2][[-> ->]] F.
by eexists (_, _); hhauto.
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s][q][j][h][->][/= -> _ _]; rewrite -!unA.
  by sauto; apply: sval_do; rewrite /= unA; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][q1 q2][j1 j2][h1 h2][[-> ->]] H _ _ _ _.
case: H (H)=>/= -> -> -> H; rewrite -!unA.
vauto; apply: val_do=>[|y1 y2 m1 m2] /=; rewrite !unA; first by hhauto.
rewrite (unC (salary a1 :-> _)) (unC (salary a2 :-> _)) in H. 
move/(_ (_, _) (_, _) (_, _) (erefl _) H).
by case=>[[t1 t2]][[-> ->]][H2][->][[-> _]] /= E; eexists (_, _); hhauto.
Qed. 

End Alice11.

(* yet another implementation where neither salary nor password are kept low *)

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 aa ii mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @ [s];; (* get a random location *)
      dealloc @@ (fun z => [z]);;
      halloc @@ (fun _ z => [nat_ptr z]);; (* store the random loc into the salary field *)
      halloc @@ (fun x _ z => [nat_ptr z]);; (* store it again into the password *)
      ret @@ (fun y x _ z => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do !sauto=>?.
move=>i1 i2 _ _ _ _; vauto=>z1 z2; vauto=>x1 x2; vauto=>y1 y2.
vauto=>_ _ _ _ _ _ _ _ _.
exists (nat_ptr z1, nat_ptr z2); exists (nat_ptr z1, nat_ptr z2). 
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2).
eexists (_, _); split; first by rewrite /plus2 /=.
by rewrite /sshape -toPredE /=; 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 yy ii 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][->][/= -> _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> ->].
by move=>_ _ _ _; rewrite -!unA; vauto.
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 yy ii 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 _; sauto.
move=>i1 i2 [[[[[]]]]] /= [s1 s2][p1 p2][j1 j2][h1 h2].
case=>[[->->]] H _ _ _ _.
by vauto=>_ _; exists (j1, j2); exists (s1, s2).
Qed.

(* we never declassify, always loop *) 
(* hence, if we observe termination, the password must have been public *)
(* 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 yy ii 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 4: 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 5: erasure policy via higher-order functions and polymorpshism *)
(*                                                                        *)
(* Alice can grant access to Bob's computation via the (higher-order)     *)
(* function endorse, 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 shape_inv :  
  forall a s1 s2 p1 p2 j1 j2 h1 h2,
    def (j1 :+ h1) -> j1 :+ h1 = j2 :+ h2 -> 
    j1 \In shape a s1 p1 -> j2 \In shape a s2 p2 -> 
    [/\ j1 = j2, h1 = h2, s1 = s2 & p1 = p2].

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 aa ii 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 yy ii 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 yy ii 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 yy ii 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 yy ii 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 yy ii 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).

Section Endorse.
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 endorse : 
  breflP -> 
  STsec [:: alice; bob] nat 
    (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
     fun aa bb yy ii mm => 
       forall 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 yy ii mm => forall jj, epost aa bb jj yy ii mm).

End Endorse.

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.

Lemma shape_inv a s1 s2 p1 p2 j1 j2 h1 h2 : 
        def (j1 :+ h1) -> j1 :+ h1 = j2 :+ h2 -> 
        j1 \In shape a s1 p1 -> j2 \In shape a s2 p2 -> 
          [/\ j1 = j2, h1 = h2, s1 = s2 & p1 = p2].
Proof.
move=>D E S1 S2.
move: S1 S2 D E=>[/= -> _ _ _][/= -> _ _ _] D.
by heap_cancel=>// _ -> -> ->.
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 aa ii mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @ [s];;
      halloc @@ (fun x => [p]);; 
      ret @@ (fun y x => [(x, y)])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do !sauto=>?.
move=>i1 i2 _ _ _ _; vauto=>x1 x2; vauto=>y1 y2; vauto=>_ _ _ _ _ _ _.
exists (s, s); exists (p, p). 
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2).
eexists (_, _); split; first by rewrite /plus2 /=.
by rewrite /sshape -toPredE /=; 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 yy ii 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][->][[/= -> _ _ _]] _; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _ _; rewrite -!unA; vauto.
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 yy ii 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:Type; 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 yy ii 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][->][/= -> _ _ _]; rewrite -!unA.
  by case: ifP=>E; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]] -> [/= -> -> -> ->] _ _ _ _; rewrite -!unA.
case: ifP=>E; vauto; rewrite !unA;
eexists (_, _); eexists (_, _); rewrite /plus2=>/=; do !split=>//.
by move=>L; eexists (_, _); eexists (_, _); hhauto.
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][/= -> _ _ _]; rewrite -unA.
  by sauto; apply: sval_do; rewrite unA; hhauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _ _ _; rewrite -!unA; vauto.
apply: val_do=>/=; first by split; rewrite unA; hhauto.
move=>_ _ m1 m2; rewrite /= 2!unA.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
by move=>H _ _; apply: H; split=>//; rewrite /= unC.
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 yy ii 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][->][/= -> _ _ _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _ _ _; rewrite -!unA; vauto=>_ _; rewrite !unA.
by eexists (_, _); hhauto.
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 yy ii 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][->][/= -> _ _ _]; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->].
move=>_ _ _ _; vauto=>_ _.
eexists (_, _); rewrite /plus2 /=; do !split=>//. 
by eexists (_, _); 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 yy ii 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) := 
  Do (ret @@ (fun a => [tt])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- by move=>i [s][p][j][h][->][[/= -> _ _ _]] _; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _ _; vauto=>_ _; eexists (_, _).
Qed.
 
Section Endorse.
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 endorse (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 yy ii mm => 
            forall 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 yy ii 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; sauto.
  apply: sval_do=>/=.
  eexists _; split; last by exists s; exists p; exists k; exists t; exists h.
  by exists (s, s); exists (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 (_, _); eexists (_, _).
vauto; apply: val_do=>[|y1 y2 m1 m2] /=.
- by split; (eexists _; split; last by [hhauto; eauto];
             by eexists (_, _); eexists (_, _)).
move/(_ (j1, j2) (s2, s2) (p2, p2) (k1, k2) (t1, t2) (h1, h2))=>L _ _.
by apply: L=>//; rewrite E1 E2.
Qed.

End Endorse.

End Alice2.

(* we can try the implementation of grant and revoke with *)
(* a boolean flag *)

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.

Lemma shape_inv a s1 s2 p1 p2 j1 j2 h1 h2 : 
        def (j1 :+ h1) -> j1 :+ h1 = j2 :+ h2 -> 
        j1 \In shape a s1 p1 -> j2 \In shape a s2 p2 -> 
          [/\ j1 = j2, h1 = h2, s1 = s2 & p1 = p2].
Proof.
move=>D E S1 S2.
move: S1 S2 D E=>[/= b1][-> _ _ -> _][/= b2][-> _ _ -> _] D.
by heap_cancel=>// _ -> -> -> ->.
Qed.

Definition rreadable (aa : d alice) : Pred (d heap) := 
  [Pred ii | exists ss : d nat, exists pp : d nat, 
             ii = (salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 :+ 
                     flag aa.1 :-> true, 
                   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 readableP a (s p : nat) (f : bool) : 
        def (salary a :-> s :+ passwd a :-> p :+ flag a :-> f) -> 
        salary a :-> s :+ passwd a :-> p :+ flag a :-> f \In readable a -> f.
Proof. by move=>D [s1][p1][]; heap_cancel. Qed. 

Program 
Definition new (s : nat) (p : nat) : 
  STsec [::] alice 
    (fun i => True, 
     fun aa ii mm => exists ss, exists pp, exists hh, 
                       mm = ii :++ hh /\ hh \In sshape aa ss pp) :=
  Do (halloc @ [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 !sauto=>?.
move=>i1 i2 _ _ _ _; vauto=>x1 x2; vauto=>y1 y2; vauto=>f1 f2.
vauto=>_ _ _ _ _ _ _ _ _.
exists (s, s); exists (p, p). 
rewrite !(push x1) !(push x2) !(push y1) !(push y2) !(push f1) !(push f2).
eexists (_, _); split; first by rewrite /plus2 /=.
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 yy ii mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
         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 yy ii 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][]] /=.
- move=>i [s][p][j][h][->][->][[/= f1 f2]][-> _ _ -> _].
  by rewrite -!unA; sauto. 
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[[]]]] -> -> [-> ->][[/= g1 g2]][-> ->] -> -> -> _ _ _ _.
by rewrite -!unA; vauto.
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s][p][j][h][->][[[/= f1 f2]]][-> _ _ -> _] E.
  rewrite -!unA; sauto.
  apply: sval_do=>/=; move=>D; move: (D).
  rewrite !unA in D; move/defUnl: D; rewrite -!unA unC=>D.  
  move/(readableP D): E=>F.
  exists s; exists p; rewrite 2!(push (flag a)) !unA.
  by eexists _; eexists _; do !split=>//; exists (f2, f2).
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[->->]] S; case/srefl: (S)=>/= S1 S2. 
case=>s3 [p3][j3][h3][H3][S3] R3 [s4][p4][j4][h4][H4][S4] R4 D3 D4.
case: {H3 S3} (shape_inv D3 H3 S1 S3) R3=><- _ _ _ R1.
case: {H4 S4} (shape_inv D4 H4 S2 S4) R4=><- _ _ _ R2.
case: {D3} S1 (defUnl D3) R1=>[[f1 f2]] /= [-> _ _ -> _] D3.
move/(readableP D3)=>-> {f1 f2 D3}.
case: {D4} S2 (defUnl D4) R2=>[[f1 f2]] /= [-> _ _ -> _] D4.
move/(readableP D4)=>-> {f1 f2 D4}.
case: S=>/= _ [_ _ -> _ ->].
rewrite -!unA; vauto; apply: val_do=>[|y1 y2 m1 m2] /=.
- split; exists s2; exists p2; 
  [rewrite 2!(push (flag a1)) !unA | rewrite 2!(push (flag a2)) !unA];
  by do 2![eexists _]; do 2![split=>//]; exists (true, true).
have L : (salary a1 :-> s2 :+ passwd a1 :-> p2 :+ flag a1 :-> true,
          salary a2 :-> s2 :+ passwd a2 :-> p2 :+ flag a2 :-> true) \In
          sshape (a1, a2) (s2, s2) (p2, p2) by exists (true, true).
rewrite 2!(push (flag a1)) 2!(push (flag a2)) !unA.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _) (erefl _) L).
by case=>[[-> ->]][-> ->].
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 yy ii 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:Type; 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 yy ii 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]][-> _ _ -> _]; rewrite -!unA.
  by case: ifP=>E; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=. 
case=>[[[-> ->]]] -> [[/= f1 f2]][-> -> -> -> ->].
case=>s3 [p3][j3][h3][H3] S3.
case=>s4 [p4][j4][h4][H4] S4; move/defUnl=>D1; move/defUnl=>D2. 
rewrite -!unA; case: ifP=>E; vauto=>_ _; rewrite !unA.
- eexists (_, _); eexists (s, s); rewrite /plus2=>/=; do 2![split=>//].
  - by exists (f2, f2).
  case/rrefl=>/= R _; case/(readableP D1): R=>->.
  by exists (s, s); exists (p2, p2).
eexists (_, _); exists (s2, s2)=>/=; rewrite /plus=>/=.
by do !split=>//; exists (f2, f2).
Qed.
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s'][p'][j][h][->][[/= f1 f2]][-> _ _ -> _]; rewrite -!unA.
  sauto; apply: sval_do=>/=; rewrite unCA !unA. 
  by do 4![eexists _]; split=>//; exists (f2, f2).
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[-> ->]][[/= f1 f2]][-> -> -> -> ->] _ _ _ _.
rewrite -!unA; vauto.
apply: val_do=>[|_ _ m1 m2] /=. 
- by split; rewrite unCA !unA; do 4![eexists _]; split=>//; exists (f2, f2).
rewrite (push (passwd a1)) (push (passwd a2)) 4!unA.
move/(_ (s2, s2) (p2, p2) (_, _) (_, _) (erefl _) (erefl _)).
move=>H _ _; rewrite (push (passwd a1)) (push (passwd a2)) 2!unA.
by 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 yy ii 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]][-> _ _ -> _]; rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[-> ->]][[/= f1 f2]][-> -> -> -> ->] _ _ _ _; rewrite -!unA.
vauto=>_ _; rewrite !unA; eexists (_, _); rewrite /plus2 /=; do !split=>//.
by exists (f2, f2)=>/=; rewrite (push (passwd a1)) (push (passwd a2)).
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 yy ii 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][]] /=.
- move=>i [s][p][j][h][->][[/= f1 f2]][-> _ _ -> _].
  by rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[->->]][[f1 f2]] /= [-> -> -> -> ->] _ _ _ _.
rewrite -!unA; vauto=>_ _; rewrite 2!(push (flag a1)) 2!(push (flag a2)) !unA.
eexists (_, _); rewrite /plus2 /=; do 2!split=>//.
- by exists (true, true).
by exists (s2, s2); exists (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 yy ii 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) := 
  Do (write @@ (fun a => [flag a, false])). 
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][][a2][]] /=.
- move=>i [s][p][j][h][->][[[/= f1 f2]]][-> _ _ -> _] _.
  by rewrite -!unA; sauto.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]][[/= f1 f2]][-> -> -> -> ->] _ _ _ _.
rewrite -!unA; vauto=>_ _; rewrite 2!(push (flag a1)) 2!(push (flag a2)) !unA.
eexists (_, _); rewrite /plus2 /=; do !split=>//.
by exists (false, false).
Qed.

Section Endorse.
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 endorse (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 yy ii mm => 
            forall 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 yy ii 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.
  sauto; apply: sbnd_do=>[|y m] /=.  
  - rewrite -unA; exists s; exists p; do 2![eexists _]; split=>//.
    by 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). 
  rewrite -unA; move/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) L).
  case=>[[j1' j2']][[-> E]][H1] H2.
  sauto; apply: sval_do=>/=.
  exists j1'; split; first by case/rrefl: H2.
  exists s; exists p; exists k; exists t; exists h; rewrite unA.
  by 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 _ _ _ _.
vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=.
- split; case/srefl: H1=>/= H1 L1; rewrite -unA.
  - by exists s1; exists p1; eexists _; eexists _.
  by exists s2; exists p2; eexists _; eexists _.
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.
vauto.
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; exists p1; exists k1; hhauto.
  by exists j2'; split=>//; exists s2; exists p2; exists k2; hhauto.
move/(_ (j1', j2') (s1, s2) (p1, p2) (k1, k2) (t1, t2) (h1, h2))=>P _ _.
by apply: P=>//; rewrite !unA.
Qed.

End Endorse.

End Alice21.

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

(* 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.endorse (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.
  sauto; apply: sbnd_do=>[|y m] /=; first by eauto 10. 
  case/(_ _ _ (j, j) (h, h) (erefl _) H2)=>[[-> _]][-> _].
  by sauto. 
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[->->]]] S [-> ->]; case/Alice2.srefl: (S)=>/= S1 S2.
case=>j3 [R3][s3][p3][_][t3][h3][H3] S3 [E3] _.
case=>j4 [R4][s4][p4][_][t4][h4][H4] S4 [E4] _ D3 D4.
rewrite {t3}E3 {t4}E4 !unh0 in D3 D4 H3 H4 *.
case: {H3 S3} (Alice2.shape_inv D3 H3 S1 S3) R3=><- _ _ _ R1.
case: {H4 S4} (Alice2.shape_inv D4 H4 S2 S4) R4=><- _ _ _ R2.
vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=.
- by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S)=>[[-> ->]][-> ->].
by vauto=>_ _; 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 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.endorse (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.
  sauto; apply: sbnd_do=>[|y m] /=; first by eauto 10.
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2)=>[[-> _]][-> _].
  by sauto.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
case=>[[[->->]]] S [/= -> ->]; case/Alice2.srefl: (S)=>/= S1 S2.
case=>j3 [R3][s3][p3][k3][t3][h3][H3] S3 [/= E3 _].
case=>j4 [R4][s4][p4][k4][t4][h4][H4] S4 [/= E4 _] D3 D4.
rewrite {t3}E3 {t4}E4 -!unA in D3 D4 H3 H4 *.
case: {H3 S3} (Alice2.shape_inv D3 H3 S1 S3) R3=><- _ _ _ R1.
case: {H4 S4} (Alice2.shape_inv D4 H4 S2 S4) R4=><- _ _ _ R2.
move/defUnr: D3; move/defUnl=>D. 
vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S)=>[[-> ->]][-> ->].
vauto=>_ _; rewrite !unA -(unC j1) -(unC j2).
exists (j1, j2); exists (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 forces erasure *)

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.endorse (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.
  sauto; apply: sbnd_do=>[|y m] /=; first by eauto 10.
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2)=>[[-> _]][-> _].
  by sauto.
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
case=>[[[->->]]] S [/= -> ->]; case/Alice2.srefl: (S)=>/= S1 S2.
case=>j3 [R3][s3][p3][k3][t3][h3][H3] S3 [/= E3 _].
case=>j4 [R4][s4][p4][k4][t4][h4][H4] S4 [/= E4 _] D3 D4.
rewrite {t3}E3 {t4}E4 -!unA in D3 D4 H3 H4 *.
case: {H3 S3} (Alice2.shape_inv D3 H3 S1 S3) R3=><- _ _ _ R1.
case: {H4 S4} (Alice2.shape_inv D4 H4 S2 S4) R4=><- _ _ _ R2.
move/defUnr: D3; move/defUnl=>D. 
vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S)=>[[-> ->]][-> ->].
vauto=>_ _; rewrite !unA -(unC j1) -(unC j2).
exists (j1, j2); exists (b1 :-> k1.+1, b2 :-> k2.+1); do !split=>//=.
by move=>E; case/(pts_injP D): E (E)=><- _; case/(pts_inj D)=><-.
Qed.
 
End ErasingClient.
