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

(* Simple role-based access control: only one role is active at a time.  A natural extension 
   is to a set of active roles, implemented as a linked list.  Also to users with uids, as in 
   principals.v and more modular definitions of roles and the access control policy.

   Based on the simple RBAC API on p.164 of: "Roles, stacks, histories: a triple for Hoare"
   by Borgstroem, Gordon and Pucella. 
*)

Module Type RbacSig. 
Inductive role := superuser | friend_of : nat -> role.

Parameter is_privileged : role -> bool.
Axiom is_privileged_superuser : is_privileged superuser.

(*The state consists of a pointer to the current role and a pointer to a private password. The 
  password can only be read when a privileged role, such as superuser, is active.*)
Parameter state : Type.
Parameter sshape : d state -> d nat -> d role -> Pred (d heap).
Definition shape s p r : Pred heap := 
  fun m => (m, m) \In sshape (s, s) (p, p) (r, r).
Parameter srefl : 
  forall ss pp rr ii, ii \In sshape ss pp rr -> 
    ii.1 \In shape ss.1 pp.1 rr.1 /\ ii.2 \In shape ss.2 pp.2 rr.2.

(*Role r is active in state s*)
Parameter aactive : d state -> d role -> Pred (d heap).
Definition active s r : Pred heap := 
  fun m => (m, m) \In aactive (s, s) (r, r).
Parameter arefl : 
  forall ss rr ii, ii \In aactive ss rr -> 
    ii.1 \In active ss.1 rr.1 /\ ii.2 \In active ss.2 rr.2.

Parameter new : role -> nat -> STsec [:::] state
  (fun i => True, 
   fun ss ii mm => exists rr, exists pp, exists jj, 
     mm = ii :++ jj /\ jj \In sshape ss pp rr).

Parameter activate : STsec [::: state; role] role
  (fun s r i => exists p, exists r, exists j, exists h, 
    i = j :+ h /\ shape s p r j,
   fun ss rr' yy ii mm => forall rr pp jj hh,
     ii = jj :++ hh -> sshape ss pp rr jj ->
     exists jj', mm = jj' :++ hh /\ 
     (rr'.1 = rr'.2 -> sshape ss pp rr' jj' /\ aactive ss rr' jj')).

Parameter do_privileged_read : STsec [::: state] nat
  (fun s i => exists p, exists r, exists j, exists h,
     i = j :+ h /\ shape s p r j /\ active s r j /\ is_privileged r,
   fun ss yy ii mm => forall rr pp jj hh,
     ii = jj :++ hh -> sshape ss pp rr jj -> 
     mm = ii /\ yy = pp).
End RbacSig.


Module Rbac : RbacSig.
Inductive role := superuser | friend_of : nat -> role.

Definition is_privileged (r: role) : bool := if r is superuser then true else false.

Lemma is_privilegedP r : reflect (r = superuser) (is_privileged r).
Proof. case r; move=>/=; constructor =>//=. Qed.

Lemma is_privilegedPN r : reflect (~(r = superuser)) (~~ is_privileged r).
Proof. case r; move=>/=; constructor =>//=. Qed.

Lemma is_privileged_superuser : is_privileged superuser.
Proof. by apply /is_privilegedP. Qed.

Definition state := (ptr * ptr)%type.

Definition role_proj := fst.
Definition pass_proj := snd.

Definition sshape (ss: d state) (pp: d nat) (rr: d role) : Pred (d heap) :=
  [Pred ii | [/\ ii.1 = role_proj ss.1 :-> rr.1 :+ pass_proj ss.1 :-> pp.1, 
                 ii.2 = role_proj ss.2 :-> rr.2 :+ pass_proj ss.2 :-> pp.2,
                 pp.1 = pp.2 & rr.1 = rr.2]].
Definition shape s p r : Pred heap := 
  fun m => (m, m) \In sshape (s, s) (p, p) (r, r). 

Lemma srefl ss pp rr ii : 
  ii \In sshape ss pp rr ->
  ii.1 \In shape ss.1 pp.1 rr.1 /\ ii.2 \In shape ss.2 pp.2 rr.2.
Proof. by case=> -> -> ->. Qed.

Definition aactive (ss: d state) (rr: d role) : Pred (d heap) := 
  [Pred ii | exists pp, sshape ss pp rr ii].
Definition active s r : Pred heap := 
  fun m => (m, m) \In aactive (s, s) (r, r).

Lemma arefl ss rr ii : 
  ii \In aactive ss rr -> 
  ii.1 \In active ss.1 rr.1 /\ ii.2 \In active ss.2 rr.2.
Proof. 
rewrite /active /aactive -toPredE /=. 
case=> pp [-> -> -> ->]; split=>//=; 
by do 2 rewrite -toPredE /=; exists (pp.2, pp.2).
Qed.

Program Definition new (r: role) (p: nat) : STsec [:::] state
  (fun i => True, 
   fun ss ii mm => exists rr, exists pp, exists jj, 
     mm = ii :++ jj /\ jj \In sshape ss pp rr) :=
  Do (halloc @0 [r];;
      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 (r, r); exists (p, p). 
rewrite -(unC i1) -(unCA i1) -(unC i2) -(unCA i2).
exists (y1 :-> p :+ x1 :-> r, y2 :-> p :+ x2 :-> r);
split; first by rewrite /plus2 /=.
by rewrite /sshape -toPredE /=; split=>//; rewrite unC.  
Defined.

Program Definition activate : STsec [::: state; role] role
  (fun s r i => exists p, exists r, exists j, exists h, 
    i = j :+ h /\ shape s p r j,
   fun ss rr' yy ii mm => forall rr pp jj hh,
     ii = jj :++ hh -> sshape ss pp rr jj ->
     exists jj', mm = jj' :++ hh /\ 
     (rr'.1 = rr'.2 -> sshape ss pp rr' jj' /\ aactive ss rr' jj')) :=
  Do (write @ (fun s r => [role_proj s, r]);;
      ret @ (fun _ _ r => [r])).
Next Obligation.      
rewrite !gh; split.
move=> a i [p][r'][j][h][A][B][_] _ _ C; move: B =>/= B. 
apply: sval_do =>//=. move=>D0 /=. split; last by move=>//=.
by move: B A =>-> A; rewrite -toPredE /=; do 3 eexists; erewrite unA; rewrite A.
move=> a1 a2 i1 i2 [[[[[]]]]][r1 r2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->] _ _ _ _; 
rewrite -!unA; vauto; move=> _ _. 
rewrite !unA; set k1 := _ :-> _ :+ _ :-> _; set k2 := _ :-> _ :+ _ :-> _.
exists (k1, k2); rewrite /plus2 /=; split =>//=.
by rewrite /k1 /k2 => ->; split =>//=; exists (p2, p2).
Defined.

(*Only privileged roles can read the password*)
Program Definition do_privileged_read : STsec [::: state] nat
  (fun s i => exists p, exists r, exists j, exists h,
     i = j :+ h /\ shape s p r j /\ active s r j /\ is_privileged r,
   fun ss yy ii mm => forall rr pp jj hh,
     ii = jj :++ hh -> sshape ss pp rr jj -> 
     mm = ii /\ yy = pp) :=
  Do (read _ @ (fun s => [pass_proj s])).
Next Obligation.
rewrite !gh; split.
move=> a i [p][r][j][h][A][B][C][D]; apply sval_do =>_ //=. 
rewrite /shape /sshape -toPredE /= in B; move: B A => [->].
by exists (role_proj a.1 :-> r :+ h); exists p; move=>//=; move: A ->; rewrite -unA -unCA =>//=.
by move=> a1 a2 i1 i2 [[[[[]]]]][r1 r2][p1 p2][j1 j2][h1 h2][[-> ->]][/= -> -> -> ->] _ _ _ _;
rewrite -!unA; vauto.
Defined.
End Rbac.

(*Simple example: activate the superuser role and perform a privileged read*)
Program Definition do_read : STsec [::: Rbac.state] nat
  (fun s i => exists p, exists r, exists j, exists h,
     i = j :+ h /\ Rbac.shape s p r j,
   fun ss yy ii mm => forall pp rr jj hh,
     ii = jj :++ hh -> Rbac.sshape ss pp rr jj -> 
     exists jj', mm = jj' :++ hh /\ Rbac.sshape ss pp (Rbac.superuser,Rbac.superuser) jj') :=
  Do (Rbac.activate @ (fun s => [s, Rbac.superuser]);;
      Rbac.do_privileged_read @ (fun r s => [s])).
Next Obligation. 
(*proof can probably be shortened*)
rewrite !gh; 
split =>[a i [p][r][j][h][A]B | a1 a2 i1 i2 [[[[[]]]]][p1 p2][r1 r2][j1 j2][h1 h2][[-> ->]] H _ _ _ _].
sauto; apply: sbnd_do =>//=; first by eauto 10.
move=> y m C; apply: sval_do =>//=. 
case: (C (r, r) (p, p) (j, j) (h, h)) =>//=; first by move: A => -> //=.
move=> [j1 j2][[-> _]] F; move: C => _.
case: F =>//= F G. case/Rbac.srefl: (F)=>/= H I; case/Rbac.arefl: (G)=>/= J K; move=> L.
exists p; exists Rbac.superuser; exists j1; exists h; do 2 split; move=>//=.
by split; move=>//=; apply: Rbac.is_privileged_superuser.

case/Rbac.srefl: (H) =>/= I J; vauto; apply: bnd_do=>[|y1 y2 m1 m2] /=.
split; first by move=> _; exists p1; exists r1; exists j1; exists h1; split.
by move=> _; exists p2; exists r2; exists j2; exists h2. 
move=> A; case: (A (r1, r2) (p1, p2) (j1, j2) (h1, h2)) =>//= [jj'][C D].
case: D =>//= [D E]; vauto; apply: val_do. 
case/Rbac.srefl: (D)=>/= K L; case/Rbac.arefl: (E)=>/= M N.
rewrite /plus2 /= in C; case: C => //=.
split. 
- move=> F //=; exists p1; exists Rbac.superuser; exists jj'.1; exists h1. 
  by do 3 (split; move=>//=); apply: Rbac.is_privileged_superuser.
- move=> F //=; exists p2; exists Rbac.superuser; exists jj'.2; exists h2. 
  by do 3 (split; move=>//=); apply: Rbac.is_privileged_superuser.
move=> y3 y4 m3 m4 /= F _ _; eexists; split; eauto. 
by rewrite <- C; case: (F _ _ _ _ C D) =>//=.
Defined.

