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

(* multilevel erasure examples from pg.5 of Hunt and Sands, "Just Forget It" *)

(* Program P1: POLICY: erase z from L to H, where z:L, y:M, x:H 
   equivalent to saying that if all program vars. besides z were equal
   initially, then all program vars. at levels below H are equal finally

   to get a handle on the return vals of y and z, the program returns the tuple
   (y, z).  we could do the same example with x,y,z being pointers but Hunt and
   Sands only work with local vars. *)

Module P1.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      ret @ (fun x' x y z => [y + 2]);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation.
by split=>//a1 a2 i1 i2 _ _ D1 D2; vauto=> _ _ _ _ ->.
Qed.

End P1.

(* Program P1': slight variation for full erasure (not given in Hunt and Sands):
   POLICY: erase z from L to TOP, where z:L, y:M, x:H and TOP is a distinguished
   security level strictly greater than H, M, L

   equivalent to saying that if all program vars. besides z were equal initially, 
   then all program vars. at levels below TOP (ie. all program vars.) are equal 
   finally *)

Module P1_fullerasure.
Notation xval := (fun p => p.1.1).
Notation yval := (fun p => p.1.2).
Notation zval := (fun p => p.2).

(* as we might expect, the original P1 fails to meet the full erasure spec
   because it updates x based on the original value of z before erasing z *)

Program Definition prog_fail : STsec [::: nat; nat; nat] (nat * nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> 
     xval rr.1 = xval rr.2 /\ yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);; (***)
      ret @ (fun x' x y z => [y + 2]);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(x', y', z')])).
Next Obligation. Admitted. (* fails: doesn't meet policy as expected *)

(* one way to fix the problem is just to remove z from the sum in the starred 
   line below.  now the proof goes through as expected.  *)

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> 
     xval rr.1 = xval rr.2 /\ yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y]);; (***)
      ret @ (fun x' x y z => [y + 2]);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(x', y', z')])).
Next Obligation. 
by split=>//a1 a2 i1 i2 _ _ D1 D2; vauto=> _ _ _ -> ->.
Qed.

(* could also write the spec this way; not sure which is better *)

Program Definition prog' : STsec [::: nat; nat; nat] (nat * nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> rr.1 = rr.2) :=
  Do (ret @ (fun x y z => [x + y]);; (***)
      ret @ (fun x' x y z => [y + 2]);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(x', y', z')])).
Next Obligation. 
by split=>//a1 a2 i1 i2 _ _ D1 D2; vauto=> _ _ _ -> ->.
Qed.

End P1_fullerasure.

(* erase z to level M by overwriting with y:M. shows that we don't always
   need to erase by overwriting with a constant *)

Module P1_med.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      ret @ (fun x' x y z => [y + 2]);;
      ret @ (fun y' x' x y z => [y']);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation.
by split=>//a1 a2 i1 i2 _ _ D1 D2; vauto=> _ _ _ _ ->.
Qed.

End P1_med.

(* Program P2 from Hunt and Sands fails to meet the erasure spec, as expected (the
   prog. updates y based on z before erasing z) *)

Module P2.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      ret @ (fun x' x y z => [y + z]);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation. Admitted. (* fails: doesn't meet policy as expected *)

End P2.

(* Program P3 from Hunt and Sands fails to meet the erasure spec, as expected (the
   prog. performs a medium update inside a branch on z before erasing z) *)

Module P3.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      Ifbool (fun x' x y z => z == 0) then ret @ (fun x' x y z => [y + 1])
      else ret @ (fun x' x y z => [y])
      with [::: nat; nat; nat; nat], nat, 
        (fun x' x y z i => True,
         fun xx' xx yy zz rr ii mm =>
           xx.1 = xx.2 -> yy.1 = yy.2 -> rr.1 = rr.2);;
      ret @ (fun y' x' x y z => [0]);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation. 
split; first by move=> a i _; case: ifP=> A; sauto.
move=>a1 a2 i1 i2 _ _ _ _; case: ifP=> A; case: ifP=> B; vauto=> _ _ _ _ ->//=.
(* fails as expected *)
Admitted. (* fails: doesn't meet policy as expected *)

End P3.

(* z/^H: erasure of z to level H under a medium guard *)

Module P4.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      Ifbool (fun x' x y z => y == 0) then ret @ (fun x' x y z => [y + 1])
      else ret @ (fun x' x y z => [y])
      with [::: nat; nat; nat; nat], nat, 
        (fun x' x y z i => True,
         fun xx' xx yy zz rr ii mm =>
           xx.1 = xx.2 -> yy.1 = yy.2 -> rr.1 = rr.2);;
      ret @ (fun y' x' x y z => [y']);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation. 
split; first by move=>a i _; case: ifP=> A; sauto.
move=>a1 a2 i1 i2 _ _ _ _; case: ifP=>/= A; case: ifP=>/= B; vauto=>//.
by move=>_ _ _ _ ->.
by move=> _ _ _ _ C; rewrite -C A in B.
by move=> _ _ _ _ C; rewrite -C A in B. 
Qed.
Next Obligation.
split=>[a i _|a1 a2 i1 i2 _ _ _ _]; first by sauto.
vauto; apply: bnd_do=>//y1 y2 m1 m2 H1; vauto=>_ _ _ H2 H3.
by move: (H1 H2 H3)=>/=->.
Qed.

(* the example above fails if we branch on x', for example *)

Program Definition prog_fail : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     xx.1 = xx.2 -> 
     yy.1 = yy.2 -> yval rr.1 = yval rr.2 /\ zval rr.1 = zval rr.2) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      Ifbool (fun x' x y z => x' == 0) then ret @ (fun x' x y z => [y + 1])
      else ret @ (fun x' x y z => [y])
      with [::: nat; nat; nat; nat], nat, 
        (fun x' x y z i => True,
         fun xx' xx yy zz rr ii mm =>
           xx' = (xx.1 + yy.1 + zz.1, xx.2 + yy.2 + zz.2) ->
           xx.1 = xx.2 -> yy.1 = yy.2 -> rr.1 = rr.2);;
      ret @ (fun y' x' x y z => [y']);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation. 
split; first by move=>a i _; case: ifP=> A; sauto.
move=>a1 a2 i1 i2 _ _ _ _; case: ifP=>/= A; case: ifP=>/= B; vauto=>//.
by move=>_ _ _ _ _ ->.
move=> _ _ _ [C1 C2] D E /=; rewrite C1 C2 in A B; rewrite D E in A B.
(* fails because we don't know that zz.1 = zz.2 initially *)
Admitted. (* fails: doesn't meet policy as expected *)
Next Obligation.
split=>[a i _|a1 a2 i1 i2 _ _ _ _]; first by sauto.
vauto; apply: bnd_do=>//y1 y2 m1 m2 /= H1; vauto=>_ _ _ H2 H3.
by rewrite H1.
Qed.

End P4.

(* here we make the security levels explicit for x:H, y:M, z:L by stating that
   the final value of y can depend on the initial value of y and the initial 
   value of the low var. z, whereas the final value of z can depend only on 
   the initial value of z. *)

Module P5.
Notation yval := (fun p => p.1).
Notation zval := (fun p => p.2).

Program Definition prog : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     (yy.1 = yy.2 -> zz.1 = zz.2 -> yval rr.1 = yval rr.2) /\
     (zz.1 = zz.2 -> zval rr.1 = zval rr.2)) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      ret @ (fun x' x y z => [y + z]);;
      ret @ (fun y' x' x y z => [z]);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation.
by split=>//a1 a2 i1 i2 _ _ D1 D2; vauto; move=>_ _ _; split=>[-> ->|->]. 
Qed.

(* we can't prove the spec if we write (y:M + z:L) into z:L *)

Program Definition prog_fail : STsec [::: nat; nat; nat] (nat * nat)
  (fun x y z i => True,
   fun xx yy zz rr ii mm =>
     (yy.1 = yy.2 -> zz.1 = zz.2 -> yval rr.1 = yval rr.2) /\
     (zz.1 = zz.2 -> zval rr.1 = zval rr.2)) :=
  Do (ret @ (fun x y z => [x + y + z]);;
      ret @ (fun x' x y z => [y + z]);;
      ret @ (fun y' x' x y z => [y + z]);;
      ret @ (fun z' y' x' x y z => [(y', z')])).
Next Obligation.
split=>//a1 a2 i1 i2 _ _ D1 D2; vauto; move=>_ _ _; split.
by move=>->->. 
move=>->//=.
Admitted. (* fails: doesn't meet policy as expected *)

End P5.
