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

(*******************************)
(* A file with random examples *)
(*******************************)

(* let's try some loops *)
(* first the infinite loop *)

Program 
Definition diverge0 A : ST [::] A := 
  Fix id : STsec [::] A (fun i => True, fun y i m => False).
Next Obligation. by apply: id_cont. Qed.

Implicit Arguments diverge0 [A].

Program
Definition diverge As A : 
  STsec As A (fun_lam (fun g i => True), 
              dfun_lam (fun gg ii yy mm => False)) :=
  Do (diverge0 @ (fun_lam (fun g => tt))).
Next Obligation.
split=>[a i _|a1 a2 i1 i2 _ _].
- by apply: sval_do; rewrite /= instE fun_beta.
apply: val_do=>[|y1 y2 m1 m2]; first by rewrite /= instE /= !fun_beta.
by rewrite /= instE /= dfun_beta.
Qed.

Implicit Arguments diverge [As A].

(* computing factorial *)

Fixpoint fact (n : nat) : nat := 
  if n is n'.+1 then n * fact n' else 1.

Definition fact_s : spec [::: nat] nat := 
  (fun n i => True, 
   fun nn ii yy mm => mm = ii /\ yy = (fact nn.1, fact nn.2)).

Program Definition factorial := 
  Fix (fun loop : STsec [::: nat] nat fact_s => 
         Ifbool (fun n => n == 0) then 
           ret @ (fun n => [1])
         else
           hide loop @ (fun n => [n - 1]);;
           ret @ (fun x n => [n * x]) 
         with [::: nat], nat, fact_s).
Next Obligation.
split=>[[n][]|[n1][][n2][]] /=.
- move=>i _; case: n=>[|n] /=; first by sstep.
  by ssimpl; apply: sbnd_do=>//= y m _; sstep.
move=>i1 i2 _ _; case: n1; case: n2=>/=.
- by v2step.
- move=>n; apply/vrfS1; vstep=>_; vsimpl.
  by apply: bnd_doV=>//= y m [[-> _]][-> _]; vstep; rewrite subn1.
- move=>n; apply/vrfS2; vstep=>_; vsimpl.
  by apply: bnd_doV=>//= y m [[-> _]][-> _]; vstep; rewrite subn1.
move=>n1 n2; v2simpl.
apply: bnd_do=>//= y1 y2 m1 m2 [[->->]][->->].
by v2step; rewrite !subn1.
Qed.
Next Obligation.
apply: if_bool_cont; first by apply: const_stcont.
apply: bind_stcont; last by apply: const_stcont.
by apply: inst_stcont; apply: hide_stcont; apply: id_cont.
Qed.

(* ok, reasoning about continuity works *)
(* more loops will be given in other files; check llist *)
(* now we move to information flow properties *)

(* the example from Simonet *)
(* shows nested conditionals. in the example below, *)
(* we can specify that the output of the function *)
(* is dependent only on x and z, not on y *)

Section Simonet.
Variables a b c d : bool.

Definition simonet_s1 : spec [::: bool; bool; bool] bool := 
  (fun x y z i => True,
   fun xx yy zz ii rr mm => 
     rr = (if yy.1 then a else b, if yy.2 then a else b)).

Definition simonet_s2 : spec [::: bool; bool; bool] bool := 
  (fun x y z i => True,
   fun xx yy zz ii rr mm => 
     rr = (if zz.1 then a else d, if zz.2 then a else d)).

Definition simonet_s3 : spec [::: bool; bool; bool] bool :=
  (fun x y z i => True,
   fun xx yy zz ii rr mm => 
     rr = (if xx.1 then if yy.1 then a else b else 
             if zz.1 then a else d, 
           if xx.2 then if yy.2 then a else b else 
             if zz.2 then a else d)).

Definition simonet_s4 : spec [::: bool; bool; bool; bool] bool :=
  (fun t x y z i => True,
   fun tt xx yy zz ii rr mm => 
     tt = (if xx.1 then if yy.1 then a else b else 
             if zz.1 then a else d, 
           if xx.2 then if yy.2 then a else b else 
             if zz.2 then a else d) -> 
     if (a == d) || (b == d) then rr = (true, true) 
     else rr = (xx.1 || zz.1, xx.2 || zz.2)).

Program 
Definition simonet :
  STsec [:: bool; bool; bool] bool
    (fun x y z i => True, 
     fun xx yy zz ii rr mm => 
       rr = ((a == d) || (b == d) || xx.1 || zz.1,
             (a == d) || (b == d) || xx.2 || zz.2)) :=
  Do (Ifbool (fun x y z => x) then 
        Ifbool (fun x y z => y) then 
          ret @ (fun x y z => [a]) else ret @ (fun x y z => [b])
        with [::: bool; bool; bool], bool, simonet_s1
      else 
        Ifbool (fun x y z => z) then 
          ret @ (fun x y z => [a]) else ret @ (fun x y z => [d])
        with [::: bool; bool; bool], bool, simonet_s2
      with [::: bool; bool; bool], bool, simonet_s3;;
      Ifbool (fun t x y z => (t == a) || (t == b)) then 
        ret @ (fun t x y z => [true])
      else ret @ (fun t x y z => [false])
      with [::: bool; bool; bool; bool], bool, simonet_s4).
Next Obligation.
split=>[[x][y][z][]|[x1][y1][z1][][x2][y2][z2][]] /=.
- by move=>i _; case: y; sstep.
by move=>i1 i2 _ _; case: y1; case: y2; v2step.
Qed.
Next Obligation.
split=>[[x][y][z][]|[x1][y1][z1][][x2][y2][z2][]] /=.
- by move=>i _; case: z; sstep.
by move=>i1 i2 _ _; case: z1; case: z2; v2step.
Qed.
Next Obligation.
split=>[[x][y][z][]|[x1][y1][z1][][x2][y2][z2][]] /=.
- by move=>i _; case: x; apply: sval_do. 
move=>i1 i2 _ _; case: x1; case: x2; first by [apply: val_do];
apply/vrfS1; apply: val_doV=>//= y m [-> _] _; 
by apply: val_doV=>//= z n [-> _].
Qed.
Next Obligation.
rewrite !gh; split=>[[t][x][y][z][]|[t1][x1][y1][z1][][t2][x2][y2][z2][]] /=.
- by move=>i _; case: ifP=>_; sstep.
move=>i1 i2 _ [->->] _ _; rewrite -2!(eq_sym d).
case: ifP=>H1; v2simpl; case: ifP=>H2; v2step; case: ifP=>E; move: E H1 H2;
case: x1; case: x2; case: y1; case: y2; case: z1; case: z2;
by rewrite 2?eq_refl //= 1?orbT //; move=>->.
Qed.
Next Obligation.
split=>[[x][y][z][]|[x1][y1][z1][][x2][y2][z2][]] /=.
- move=>i _; ssimpl; apply: sbnd_do=>//= y1 m1 [-> _]; 
  by ssimpl; apply: sval_do. 
move=>i1 i2 _ _.
v2simpl; apply: bnd_do=>//= y3 y4 m1 m2 [-> ->].
v2simpl; apply: val_do=>//= y5 y6 m3 m4.
by move/(_ (erefl _)); case: ifP=>E [-> ->].
Qed.

End Simonet.

Definition silly0_s : spec [::: bool] ptr := 
  (fun h i => True,
   fun hh ii yy mm => mm = ii :++ (yy.1 :-> 2, yy.2 :-> 2) /\ 
                     (ii.1 =~ ii.2 -> yy.1 = yy.2)).

Program
Definition silly0 : STsec [::: bool] ptr silly0_s :=
  Ifbool (fun h => h) then 
    lalloc @ (fun h => [2]);;
    ret @ (fun z h => [z])
  else 
    halloc @ (fun h => [1]);;
    lalloc @ (fun y h => [2]);;
    dealloc @ (fun z y h => [y]);;
    ret @ (fun _ z y h => [z]) 
  with [::: bool], ptr, silly0_s.
Next Obligation.
split=>[[h][]|[h1][][h2][]] /=.
- by move=>i _; case: h; [|sstep=>y]; sstep=>z; sstep.
move=>i1 i2 _ _; case: h1; case: h2.
- by v2step=>z1 z2; v2step=>_ _ L _; rewrite unC2; split=>//; case/L.
- apply/vrfS2; vstep=>y H; apply: vrfD=>D; apply/vrfS2.
  v2step=>z1 z2; apply/vrfS2; do 2![vstep=>_].
  by rewrite un0h unC2 !(low_sym i1) -(highPtUn _ D H)=>E; split=>//; case/E.
- apply/vrfS1; vstep=>y H; apply: vrfD=>D; apply/vrfS1.
  v2step=>z1 z2; apply/vrfS1; do 2![vstep=>_].
  by rewrite un0h unC2 -(highPtUn _ D H)=>E; split=>//; case/E.
v2step=>y1 y2; apply: vrf2D=>D1 D2; v2step=>z1 z2; v2step=>_ _ L H1 H2 _.
by rewrite !un0h unC2; split=>//; move/(highPtUn2 D1 D2 H1 H2); case/L.
Qed.

(* example from Terauchi and Aiken *)
(* demonstrates handling of implicit flows *)

Fixpoint public (ls : seq ptr) : Pred (d heap) :=
  if ls is l::ls then 
    fun i => look l i.1 = look l i.2 /\ public ls i
  else PredT.

Lemma public_refl ls i : public ls (i, i).
Proof. by elim: ls. Qed.

Hint Resolve public_refl. 

Section Silly.
Variables x y z h l : ptr.

Definition silly_s1 : spec [::: bool; unit] unit :=
    (fun _ _ i => exists u:nat, exists j, exists h, 
                    i = j :+ h /\ j = x :-> u, 
     fun bb _ ii yy mm=> 
       forall (uu : d nat) jj hh, 
         ii = jj :++ hh -> jj = (x :-> uu.1, x :-> uu.2) ->
         exists jj', mm = jj' :++ hh /\ 
           jj' = (if bb.1 then x :-> 1 else jj.1, 
                 (if bb.2 then x :-> 1 else jj.2))).

Definition silly_s2 : spec [::: unit; bool; unit] unit := 
  (fun _ _ _ i => exists u:nat, exists j, exists h, 
                    i = j :+ h /\ j = x :-> u :+ z :-> 1, 
   fun _ bb _ ii yy mm=> 
     forall (uu : d nat) jj hh, 
       ii = jj :++ hh -> jj = (x :-> uu.1 :+ z :-> 1, x :-> uu.2 :+ z :-> 1) ->
       exists jj', mm = jj' :++ hh /\ 
         jj' = (if ~~ bb.1 then x :-> 1 :+ z :-> 1 else jj.1, 
                if ~~ bb.2 then x :-> 1 :+ z :-> 1 else jj.2)).

Program
Definition silly :
  STsec [:::] unit
    (fun i => 
       exists f, exists u:nat, exists v:nat, 
       exists w:nat, exists b:bool, exists c:nat, 
         i = x :-> u :+ y :-> v :+ z :-> w :+ h :-> b :+ l :-> c :+ f, 
     fun i r m => public [:: l; y] i -> public [:: l; y] m) :=
  Do (write @ [z, 1];;
      read bool @ (fun _ => [h]);;
      Ifbool (fun b _ => b) then 
        write @ (fun b _ => [x, 1])
      else ret @ (fun b _ => [tt])
      with [::: bool; unit], unit, silly_s1;;
      Ifbool (fun _ b _ => ~~ b) then 
        read nat @ (fun _ _ _ => [z]);;
        write @ (fun w _ _ _ => [x, w])
      else ret @ (fun _ _ _ => [tt]) 
      with [::: unit; bool; unit], unit, silly_s2;;
      read nat @ (fun _ _ b _ => [x]);;
      read nat @ (fun u _ _ b _ => [y]);;
      write @ (fun v u _ _ b _ => [l, u + v]);;
      ret @ (fun _ v u _ _ b _ => [tt])).
Next Obligation.
rewrite !gh; split.
- by case=>b g i [u][j][k][->] ->; case: b; sstep.
case=>b1 g1 [b2 g2] i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /= [->->][->->] _ _.
by case: b1; case: b2; apply/vrfS1; do 2![vstep=>_]; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- by move=>[[]][b][[][]] i [u][j][k][->->]; case: b; sstep. 
case=>[[]][b1][[][]][[]][b2][[][]] i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /=.
case=>[->->][->->] _ _; apply/vrfS1.
by case: b1; case: b2; do 2![vstep=>_]; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- move=>[] i [f][u][v][w][b][c] ->; sstep; ssimpl.
  apply: (sbndO1 (x:->_))=>//= [[j]][->] _; ssimpl. 
  rewrite /= -(unAC _ (z :-> _)). 
  by case: b; apply: (sbndO1 (x:->_ :+ z:->_))=>//= [[j']][->] _; sstep.
move=>[][] i1 i2 _ [E1][E2] _.
move=>[h1][u1][v1][w1][b1][c1] X1 [h2][u2][v2][w2][b2][c2] X2.
apply: vrf2D=>D1 D2; move: E1 E2; rewrite {i1}X1 {i2}X2 in D1 D2 *.
rewrite !lookPtUnO {D1 D2} //; do 2![move/dyn_inj=>->].
v2step; apply: v2simpl=>/=.
apply: (bnd2O1 (x:->_) (x:->_))=>//= [[[]]] j1' j2' [->->] /=.
rewrite /= -2!(unAC _ (z :-> _)); apply: v2simpl=>/=. 
case: b1; case: b2; 
apply: (bnd2O1 (x:->_ :+ z:->_) (x:->_ :+ z:->_))=>//=;
by case=>[][] _ _ /= [->->]; v2step=>D1 D2; rewrite !lookPtUnO.
Qed.

End Silly.

(* locations can be private, but their contents can be public *)

Definition silly2_s1 : 
             spec [::: bool; unit; ptr; ptr; ptr; ptr; ptr] unit :=
  (fun b _ x y z h l i => exists u:nat, exists j, exists k, 
                            i = j :+ k /\ j = x :-> u, 
   fun bb _ xx yy zz hh ll ii yy mm => 
     forall (uu : d nat) jj kk, 
       ii = jj :++ kk -> jj = (xx.1 :-> uu.1, xx.2 :-> uu.2) ->
       exists jj', mm = jj' :++ kk /\
         jj' = (if bb.1 then xx.1 :-> 1 else jj.1, 
                if bb.2 then xx.2 :-> 1 else jj.2)).

Definition silly2_s2 : 
             spec [::: unit; bool; unit; ptr; ptr; ptr; ptr; ptr] unit :=
  (fun _ b _ x y z h l i => exists u:nat, exists j, exists k, 
                              i = j :+ k /\ j = x :-> u :+ z :-> 1, 
   fun _ bb _ xx yy zz hh ll ii yy mm => 
     forall (uu : d nat) jj kk, 
       ii = jj :++ kk -> 
       jj = (xx.1 :-> uu.1 :+ zz.1 :-> 1, xx.2 :-> uu.2 :+ zz.2 :-> 1) ->
     exists jj', mm = jj' :++ kk /\
       jj' = (if ~~ bb.1 then xx.1 :-> 1 :+ zz.1 :-> 1 else jj.1, 
              if ~~ bb.2 then xx.2 :-> 1 :+ zz.2 :-> 1 else jj.2)).

Program
Definition silly2 : 
  STsec [::: ptr; ptr; ptr; ptr; ptr] unit 
    (fun x y z h l i => 
       exists f, exists u:nat, exists v:nat, 
       exists w:nat, exists b:bool, exists c:nat, 
         i = x :-> u :+ y :-> v :+ z :-> w :+ h :-> b :+ l :-> c :+ f, 
       fun x y z h l i r m => 
         look l.1 i.1 = look l.2 i.2 -> look y.1 i.1 = look y.2 i.2 -> 
         look l.1 m.1 = look l.2 m.2 /\ look y.1 m.1 = look y.2 m.2) :=
 Do (write @ (fun x y z h l => [z, 1]);;
     read bool @ (fun _ x y z h l => [h]);;
     Ifbool (fun b _ x y z h l => b) then 
       write @ (fun b _ x y z h l => [x, 1])
       else ret @ (fun b _ x y z h l => [tt]) 
     with [::: bool; unit; ptr; ptr; ptr; ptr; ptr], unit, silly2_s1;;
     Ifbool (fun _ b _ x y z h l => ~~ b) then 
       read nat @ (fun _ _ _ x y z h l => [z]);;
       write @ (fun w _ _ _ x y z h l => [x, w])
     else ret @ (fun _ _ _ x y z h l => [tt]) 
     with [::: unit; bool; unit; ptr; ptr; ptr; ptr; ptr], unit, silly2_s2;;
     read nat @ (fun _ _ b _ x y z h l => [x]);;
     read nat @ (fun u _ _ b _ x y z h l => [y]);;
     write @ (fun v u _ _ b _ x y z h l => [l, u + v]);;
     ret @ (fun _ v u _ _ b _ x y z h l => [tt])).
Next Obligation.
rewrite !gh; split=>/=.
- by case=>b [[]][x][y][z][h][l][] i [u][j][k][->] ->; case: b; sstep.
case=>b1 [[]][x1][y1][z1][h1][l1][[]] b2 [[]][x2][y2][z2][h2][l2][].
move=>i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /= [->->][->->] _ _.
by case: b1; case: b2; apply/vrfS1; do 2![vstep=>_]; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- by case=>[[]][b][[]][x][y][z][h][l][] i [u][j][k][->->] /=; case: b; sstep.
case=>[[]][b1][[]][x1][y1][z1][h1][l1][][[]][b2][[]][x2][y2][z2][h2][l2][].
move=>i1 i2 [[[[]]]][u1 u2][j1 j2][k1 k2][] /=.
case=>[->->][->->] _ _; apply/vrfS1.
by case: b1; case: b2; do 2![vstep=>_]; eexists (_, _).
Qed.
Next Obligation.
rewrite !gh; split=>/=.
- case=>x [y][z][h][l][] i [f][u][v][w][b][c] /= ->.
  sstep; ssimpl; apply: (sbndO1 (x:->_))=>//= [[j]][-> _].
  ssimpl; rewrite /= -(unAC _ (z :-> _)). 
  by case: b; apply: (sbndO1 (x:->_ :+ z:->_))=>//= [[j']][->] _; sstep.
case=>x1 [y1][z1][h1][l1][][x2][y2][z2][h2][l2][] i1 i2 [] /= [E1 E2].
move=>[f1][u1][v1][w1][b1][c1] X1 [f2][u2][v2][w2][b2][c2] X2.
apply: vrf2D=>D1 D2; move: E1 E2; rewrite {i1}X1 {i2}X2 in D1 D2 *.
rewrite !lookPtUnO {D1 D2} //; do 2![move/dyn_inj=>->].
v2step; apply: v2simpl=>/=.
apply: (bnd2O1 (x1:->_) (x2:->_))=>//= [[[]]] j1' j2' [->->] /=.
rewrite /= -(unAC _ (z1:->_)) -(unAC _ (z2:->_)); apply: v2simpl=>/=. 
case: b1; case: b2; 
apply: (bnd2O1 (x1:->_ :+ z1:->_) (x2:->_ :+ z2:->_))=>//=;
by case=>[][] _ _ /= [->->]; v2step=>D1 D2; rewrite !lookPtUnO.
Qed.

(* Heap locations can be declared public not only by stating the
equality of their contents in the two heaps, but by stating something
that implies this equality. The program below exemplifies this; in the
spec we have a hypothesis that the sum of the two variables x and y
must be 0 in both heaps, hence implying that x and y must be equal to
0. since their values are equal (and equal to 0) in the input heaps,
both x and y must be public.  *)

Program 
Definition silly3 (x y : ptr) : 
   STsec [:::] nat 
     (fun i => exists h, exists v:nat, exists w:nat, 
                 i = x :-> v :+ y :-> w :+ h,
      fun i z m => forall (h : d heap) (v w : d nat), 
        i.1 = x :-> v.1 :+ y :-> w.1 :+ h.1 -> 
        i.2 = x :-> v.2 :+ y :-> w.2 :+ h.2 -> 
        v.1 + w.1 = v.2 + w.2 -> 
        v.1 + w.1 = 0 -> m = i /\ z = (0, 0)) :=
   Do (read nat @0 [x];;
       read nat @ (fun v1 => [y]);;
       ret @ (fun v2 v1 => [v1])).
Next Obligation.
rewrite !gh /=; split=>[[]|[][]]; first by move=>i [h][v][w] ->; sstep.
move=>i1 i2 [[[[]]]][f1 f2][v1 v2][w1 w2] /= [[[-> ->]]] E1 E2 _ _.
v2step=>_ _; rewrite E2 in E1; move/eqP: (esym E1); move/eqP: E2.
by rewrite !addn_eq0; do 2![case/andP; move/eqP=>-> _].
Qed.

(* another example with polynomials *)
Definition sgn (x : nat) : nat := if x > 0 then 1 else 0.

Program
Definition poly : 
  STsec [::: nat; nat; nat; nat] nat 
    (fun a b c x i => True,
     fun a b c x i y m => 
       sgn (a.1*x.1*x.1 + b.1*x.1 + c.1) = 
       sgn (a.2*x.2*x.2 + b.2*x.2 + c.2) -> y.1 = y.2) :=
  Do (ret @ (fun a b c x => [sgn (a*x*x + b*x + c) + 1])).
Next Obligation.
rewrite !gh; split=>/=; first by case=>a [b][c][x][] i _; sstep.
case=>a1 [b1][c1][x1][][a2][b2][c2][x2][] /=.
by move=>i1 i2 _ E _ _; v2step=>_ _; rewrite E.
Qed.

(* A number of examples about granting access to locations, and hiding *)
(* The examples here are done in an "object-oriented" fashion *)
(* In the alice.v file, the examples are redone to match the paper *)

(* Access to a location can be controled by means of a type system in a *)
(* fairly standard way. To grant read access, but not write access to a *)
(* location, simply hide the location by means of type and predicate *)
(* abstraction, and export a function for reading this location in the *)
(* module interface. The following example does just that. It does not *)
(* have much to do with information leakage, but it illustrates other *)
(* features, such as access control via types. *)

Structure alice : Type :=
  Alice {shape : nat -> Pred heap; 
         get_secret : 
           STsec [:::] nat 
             (fun i => exists v, exists j, exists h,
                         i = j :+ h /\ j \In shape v,
              fun ii yy mm => forall vv jj hh, 
                ii = jj :++ hh -> 
                [/\ jj.1 \In shape vv.1 & jj.2 \In shape vv.2] ->
              exists jj', mm = jj' :++ hh /\ 
                [/\ jj'.1 \In shape vv.1, jj'.2 \In shape vv.2 & yy = vv])}.

Program
Definition new_alice (secret : nat) : 
  STsec [:::] alice 
    (fun i => True, 
     fun ii yy mm => exists jj, mm = jj :++ ii /\
       [/\ jj.1 \In shape yy.1 secret & jj.2 \In shape yy.2 secret]) :=
  Do (halloc @ [secret];;
      ret @ (fun x => [@Alice (fun n i => i = x :-> n)
                              (Do (read nat @0 [x];; 
                                   ret @ fun y => [y]))])). 
Next Obligation.
rewrite !gh; split=>[[]|[][]] /=; first by move=>i [v][j][h][->][->]; sstep.
move=>i1 i2 [[[[]]]][v1 v2][j1 j2][h1 h2] /= [[->->]][[->]][->] _ _.
by v2step=>_ _; eexists (_, _).
Qed.
Next Obligation.
split=>[[]|[][]]; first by move=>i _; sstep=>x; sstep.
by move=>i1 i2 _ _; v2step=>x1 x2; v2step; eexists (_, _).
Qed.

(* Now, someone trying to access alice's local store, can do so only via *)
(* a call to get_secret, as alice's shape predicate is abstracted. It is *)
(* important to understand how this abstraction came to be, as this *)
(* illustrates one of the main properties of the system, namely, the Do *)
(* construct. *)

(* Notice that the computation of new returns a fresh alice structure, *)
(* which is actually a dependent pair including get_secret, and a *)
(* predicate describing the shape of alice's local state. In principle, *)
(* if dependent pairs were all there was to this program, we would have *)
(* not actually achieved any information hiding, because one can project *)
(* out the components of a dependent pair, and hence access the *)
(* supposedly abstracted shape predicate. *)

(* But here, the construction of the alice structure occurs in a monadic *)
(* computation, in the scope of the Do construct. Because the logic and *)
(* the implementation do not expose the semantics of Do (notice that Do's *)
(* definition is deliberately made opaque in the stcont.v file), the only *)
(* knowledge that the clients of new will have about the returned alice *)
(* value is that it satisfies the Alice type. Nothing else is exported *)
(* about this value; in particular, clients will have to treat alice's *)
(* shape predicate as an un-interpreted function. As a consequence, the *)
(* clients can only use the get_secret function to read alice's secret, *)
(* but they can't do anything else, and in particular, they can't write *)
(* into alice's secret location because writing requires first deriving *)
(* out of this shape predicate that the written location is allocated. *)

(* For example, in the program and the proof below, one can try to unfold *)
(* the definition of shape, but that will not reveal any information *)
(* beyond alice's spec. *)

Program 
Definition do_the_read : 
  STsec [:::] nat (PredT, fun i y m => y.1 = y.2) := 
  Do (new_alice 0;;
      localize get_secret @ (fun a => [a])).
Next Obligation.
split=>[[] i _|[][] i1 i2 _ _] /=.
- ssimpl; apply: sbnd_do=>//= y m [[j1 j2]][[-> _]][/= H1 _].
  by ssimpl; apply: sval_do=>/=; eauto. 
v2simpl; apply: bnd_do=>// y1 y2 m1 m2 [[j1 j2]][[->->]][/= H1 H2].
v2simpl; apply/vrfS1; apply: val_doV=>[|v1 n1] /=; first by eauto.
case/(_ (erefl _) (0, 0) (_, _) (_, _) (erefl _) (conj H1 H1))=>/=.
move=>k [_][_ _][->] _ _; apply: val_doV=>[|v2 n2]=>/=; first by eauto.
case/(_ (erefl _) (0, 0) (_, _) (_, _) (erefl _) (conj H2 H2))=>/=.
by move=>k' [_][_ _][->].
Qed.

(* The above example illustrates that combining Do with dependent pairing *)
(* suffices to enforce predicate abstraction, which leads to enforcing *)
(* correct access control. We next give another important example of *)
(* using Do. *)

(* Notice that the type of do_the_read not only enforces access control, *)
(* but it also exposes the fact that alice's stored secret is equal to *)
(* the argument passed to new. In particular, the claimed secret is *)
(* actually clearly equal in both the runs of do_the_read, and is hence *)
(* public. *)

(* If we want to make alice's secret really secret, we have to hide the *)
(* later equality property upon creating instances of alice. This can be *)
(* done by using a different new function, as below, which hides the fact *)
(* that the stored secret actually equals the initially passed input.  *) 

Program 
Definition new_alice1 (secret : nat) : 
  STsec [:::] alice 
    (PredT, 
     fun ii yy mm => exists vv, exists jj, 
        [/\ mm = jj :++ ii, jj.1 \In shape yy.1 vv.1 & 
                            jj.2 \In shape yy.2 vv.2]) :=
  Do (new_alice secret).
Next Obligation.
split=>[[] i _|[][] i1 i2 _ _] /=; first by apply: sval_do.
apply: val_do=>// y1 y2 m1 m2 [[j1 j2]][[/= ->->]][H1 H2] _ _ _.
by exists (secret, secret); eexists (_, _).
Qed.

(* If alice is created by new1, clients accessing her secret via *)
(* get_secret, won't be able to prove that the obtained value is public. *)

Program
Definition do_the_read1 : 
  STsec [:::] nat (PredT, fun ii yy mm => yy.1 = yy.2) := 
  Do (new_alice1 0;; 
      localize get_secret @ (fun a => [a])).
Next Obligation.
split=>[[] i _|[][] i1 i2 _ _] /=.
- ssimpl; apply: sbnd_do=>// y m [[v _]][[j _]][[-> _]] /= H _.
  by ssimpl; apply: sval_do=>//=; eauto. 
v2simpl; apply: bnd_do=>// y1 y2 m1 m2 [[v1 v2]][[j1 j2]][[->->]] /= H1 H2.
v2simpl; apply/vrfS1; apply: val_doV=>[|z1 n1] /=; first by eauto 10.
case/(_ (erefl _) (v1, v1) (_, _) (_, _) (erefl _))=>//=.
case=>k1 k2 [[-> E1]] /= [H3 H4][-> _] _.
apply: val_doV=>[|z2 n2] /=; first by  eauto.
case/(_ (erefl _) (v2, v2) (_, _) (_, _) (erefl _))=>//=.
case=>l1 l2 [[-> E2]] /= [H5 H6][-> _] _.
(* can't push the proof through; the spec is not valid *)
(* as expected, we have to admit *)
admit.
Qed.

(* Alternativelly, we can expose that alice's secret equals the input of *)
(* new, but then make this input be secret. Clients who have already *)
(* managed to declassify the input will simply propagate this knowledge *)
(* forward. *)

Program 
Definition new_alice2 :
  STsec [::: nat] alice 
    (fun s i => True, 
     fun ss ii yy mm => exists jj, mm = jj :++ ii /\
       jj.1 \In shape yy.1 ss.1 /\ jj.2 \In shape yy.2 ss.2) :=
  Do (halloc @ (fun s => [s]);;
      ret @ (fun x s => [@Alice (fun n i => i = x :-> n)
                                (Do (read nat @0 [x];;
                                     ret @ (fun y => [y])))])).
Next Obligation.
rewrite !gh; split=>[[] i|[][]] /=.
- by case=>v [j][h][->][->]; sstep.
move=>i1 i2 [[[[]]]][v1 v2][j1 j2][h1 h2][[->->]][/= ->->] _ _. 
by v2step=>_ _; eexists (_, _).
Qed.
Next Obligation.
split=>[[s][] i _|[s1][][s2][] i1 i2 _ _] /=; first by sstep=>x; sstep.
by v2step=>x1 x2; v2step; eexists (_, _).
Qed.

(* Now, say alice wants to use somebody's program for managing secrets, *)
(* i.e., divide the secret by two. Alice wants to allow the managing *)
(* program to access the secret and modify it, but she wants to ensure *)
(* that her secret is not stolen. Let's say bob is a code provider, who *)
(* exports a secret-processing program to be run by instances of *)
(* alice. Bob wants to keep statistics on how many time his program has *)
(* been executed by alice. But, bob also wants to convince alice that his *)
(* program will not steal any of alices secret information. The next *)
(* example shows how these properties can be specified. *)

Structure bob : Type := 
  Bob {bshape : nat -> Pred heap;
       process : forall a, 
         STsec [:::] nat 
           (fun i => exists v, exists k, exists j, exists s, exists h, 
              [/\ i = j :+ s :+ h, j \In shape a v & s \In bshape k],
            fun ii yy mm => forall vv kk jj ss hh,
              ii = jj :++ ss :++ hh -> 
              [/\ jj.1 \In shape a vv.1 /\ jj.2 \In shape a vv.2 &
                  ss.1 \In bshape kk.1 /\ ss.2 \In bshape kk.2] ->
            exists jj', exists ss', 
              mm = jj' :++ ss' :++ hh /\
              [/\ jj'.1 \In shape a vv.1 /\ jj'.2 \In shape a vv.2 &
                  ss'.1 \In bshape kk.1.+1 /\ ss'.2 \In bshape kk.2.+1] /\
              yy = (vv.1./2, vv.2./2) /\
              (ii.1 =~ ii.2 -> ss.1 = ss.2 -> ss'.1 = ss'.2))}.

Program 
Definition new_bob :
  STsec [:::] bob 
    (fun i => True, 
     fun ii yy mm => exists jj, mm = jj :++ ii /\ 
       jj.1 \In bshape yy.1 0 /\ jj.2 \In bshape yy.2 0) :=
  Do (halloc @0 [0];; 
      ret @ (fun x => [@Bob (fun n i => i = x :-> n)
                            (fun a => 
                               Do(get_secret a;;
                                  read nat @ (fun y => [x]);;
                                  write @ (fun z y => [x, z.+1]);;
                                  ret @ (fun _ z y => [y./2])))])).
Next Obligation.
rewrite !gh; split=>[[]|[][]] /=.
- move=>i [v][k][j][s][h][->] H [->]; ssimpl; rewrite -unA.
  apply: sbnd_do=>[|y m] /=; first by eauto 10.  
  by case/(_ (v, v) (_, _) (_, _) (erefl _))=>// [[j1 j2]][[-> E]] _; sstep.
move=>i1 i2 [[[[[[]]]]]] /= [v1 v2][k1 k2][j1 j2][s1 s2][h1 h2] /= [].
case=>->-> [[H1 H2]][[->]][->] _ _; apply: vrf2D=>D _; v2simpl; rewrite -!unA.
apply: bnd_do=>[|y1 y2 m1 m2] /=; first by eauto 10.
case/(_ (v1, v2) (_, _) (_, _) (erefl _))=>// [[j1' j2']][[->->]][/= H3 H4].
case=>->->; v2step=>_ _; rewrite !unA /plus2.
eexists (_, _); eexists (_, _)=>/=; do !split=>//; move=>_. 
by case/(pts_inj (defUnr (defUnl D)))=>->.
Qed.
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; sstep=>x; sstep.
by move=>i1 i2 _ _; v2step=>x1 x2; v2step; eexists (_, _).
Qed.

(* If we were to leak some information from alice into bob's local state, *)
(* we wouldn't have been able to prove the spec. *)

(* Say, for example, that bob keeps his local counter not as one pointer, *)
(* but as two. The count it wants to return is the difference of the *)
(* two. if bob wants to steal some information from alice, he can do so *)
(* as follows, without violating the correctness spec (but he will *)
(* violate his information flow leakage spec). He can increment both her *)
(* counters with the value of alices secret. Because of the way bob *)
(* computes the count, the two values would cancel each other, so the *)
(* count will be kept correctly. However, after this has been done, *)
(* alice's secret is effectively written into bob's local state, and is *)
(* hence stolen. *)

Program 
Definition new_bob1 :
  STsec [:::] bob 
    (fun i => True, 
     fun ii yy mm => exists jj, mm = jj :++ ii /\
        jj.1 \In bshape yy.1 0 /\ jj.2 \In bshape yy.2 0) :=
  Do (halloc @0 [0];; 
      halloc @ (fun x1 => [0]);;
      ret @ (fun x2 x1 => 
            [@Bob (fun n i => 
                     exists c, i = x1 :-> c.1 :+ x2 :-> c.2 /\ 
                               n = c.1 - c.2 /\ c.2 <= c.1)
                  (fun a => 
                     Do (get_secret a;;
                         read nat @ (fun y => [x1]);;
                         read nat @ (fun z1 y => [x2]);;
                         write @ (fun z2 z1 y => [x1, z1.+1 + y]);;
                         write @ (fun _ z2 z1 y => [x2, z2 + y]);;
                         ret @ (fun _ _ z2 z1 y => [y./2])))])).
Next Obligation. 
rewrite !gh; split=>[[]|[][]] /=.
- move=>i [v][k][j][s][h][->] H [[c1 c2]][/= ->][_] _. 
  rewrite -unA; ssimpl; apply: sbnd_do=>[|y m] /=; first by eauto.
  case/(_ (v, v) (_, _) (_, _) (erefl _))=>// [[j1' j2']][[-> _]] /=.
  by case=>_ _ [-> _]; sstep.
move=>i1 i2 [[[[[[]]]]]][v1 v2][k1 k2][j1 j2][s1 s2][h1 h2] /= [].
case=>->-> [[H1 H2]][[c1]][->][->] E1 [c2][->][->] E2 /= _ _.
apply: vrf2D=>D _; rewrite -(unA j1) -(unA j2); v2simpl; apply: bnd_do=>//=. 
- by split; [eexists v1, _, _ | eexists v2, _, _]; split=>//.
move=>y1 y2 m1 m2.
case/(_ (v1, v2) (_, _) (_, _) (erefl _))=>// [[j1' j2']][[->->]] /=.
case=>H3 H4 [->->]; v2step=>_ _; rewrite (unA j1') (unA j2') /plus2.
eexists (_, _); eexists (_, _)=>/=; do !split=>//.
- eexists (_, _)=>/=; split=>//.
  by rewrite subnDr subSn // leq_add2r ltnW.
- eexists (_, _)=>/=; split=>//.
  by rewrite subnDr subSn // leq_add2r ltnW.
(* we have pushed the proof as far as it can go *)
(* clearly, this program steals alice's secret v  *)
(* so we can't prove that it's safe; we have to admit *)
admit.
Qed.
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; do 2![sstep=>?]; sstep.
move=>i1 i2 _ _; v2step=>x1 x2; v2step=>y1 y2; v2step=>/= _ _ H1 H2 H3 H4 _.
rewrite !unA /plus2; eexists (_, _)=>/=; split=>//.
by split; rewrite unC; exists (0, 0).
Qed.

(* we can now execute bob's process over several alices, without worry *)
(* that we are leaking any information from alices' secrets *)

Program
Definition client : STsec [:::] nat (PredT, fun y i m => True) := 
  Do (new_alice2 @0 [1];;
      new_alice2 @ (fun a1 => [2]);;
      new_bob @ (fun a2 a1 => tt);;
      localize (fun b => localize (process b)) @ 
        (fun b a2 a1 => [b, a1]);;
      localize (fun b => localize (process b)) @ 
        (fun t1 b a2 a1 => [b, a2]);;
      ret @ (fun t2 t1 b a2 a1 => [t1 + t2])).
Next Obligation.
split=>[[] i _|[][]] /=; last by move=>i1 i2 _ _; v2simpl; apply: bnd_do.
ssimpl; apply: sbnd_do=>//= a1 _ [[h1]] _ [[->]] _ /= [H1] _.
ssimpl; apply: sbnd_do=>//= a2 _ [[h2]] _ [[->]] _ /= [H2] _.
ssimpl; apply: sbnd_do=>//=  c _ [[h3]] _ [[->]] _ /= [H3] _.
ssimpl; rewrite -!(unCA h1) (unA h1).
apply: sbnd_do=>[|y m] /=; first by eexists 1, 0, _, _, _.
case/(_ (erefl _) (erefl _) (_, _) (_, _) (_, _) (_, _) (_, _) (erefl _)
        (conj (conj H1 H1) (conj H3 H3)))=>[[h1' t1]][[h3' t2]][[-> _]] /=.
case=>[[[H1' _]]][H3' _][[-> _]] _ {t1 t2}.
ssimpl; rewrite -!(unCA h2) -(unC h3') -unA (unA h2).
apply: sbnd_do=>[|y2 m2] /=; first by eexists 2, 1, _, _, _.
move/(_ (erefl _) (erefl _) (_, _) (_, _) (_, _) (_, _) (_, _) (erefl _)
        (conj (conj H2 H2) (conj H3' H3')))=>[[h2' t1]][[h4' t2]][[-> _]] /=.
by case=>[[[H2' _]]][H4' _][[-> _]] _ {t1 t2}; sstep.
Qed.
