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

(*************************************************************************)
(* Example with principals.                                              *)
(*                                                                       *)
(* Inspired by Roles, stacks, histories: a triple for Hoare              *)
(* of Borgstroem, Gordon and Pucella                                     *)
(*                                                                       *)
(* We can create new companies, each of which keeps a set of employees,  *)
(* which can be dynamicaly extended, but only by a manager.              *)
(*                                                                       *)
(* Each company has a notion of "current" employee, which is the         *)
(* principal on behalf of whom the current code is executed.             *)
(*                                                                       *)
(* For example, a new_employee method can only be invoked if the current *)
(* principal of the company is a manager.                                *)
(*                                                                       *)
(* Current principals can be changed by calling change_user method.      *)
(* (something like sudo, but without a password authentication           *)
(*************************************************************************)

Module Type CompanySig.
Parameter company : Type.
Parameter employee : Type. 
Parameter uid : employee -> nat. 
Inductive role : Type := manager | staff. 

(* tie company with currently active uid *)
(* and the roster *)
Parameter ccshape : d company -> d employee -> 
                      d (seq nat) -> Pred (d heap).
Definition cshape c u r : Pred heap := 
  fun i => (i, i) \In ccshape (c, c) (u, u) (r, r).

Parameter roster_uniq: 
  forall cc uu rr ii, ii \In ccshape cc uu rr -> 
    [/\ uniq rr.1, uniq rr.2, uid uu.1 \in rr.1 & uid uu.2 \in rr.2].

(* roles of employees *)
Parameter eeshape : d employee -> d role -> Pred (d heap).
Definition eshape u r : Pred heap := 
  fun i => (i, i) \In eeshape (u, u) (r, r).

(* new gives a pointer to a company, and to it's ceo *)
(* the ceo can then go and add new employees *)

Parameter new_company : 
  STsec [:::] (company * employee) 
    (fun i => True, 
     fun ii yy mm => exists jj, exists pp,
         mm = jj :++ pp :++ ii /\ 
         jj \In ccshape (fst yy.1, fst yy.2) (snd yy.1, snd yy.2) 
                        ([:: uid (snd yy.1)], [:: uid (snd yy.2)]) /\
         pp \In eeshape (snd yy.1, snd yy.2) (manager, manager)).

Parameter new_employee : 
  STsec [::: company; role] employee 
    (fun c l i => 
       exists u, exists r, exists k, exists j, exists h, 
         i = k :+ j :+ h /\ k \In cshape c u r /\ j \In eshape u manager,
     fun cc ll ii yy mm => forall uu rr kk jj hh,
       ii = kk :++ jj :++ hh -> 
         kk \In ccshape cc uu rr -> jj \In eeshape uu (manager, manager) ->
     exists kk', exists ee', 
       mm = kk' :++ jj :++ ee' :++ hh /\ 
         kk' \In ccshape cc uu ([:: uid yy.1 & rr.1], [:: uid yy.2 & rr.2]) /\
         ee' \In eeshape yy ll).

(* changing user without authentication *)
Parameter change_user : 
  STsec [::: company; employee] unit
    (fun c e i => exists u, exists r, exists j, exists h,
                    i = j :+ h /\ j \In cshape c u r,
     fun cc ee ii yy mm => forall uu rr jj hh,
       ii = jj :++ hh -> jj \In ccshape cc uu rr ->
     exists jj', 
       mm = jj' :++ hh /\ jj' \In ccshape cc ee rr).

End CompanySig.

Module Company : CompanySig.

Definition company := ptr.
Definition employee := (ptr*nat)%type.
Inductive role : Type := manager | staff.

Definition uid (u : employee) := u.2.

Definition ccshape (cc : d company) (uu : d employee) 
                   (rr : d (seq nat)) : Pred (d heap) := 
  fun ii => [/\ ii.1 = cc.1 :-> (uu.1, rr.1), 
                ii.2 = cc.2 :-> (uu.2, rr.2), 
                uniq rr.1 /\ uniq rr.2, uid uu.1 \in rr.1 & uid uu.2 \in rr.2].
 
Definition cshape c u r : Pred heap := 
  fun i => (i, i) \In ccshape (c, c) (u, u) (r, r).

Lemma roster_uniq : forall cc uu rr ii,
        ii \In ccshape cc uu rr -> 
        [/\ uniq rr.1, uniq rr.2, uid uu.1 \in rr.1 & uid uu.2 \in rr.2].
Proof. by move=>[c1 c2][u1 u2][r1 r2][i1 i2][/= _ _ []]. Qed.

Definition eeshape (uu : d employee) (ll : d role) : Pred (d heap) :=
  fun ii => ii.1 = fst uu.1 :-> (snd uu.1, ll.1) /\ 
            ii.2 = fst uu.2 :->(snd uu.2, ll.2).

Definition eshape u r : Pred heap := 
  fun i => (i, i) \In eeshape (u, u) (r, r).

Program
Definition new_company : 
  STsec [:::] (company * employee) 
    (fun i => True, 
     fun ii yy mm => exists jj, exists pp,
         mm = jj :++ pp :++ ii /\ 
         jj \In ccshape (fst yy.1, fst yy.2) (snd yy.1, snd yy.2) 
                        ([:: uid (snd yy.1)], [:: uid (snd yy.2)]) /\
         pp \In eeshape (snd yy.1, snd yy.2) (manager, manager)) := 
  Do (halloc @ [(0, manager)];;
      halloc @ (fun u => [((u, 0), [:: 0])]);;
      ret @ (fun c u => [(c, (u, 0))])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; sstep=>u; sstep=>c; sstep.
move=>i1 i2 _ _; v2step=>u1 u2; v2step=>c1 c2; v2step=>/= _ _ _ _ _ _ _. 
rewrite /plus2 /= !unA.
by do 2![eexists (_, _)]=>/=; do !split=>//=.
Qed.

Fixpoint maxs (s : seq nat) : nat :=
  if s is u::ss then maxn u (maxs ss) else 0.

Lemma maxsP (s : seq nat) n : n > maxs s -> n \notin s.
Proof.
elim: s n=>[|u s IH] //= n H; rewrite inE /= negb_or.
have [H1 H2] :  u < n /\ maxs s < n.
- by case: n H=>// n; rewrite !ltnS geq_max; case/andP.
by rewrite IH //; case: eqP H1=>//= ->; rewrite ltnn.
Qed.

Program
Definition new_employee : 
  STsec [::: company; role] employee
    (fun c l i => 
       exists u, exists r, exists k, exists j, exists h, 
         i = k :+ j :+ h /\ k \In cshape c u r /\ j \In eshape u manager,
     fun cc ll ii yy mm => forall uu rr kk jj hh,
       ii = kk :++ jj :++ hh -> 
         kk \In ccshape cc uu rr -> jj \In eeshape uu (manager, manager) ->
     exists kk', exists ee', 
       mm = kk' :++ jj :++ ee' :++ hh /\ 
         kk' \In ccshape cc uu ([:: uid yy.1 & rr.1], [:: uid yy.2 & rr.2]) /\
         ee' \In eeshape yy ll) :=
  Do (read (employee * seq nat) @ (fun c l => [c]);;
      halloc @ (fun ur c l => [((maxs ur.2).+1, l)]);;
      write @ (fun u ur c l => [c, (ur.1, [:: (maxs ur.2).+1 & ur.2])]);;
      ret @ (fun _ u ur c l => [(u, (maxs ur.2).+1)])).
Next Obligation.
rewrite !gh; split=>[[c][l][]|[c1][l1][][c2][l2][]] /=.
- move=>i [u][r][k][j][h][->] /= [H1] H2.
  by case: (H1)=>/= -> _ [U1 _] U2 _; rewrite -!unA; sstep=>v; sstep.
move=>i1 i2 [[[[[[]]]]]][u1 u2][r1 r2][k1 k2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]][/= -> ->][U1 U2] U3 U4 E _ _.
v2step=>v1 v2; v2step=>_ _ _ _; rewrite /plus2 /=.
rewrite -!unA -(pull c1) -!(pull c2) -(unCA j1) -(unCA j2) !unA.
eexists (_, _), (_, _)=>/=; do !split=>//=.
- by rewrite U1 maxsP // maxsP.
- by rewrite U2 maxsP // maxsP.
- by rewrite inE U3 orbT.
by rewrite inE U4 orbT.
Qed.

Program 
Definition change_user : 
  STsec [::: company; employee] unit
    (fun c e i => exists u, exists r, exists j, exists h,
                    i = j :+ h /\ j \In cshape c u r,
     fun cc ee ii yy mm => forall uu rr jj hh,
       ii = jj :++ hh -> jj \In ccshape cc uu rr ->
     exists jj', 
       mm = jj' :++ hh /\ jj' \In ccshape cc ee rr) :=
  Do (read (employee * seq nat) @ (fun c u => [c]);;
      Ifbool (fun ur c u => uid u \in ur.2) then 
        write @ (fun ur c u => [c, (u, ur.2)])
      else diverge with
        [::: employee * seq nat; company; employee], unit,
          (fun ur c e i => exists j, exists h,
                             i = j :+ h /\ j \In cshape c ur.1 ur.2,
           fun uur cc ee ii yy mm => forall jj hh,
             ii = jj :++ hh -> 
             jj \In ccshape cc (fst uur.1, fst uur.2) (snd uur.1, snd uur.2) ->
           exists jj', 
              mm = jj' :++ hh /\ jj' \In ccshape cc ee (snd uur.1, snd uur.2))).
Next Obligation.
rewrite !gh; split=>[[ur][c][e][]|[ur1][c1][e1][][ur2][c2][e2][]] /=.
- move=>i [j][h][->][/= -> _ [U1 _] U2 _].
  by case: ifP=>E; [sstep | apply: sval_do].
move=>i1 i2 [[[]]][j1 j2][h1 h2][[-> ->]][/= -> -> [U1 U2] U3 U4] _ _.
case: ifP=>E1; case: ifP=>E2.
- by v2step=>_ _; eexists (_, _); split.
- by apply/vrfS1; vstep=>_; vsimpl; apply: val_doV.
- by apply/vrfS2; vstep=>_; vsimpl; apply: val_doV.
by apply: val_do.
Qed.
Next Obligation.
rewrite !gh; split=>[[c][u][]|[c1][u1][][c2][u2][]] /=.
- move=>i [u1][r][j][h][->] /= H; case: (H)=>[/= -> _ [U1 _] U2 _].
  by sstep; ssimpl; apply: sval_do=>/=; eexists _, _.
move=>i1 i2 [[[[[]]]]][v1 v2][r1 r2][j1 j2][h1 h2] /=.
case=>[[-> ->]][/= -> -> [U1 U2] U3 U4] _ _.
v2step; v2simpl; apply: val_do=>[|_ _ m1 m2] /=; first by split; eexists _, _.
by move/(_ (_, _) (_, _) (erefl _))=>L _ _; apply: L.
Qed.

End Company.