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.

(******************************************************************************

 An implementation of the medical records workflow from p.171 of
                                                                            
   "Roles, stacks,  histories: a  triple for Hoare,"  by Borgstroem,  Gordon and
   Pucella
                                                                            
OVERVIEW: A hospital is a tuple of a list of active roles, an active user, and a
list of  employee user ids  (the roster).  The  active user is the  principal on
behalf  of whom  the  current code  is  executed.  The  active  roles limit  the
operations the  current user can  perform.  Which roles  a user can  activate is
determined by the that user's role memberships (represented as a list of roles).
A user is a pair of a list of her role memberships and a unique user id.
 
INITIALIZATION: When a hospital is  first created, the hospital director (uid 0)
is added to the roster automatically as  an administrator.  It is the job of the
hospital director to manage the roster by creating new users and assigning users
to roles.  Later on, new users can be added and removed from the hospital roster
dynamically, by any  user acting in an administrative  capacity (i.e.  the admin
role is active).  In particular, the administrator may delegate her duties to a
deputy by granting another user administrative privileges.

ROLES: Roles determine  which operations a user can perform.   For example, if a
new doctor  is hired by the hospital,  the hospital director may  assign her the
clinician role, perhaps  among other roles, with the effect  that the doctor can
perform  functions such  as reading  a  patient's electronic  health record  but
cannot execute administrative functions such as adding a new user (if the doctor
is not also  an administrator).  Roles can be granted to  and revoked from users
dynamically, by any user acting in an administrative capacity.
                                                                 
PROTECTED  RESOURCES: Access  to  resources such  as  electronic health  records
(EMRs) is limited using abstract predicates.  Assume, for example, that a doctor
must  request a  patient's consent  before accessing  that  patient's electronic
health record.  We can model such a policy by defining an abstract predicate, or
a series of such predicates, that indicate  when an action such as a request for
consent has been  performed, and by whom.  The key  property of these predicates
is that they are opaque to  clients of the module, enforcing that, e.g., calling
request_consent(pat)  is the  only  way  to prove  that  the abstract  predicate
requested_consent(current_user, pat) actually holds.  Abstract predicates can be
composed  arbitrarily, according  to  the specification  of  the access  control
policy.   For  example,   we  may  want  to  specify   that  if  the  predicates
requested_consent(doc, pat) and consented(doc, pat) both hold, then the user doc
can execute the privileged function read_emr(pat).

*******************************************************************************)

Module Type HospitalSig.
Parameter hospital : Type.
Parameter user : Type. 
Notation uid := nat.
Parameter get_uid : user -> uid.
Inductive role : Type := admin | clinician | patient. 

(*We need to define a boolean equality on roles in order to use many of the
  functions and lemmas provided on sequences.*)

Definition eqr (r1 r2: role) : bool := 
  if r1 is admin then (if r2 is admin then true else false)
  else (if r1 is clinician then (if r2 is clinician then true else false)
        else (if r1 is patient then (if r2 is patient then true else false)
             else false)).
Axiom eqrP : Equality.axiom eqr. 
Canonical Structure role_eqMixin := EqMixin eqrP.
Canonical Structure role_eqType := Eval hnf in EqType role role_eqMixin.

Parameter hhshape : 
  d hospital -> d (seq role) -> d user -> d (seq uid) -> Pred (d heap).
Definition hshape q a u r : Pred heap := 
  fun i => (i, i) \In hhshape (q, q) (a, a) (u, u) (r, r).
Axiom hrefl : forall hhosp aa uu rr ii,
  hhshape hhosp aa uu rr ii ->
  hshape hhosp.1 aa.1 uu.1 rr.1 ii.1 /\ hshape hhosp.2 aa.2 uu.2 rr.2 ii.2.

Parameter roster_uniq: 
  forall qq aa uu rr ii, ii \In hhshape qq aa uu rr -> 
    [/\ uniq rr.1, uniq rr.2, get_uid uu.1 \in rr.1 & get_uid uu.2 \in rr.2].

(** A user is a pointer to the user's role memberships, along with a unique
    uid.*)

Parameter uushape : d user -> d (seq role) -> Pred (d heap).
Definition ushape u roles : Pred heap := 
  fun i => (i, i) \In uushape (u, u) (roles, roles).
Axiom urefl : forall uu rroles hh,
  uushape uu rroles hh ->
  ushape uu.1 rroles.1 hh.1 /\ ushape uu.2 rroles.2 hh.2.

(** The clinician Doc has requested to read Pat's medical records.*)

Parameter rrequested_consent : d uid -> d uid -> Prop.
Definition requested_consent doc pat : Prop := 
  rrequested_consent (doc, doc) (pat, pat).
Axiom rrefl : forall ddoc ppat,
  rrequested_consent ddoc ppat ->
  requested_consent ddoc.1 ppat.1 /\ requested_consent ddoc.2 ppat.2.

(** Pat has given Doc consent.*)

Parameter cconsented : d uid -> d uid -> Prop.
Definition consented doc pat : Prop := cconsented (doc, doc) (pat, pat).
Axiom crefl : forall ddoc ppat,
  cconsented ddoc ppat ->
  consented ddoc.1 ppat.1 /\ consented ddoc.2 ppat.2.

(** Doc can read Pat's medical records if either Pat has given Doc her consent
    or Doc and Pat are actually the same user. *)

Parameter ccan_read_emr : d uid -> d uid -> Prop.
Definition can_read_emr doc pat : Prop := ccan_read_emr (doc, doc) (pat, pat).
Axiom cremr_refl : forall ddoc ppat,
  ccan_read_emr ddoc ppat ->
  can_read_emr ddoc.1 ppat.1 /\ can_read_emr ddoc.2 ppat.2.
Axiom can_read_emr_refl : forall id: uid, can_read_emr id id.
Axiom can_read_emr_consent : forall (doc pat: uid), 
  consented doc pat -> can_read_emr doc pat.

(** Create a new hospital with a single user, the Admin.  The Admin is
    automatically mad a member of the admin role. *)
  
Parameter new_hospital : 
  STsec [:::] (hospital * user) 
    (fun i => True, 
     fun yy ii mm => exists jj, exists uu,
         mm = jj :++ uu :++ ii /\ 
         jj \In hhshape (fst yy.1, fst yy.2) (nil, nil) (snd yy.1, snd yy.2) 
                        ([:: get_uid (snd yy.1)], [:: get_uid (snd yy.2)]) /\
         uu \In uushape (snd yy.1, snd yy.2) ([:: admin], [:: admin])).

(** Create a new user.  For this operation to succeed, the admin role must be
    active. *)

Parameter new_user : 
  STsec [::: hospital; seq role] user
    (fun hosp _ i => 
       exists act, exists u, exists rost, exists j, exists h, 
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ admin \in act,
     fun hhosp rroles yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> jj \In hhshape hhosp aact uu rrost -> 
         exists jj', exists uu', 
           mm = jj' :++ uu' :++ hh /\ 
           jj' \In hhshape hhosp aact uu 
                           (get_uid yy.1 :: rrost.1, get_uid yy.2 :: rrost.2) /\
           uu' \In uushape yy rroles).

(** Remove a user from the roster. A user can't remove himself from the
    roster. Also, the admin role must be active. *)

Definition remove_uid (id: uid) : seq uid -> seq uid := 
  filter (fun id' => id != id').

Parameter remove_user : 
  STsec [::: hospital; user] unit
    (fun hosp u' i => 
       exists act, exists u, exists rost, exists roles,
       exists j, exists k, exists h, 
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\
         admin \in act /\ get_uid u != get_uid u',
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         get_uid uu.1 != get_uid uu'.1 -> get_uid uu.2 != get_uid uu'.2 ->
         exists kk', 
           mm = kk' :++ hh /\ 
           kk' \In hhshape hhosp aact uu (remove_uid (get_uid uu'.1) rrost.1, 
                                          remove_uid (get_uid uu'.2) rrost.2)).

(** Activate a role.  The current user must be a member of the activated role
    for the operation to succeed. *)

Parameter activate_role : 
  forall (rol : role),
  STsec [::: hospital] unit
    (fun hosp i =>
       exists act, exists u, exists rost, exists roles, 
       exists j, exists k, exists h,
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u roles /\ 
         rol \in roles,
     fun hhosp yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu rroles ->
         exists kk', 
           mm = kk' :++ jj :++ hh /\
           kk' \In hhshape hhosp (rol :: aact.1, rol :: aact.2) uu rrost).

(** Dectivate a role. The role must be active for the operation to succeed. *)

Definition remove_role (rol: role) : seq role -> seq role := 
  filter (fun rol' => negb (eqr rol rol')).

Parameter deactivate_role : 
  forall (rol : role),
  STsec [::: hospital] unit
    (fun hosp i =>
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ rol \in act,
     fun hhosp yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost -> 
         exists jj', 
           mm = jj' :++ hh /\
           jj' \In hhshape hhosp (remove_role rol aact.1, 
                                  remove_role rol aact.2) uu rrost).

(** Grant a user membership in a role. The admin role must be active. *)

Parameter grant_role : 
  forall (rol : role),
  STsec [::: hospital; user] unit
    (fun hosp u' i =>
       exists act, exists u, exists rost, exists roles, 
       exists k, exists j, exists h,
         i = k :+ j :+ h /\ 
         (*j is the heap of a potentially different user*)
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\ 
         admin \in act,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         exists jj', 
           mm = kk :++ jj' :++ hh /\
           kk \In hhshape hhosp aact uu rrost /\ 
           jj' \In uushape uu' (rol :: rroles.1, rol :: rroles.2)).

(** Revoke user membership in a role. The admin role must be active. *)

Parameter revoke_role : 
  forall (rol : role),
  STsec [::: hospital; user] unit
    (fun hosp u' i =>
       exists act, exists u, exists rost, exists roles, 
       exists k, exists j, exists h,
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\ 
         admin \in act /\ rol \in roles,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         exists jj', 
           mm = kk :++ jj' :++ hh /\
           kk \In hhshape hhosp aact uu rrost /\ 
           jj' \In uushape uu' (remove_role rol rroles.1, 
                                remove_role rol rroles.2)).

(** Change the active user.  One effect of this operation is to deactivate all
    active roles. *)

Parameter switch_user : 
  STsec [::: hospital; user] unit
    (fun hosp u' i => 
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ get_uid u' \in rost,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost -> 
         get_uid uu'.1 \in rrost.1 -> get_uid uu'.2 \in rrost.2 ->
         exists jj', 
           mm = jj' :++ hh /\ 
           jj' \In hhshape hhosp (nil, nil) uu' rrost).

(** Request Pat's permission to read her health record.  The clinician role must
    be active. *)

Parameter request_consent : 
  STsec [::: hospital; user] unit
    (fun hosp _ i =>
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ clinician \in act,
     fun hhosp ppat yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost ->
         mm = ii /\ rrequested_consent (get_uid uu.1, get_uid uu.2) 
                                       (get_uid ppat.1, get_uid ppat.2)).

(** Give Doc consent.  The patient role must be active and Doc must have
    previously requested consent. *)

Parameter give_consent : 
  STsec [::: hospital; user] unit
    (fun hosp doc i =>
      exists act, exists u, exists rost, 
      exists j, exists h,
        i = j :+ h /\ 
        j \In hshape hosp act u rost /\ 
        patient \in act /\ requested_consent (get_uid doc) (get_uid u),
     fun hhosp ddoc yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost ->
         mm = ii /\ cconsented (get_uid ddoc.1, get_uid ddoc.2) 
                               (get_uid uu.1, get_uid uu.2)).

(** Read Pat's electronic health record.  The clinician role must be active and
    Doc must have previously requested consent. *)

Parameter read_emr : 
  STsec [::: hospital; user] nat
    (fun hosp pat i => 
       exists act, exists u, exists rost, 
       exists j, exists h, 
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ 
         can_read_emr (get_uid u) (get_uid pat),
     fun hhosp ppat yy ii mm => mm = ii).

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 hosp b act u rost j : Pred heap := 
  fun i => exists k, exists t, exists h, 
    [/\ i = j :+ t :+ h, j \In hshape hosp act u rost & t \In bshape b k].

Definition epost hhosp bb aact uu rrost jj (yy : d nat) ii mm := 
  forall kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In hhshape hhosp aact uu rrost -> tt \In bbshape bb kk ->
  exists tt', 
    mm = jj :++ tt' :++ hh /\ tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (tt.1 = tt.2 -> tt'.1 = tt'.2). 

Parameter endorse : 
  breflP -> 
  (STsec [::: hospital; bob; user] nat 
    (fun hosp b pat i => exists act:seq role, exists u, exists rost, exists j, 
      [/\ can_read_emr (get_uid u) (get_uid pat) & i \In epre hosp b act u rost j],
     fun hhosp bb ppat yy ii mm => 
       forall aact uu rrost jj, epost hhosp bb aact uu rrost jj yy ii mm)) -> 
  STsec [::: hospital; bob; user] nat
    (fun hosp b pat i => exists act, exists u, exists rost, exists j, 
       i \In epre hosp b act u rost j, 
     fun hhosp bb ppat yy ii mm => forall aact uu rrost jj, 
       epost hhosp bb aact uu rrost jj yy ii mm).

Definition epost_low hhosp bb aact uu rrost jj (yy : d nat) ii mm := 
  forall kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In hhshape hhosp aact uu rrost -> tt \In bbshape bb kk ->
  exists tt', 
    mm = jj :++ tt' :++ hh /\ tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (* expose the assumption here that the initial abstract bob states are equal; 
       means we don't need to prove an injectivity lemma for bob's shape predicate*)
    (kk.1 = kk.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Parameter endorse_low : 
  breflP -> forall b:bob,
  (STsec [::: hospital; user] nat 
    (fun hosp pat i => exists act:seq role, exists u, exists rost, exists j, 
      [/\ can_read_emr (get_uid u) (get_uid pat) & i \In epre hosp b act u rost j],
     fun hhosp ppat yy ii mm => 
       forall aact uu rrost jj, epost_low hhosp (b, b) aact uu rrost jj yy ii mm)) -> 
  STsec [::: hospital; user] nat
    (fun hosp pat i => exists act, exists u, exists rost, exists j, 
       i \In epre hosp b act u rost j, 
     fun hhosp ppat yy ii mm => forall aact uu rrost jj, 
       epost_low hhosp (b, b) aact uu rrost jj yy ii mm).

End Endorse.

End HospitalSig.

Module Hospital : HospitalSig.
Definition hospital := ptr.
Definition user := (ptr * nat)%type.
Inductive role : Type := admin | clinician | patient. 

Definition eqr (r1 r2: role) : bool := 
  if r1 is admin then (if r2 is admin then true else false)
  else (if r1 is clinician then (if r2 is clinician then true else false)
        else (if r1 is patient then (if r2 is patient then true else false)
             else false)).
Lemma eqrP : Equality.axiom eqr.
Proof. by do 2 case; constructor. Qed.

Canonical Structure role_eqMixin := EqMixin eqrP.
Canonical Structure role_eqType := Eval hnf in EqType role role_eqMixin.

Notation uid := nat.
Definition get_uid (u : user) := u.2.

Definition hhshape (hh : d hospital) (aa : d (seq role)) (uu : d user) 
                   (rr : d (seq nat)) : Pred (d heap) := 
  fun ii => [/\ ii.1 = hh.1 :-> (uu.1, aa.1, rr.1), 
                ii.2 = hh.2 :-> (uu.2, aa.2, rr.2), 
                uniq rr.1 /\ uniq rr.2, 
                get_uid uu.1 \in rr.1 & get_uid uu.2 \in rr.2].
 
Definition hshape hosp act u rost : Pred heap := 
  fun i => (i, i) \In hhshape (hosp, hosp) (act, act) (u, u) (rost, rost).

Lemma hrefl qq aa uu rr hh :
       hhshape qq aa uu rr hh ->
       hshape qq.1 aa.1 uu.1 rr.1 hh.1 /\ hshape qq.2 aa.2 uu.2 rr.2 hh.2.
Proof. by case=> -> -> [A1 A2] B C. Qed.

Lemma roster_uniq : forall qq aa uu rr ii,
        ii \In hhshape qq aa uu rr -> 
        [/\ uniq rr.1, uniq rr.2, get_uid uu.1 \in rr.1 & 
                                  get_uid uu.2 \in rr.2].
Proof. by move=>[q1 q2][a1 a2][u1 u2][r1 r2][i1 i2][/= _ _ []]. Qed.

Definition uushape (uu: d user) (ll: d (seq 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 ushape u r : Pred heap := 
  fun i => (i, i) \In uushape (u, u) (r, r).

Lemma urefl uu rr hh :
  uushape uu rr hh ->
  ushape uu.1 rr.1 hh.1 /\ ushape uu.2 rr.2 hh.2.
Proof. by case=> -> ->. Qed.

Definition rrequested_consent (doc pat: d uid) : Prop := True.
Definition requested_consent doc pat : Prop := 
  rrequested_consent (doc, doc) (pat, pat).
Lemma rrefl dd pp :
  rrequested_consent dd pp ->
  requested_consent dd.1 pp.1 /\ requested_consent dd.2 pp.2.
Proof. done. Qed.

Definition cconsented (doc pat: d uid) : Prop := True.
Definition consented doc pat : Prop := cconsented (doc, doc) (pat, pat).
Lemma crefl dd pp :
  cconsented dd pp ->
  consented dd.1 pp.1 /\ consented dd.2 pp.2.
Proof. done. Qed.

Definition ccan_read_emr (doc pat: d uid) : Prop := True.
Definition can_read_emr doc pat : Prop := ccan_read_emr (doc, doc) (pat, pat).
Lemma can_read_emr_refl id : can_read_emr id id.
Proof. done. Qed.
Lemma can_read_emr_consent (doc pat: uid) : 
  consented doc pat -> can_read_emr doc pat.
Proof. done. Qed.
Lemma cremr_refl dd pp : 
  ccan_read_emr dd pp ->
  can_read_emr dd.1 pp.1 /\ can_read_emr dd.2 pp.2.
Proof. done. 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 hosp b act u rost j : Pred heap := 
  fun i => exists k, exists t, exists h, 
    [/\ i = j :+ t :+ h, j \In hshape hosp act u rost & t \In bshape b k].

Definition epost hhosp bb aact uu rrost jj (yy : d nat) ii mm := 
  forall kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In hhshape hhosp aact uu rrost -> tt \In bbshape bb kk ->
  exists tt', 
    mm = jj :++ tt' :++ hh /\ 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 [::: hospital; bob; user] nat 
    (fun hosp b pat i => exists act:seq role, exists u, exists rost, exists j, 
      [/\ can_read_emr (get_uid u) (get_uid pat) & i \In epre hosp b act u rost j],
     fun hhosp bb ppat yy ii mm => 
       forall aact uu rrost jj, epost hhosp bb aact uu rrost jj yy ii mm)) :
  STsec [::: hospital; bob; user] nat
    (fun hosp b pat i => exists act, exists u, exists rost, exists j, 
       i \In epre hosp b act u rost j, 
     fun hhosp bb ppat yy ii mm => forall aact uu rrost jj, 
       epost hhosp bb aact uu rrost jj yy ii mm) :=
   Do (e @ (fun hosp b pat => [hosp, b, pat])).
Next Obligation.
rewrite !gh; split=>[[hosp][b][pat][]|[hosp1][b1][u1][][hosp2][b2][u2][]] /=.
- move=>i [act][u][rost][j][k][t][h][->][/= H _ Huniq _] H1 H2; sauto.
  apply: sval_do=>/=. exists act; exists u; exists rost; exists j.
  rewrite H. split=>//=. exists k; exists t; exists h; split=>//.
move=>i1 i2 [[[[[[[[]]]]]]]][act1 act2][user1 user2][rost1 rost2]
      [k1 k2][t1 t2][h1 h2][j1 j2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>/=H2 H3 _ _ _ H [j1' H4][j2' H5] _ _.
case: (pf _ _ _ H)=>/= H6 H7.
vauto. apply: val_do=>[|y1 y2 m1 m2] /=. 
case: H4=>u[rost][j]H8. case: H5=>u'[rost'][j']H9.
rewrite /can_read_emr/ccan_read_emr. 
by split; do 4!eexists; eauto.
move/(_ (act1, act2) (user1, user2) (rost1, rost2) (k1, k2)).
move/(_ (t1, t2) (h1, h2) (j1, j2))=>L _ _ /=.
by case: L=>//[[t1' t2']][[-> ->]]/= [H8]H10; exists (t1', t2'); split.
Qed.

(* alternative version of endorse in which bob is a function argument (hence low) *)

Definition epost_low hhosp bb aact uu rrost jj (yy : d nat) ii mm := 
  forall kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In hhshape hhosp aact uu rrost -> tt \In bbshape bb kk ->
  exists tt', 
    mm = jj :++ tt' :++ hh /\ tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (* expose the assumption here that the initial abstract bob states are equal; 
       means we don't need to prove an injectivity lemma for bob's shape predicate*)
    (kk.1 = kk.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Program
Definition endorse_low (pf : breflP) (b : bob)
  (e : STsec [::: hospital; user] nat 
    (fun hosp pat i => exists act:seq role, exists u, exists rost, exists j, 
      [/\ can_read_emr (get_uid u) (get_uid pat) & i \In epre hosp b act u rost j],
     fun hhosp ppat yy ii mm => 
       forall aact uu rrost jj, epost_low hhosp (b, b) aact uu rrost jj yy ii mm)) :
  STsec [::: hospital; user] nat
    (fun hosp pat i => exists act, exists u, exists rost, exists j, 
       i \In epre hosp b act u rost j, 
     fun hhosp ppat yy ii mm => forall aact uu rrost jj, 
       epost_low hhosp (b, b) aact uu rrost jj yy ii mm) :=
   Do (e @ (fun hosp pat => [hosp, pat])).
Next Obligation.
rewrite !gh; split=>[[hosp][pat][]|[hosp1][u1][][hosp2][u2][]] /=.
- move=>i [act][u][rost][j][k][t][h][->][/= H _ Huniq _] H1 H2; sauto.
  apply: sval_do=>/=. exists act; exists u; exists rost; exists j.
  rewrite H. split=>//=. exists k; exists t; exists h; split=>//.
move=>i1 i2 [[[[[[[[]]]]]]]][act1 act2][user1 user2][rost1 rost2]
      [k1 k2][t1 t2][h1 h2][j1 j2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>/=H2 H3 _ _ _ H [j1' H4][j2' H5] _ _.
case: (pf _ _ _ H)=>/= H6 H7.
vauto. apply: val_do=>[|y1 y2 m1 m2] /=. 
case: H4=>u[rost][j]H8. case: H5=>u'[rost'][j']H9.
rewrite /can_read_emr/ccan_read_emr. 
by split; do 4!eexists; eauto.
move/(_ (act1, act2) (user1, user2) (rost1, rost2) (k1, k2)).
move/(_ (t1, t2) (h1, h2) (j1, j2))=>L _ _ /=.
by case: L=>//[[t1' t2']][[-> ->]]/= [H8]H10; exists (t1', t2'); split.
Qed.

End Endorse.

Program
Definition new_hospital : 
  STsec [:::] (hospital * user) 
    (fun i => True, 
     fun yy ii mm => exists jj, exists uu,
         mm = jj :++ uu :++ ii /\ 
         jj \In hhshape (fst yy.1, fst yy.2) (nil, nil) (snd yy.1, snd yy.2) 
                        ([:: get_uid (snd yy.1)], [:: get_uid (snd yy.2)]) /\
         uu \In uushape (snd yy.1, snd yy.2) ([:: admin], [:: admin])) :=
  Do (lalloc @ [(0, [:: admin])];;
      lalloc @ (fun u => [((u, 0), @Nil role, [:: 0])]);;
      ret @ (fun hosp u => [(hosp, (u, 0))])).
Next Obligation.
split=>[[]|[][]] /=; first by move=>i _; sauto=>u; sauto=>c; sauto.
move=>i1 i2 _ _ _ _. vauto=>u1 u2. vauto=>c1 c2. vauto=>/= _ _ _ _ _. 
rewrite /plus2 /= !unA.
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 leq_maxl; case/andP.
by rewrite IH //; case: eqP H1=>//= ->; rewrite ltnn.
Qed.

Definition next_uid (rost : seq uid) := (maxs rost).+1.
Definition get_user (uar : user * seq role * seq uid) := uar.1.1.
Definition get_act (uar : user * seq role * seq uid) := uar.1.2.
Definition get_rost (uar : user * seq role * seq uid) := uar.2.

Program
Definition new_user : 
  STsec [::: hospital; seq role] user
    (fun hosp _ i => 
       exists act, exists u, exists rost, exists j, exists h, 
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ admin \in act,
     fun hhosp rroles yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost -> 
         exists jj', exists uu', 
           mm = jj' :++ uu' :++ hh /\ 
           jj' \In hhshape hhosp aact uu (get_uid yy.1 :: rrost.1, 
                                          get_uid yy.2 :: rrost.2) /\
           uu' \In uushape yy rroles) :=
  Do (read (user * seq role * seq uid) @ (fun hosp roles => [hosp]);;
      lalloc @ (fun uar hosp roles => [(next_uid (get_rost uar), roles)]);;
      write @ (fun u uar hosp roles => 
        [hosp, (uar.1, next_uid (get_rost uar) :: get_rost uar)]);;
      ret @ (fun _ u uar hosp roles => [(u, next_uid (get_rost uar))])).
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 _; sauto=>v; sauto. 
move=>i1 i2 [[[[[[]]]]]][a1 a2][u1 u2][r1 r2][j1 j2][h1 h2] /=.
case=>[[[-> ->]]][/= -> ->][U1 U2] U3 U4 E _ _ _; vauto=>v1 v2; vauto=> _ _ _.
rewrite !unA /plus2 /next_uid /=.
eexists (_, _); eexists (_, _)=>/=; do !split=>//=. 
- by rewrite U1 maxsP // maxsP.
- by rewrite U2 maxsP // maxsP.
- by rewrite inE U3 orbT.
by rewrite inE U4 orbT.
Qed.

Definition remove_uid (id: uid) : seq uid -> seq uid := 
  filter (fun id' => id != id').

Lemma remove_uid_uniq id roles : uniq roles -> uniq (remove_uid id roles).
Proof. apply: filter_uniq. Qed.

Lemma neqnP (n m: nat) : reflect (n <> m) (n != m).
Proof.
rewrite /negb; case (@eqnP n m) =>[Heq|Heq]. rewrite Heq =>/=.
have A: (m == m = true) by apply/eqnP. rewrite A; constructor =>//=.
have A: (n == m = false) by apply/eqnP =>//=. rewrite A; constructor =>//=.
Qed.

Lemma remove_uid_mem id id' roles : 
  id' != id -> id' \in roles -> id' \in remove_uid id roles.
Proof.
move=> A B. rewrite mem_filter /is_true andb_true_iff; split =>//.
case (@neqnP id id') =>H //. 
exfalso. apply: H =>Contra. subst id. unfold negb in A. 
case H: (id' == id'); rewrite H in A =>//.
(*fixme*)
clear B. induction id'. compute in H. inversion H.
compute in H. apply IHid'. rewrite <-H. auto.
Qed.

Program
Definition remove_user : 
  STsec [::: hospital; user] unit
    (fun hosp u' i => 
       exists act, exists u, exists rost, exists roles,
       exists j, exists k, exists h, 
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\
         admin \in act /\ get_uid u != get_uid u',
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         get_uid uu.1 != get_uid uu'.1 -> get_uid uu.2 != get_uid uu'.2 ->
         exists kk', 
           mm = kk' :++ hh /\ 
           kk' \In hhshape hhosp aact uu 
                           (remove_uid (get_uid uu'.1) rrost.1, 
                            remove_uid (get_uid uu'.2) rrost.2)) :=
  Do (read (user * seq role * seq uid) @ (fun hosp u' => [hosp]);;
      write @ (fun uar hosp u' => 
        [hosp, (get_user uar, get_act uar, 
                remove_uid (get_uid u') (get_rost uar))]);;
      dealloc @ (fun _ uar hosp u' => [u'.1])).
Next Obligation.
rewrite !gh; split. 
move=>a i [act][u][rost][roles][j][k][h][[->]][[/= ->]] _ _ _ _ [[/= ->] _ _].
sauto=> C; rewrite -unA; apply sbnd_read. sauto. by rewrite unA. 
move=>a1 a2 i1 i2 [[[[[[[]]]]]]]act1 act2[u1 u2][r1 r2][rl1 rl2].
move=>[j1 j2][k1 k2][h1 h2][[[[[-> ->]]]]].
move=>[[/= -> ->]]. move=>[A1 A2]B C[[/= -> ->]] E F G H _ _.
vauto. rewrite -unA -(unA (a2.1 :-> _)). apply bnd_read. vauto.
set j'1 := (a1.1 :-> _); set j'2 := (a2.1 :-> _). 
exists (j'1, j'2); split=>//=.
rewrite /j'1 /j'2 /hhshape -toPredE; split =>//=.
by split; apply: filter_uniq.
by apply: remove_uid_mem. by apply: remove_uid_mem.
Qed.

Program 
Definition activate_role (rol: role) :
  STsec [::: hospital] unit
    (fun hosp i =>
       exists act, exists u, exists rost, exists roles, 
       exists j, exists k, exists h,
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u roles /\ 
         rol \in roles,
     fun hhosp yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu rroles ->
         exists kk', 
           mm = kk' :++ jj :++ hh /\
           kk' \In hhshape hhosp (rol :: aact.1, rol :: aact.2) uu rrost) :=
  Do (read (user * seq role * seq nat) @ (fun hosp => [hosp]);;
      write @ (fun uar hosp => 
        [hosp, (get_user uar, rol :: get_act uar, get_rost uar)])).
Next Obligation.
rewrite !gh; split=>
[a i [aa][u][r][l][j][k][h][[->]][[/= ->]] _ _ _ _ A
|a1 a2 i1 i2 [[[[[[[[]]]]]]]] a u r1 r2 [j1 j2][k1 k2][h1 h2][[[-> ->]]]
 [[/= -> ->]][A1 A2]B C[[/= -> ->]]D E _ _];
first by rewrite -unA; set h' := (_ :+ _); sauto.
rewrite -!unA; set (z1 := u.1.1 :-> (u.1.2, r2.1) :+ h1).
set (z2 := u.2.1 :-> (u.2.2, r2.2) :+ h2); vauto.
rewrite /z1 /z2 => _ _.
exists (a1.1 :-> (u.1, rol :: a.1, r1.1), a2.1 :-> (u.2, rol :: a.2, r1.2)).
by rewrite /plus2 -!unA; split =>/=. 
Qed.

Definition remove_role (rol: role) : seq role -> seq role := 
  filter (fun rol' => negb (eqr rol rol')).

Program 
Definition deactivate_role (rol: role) : 
  STsec [::: hospital] unit
    (fun hosp i =>
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ rol \in act,
     fun hhosp yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost -> 
         exists jj', 
           mm = jj' :++ hh /\
           jj' \In hhshape hhosp (remove_role rol aact.1, 
                                  remove_role rol aact.2) uu rrost) :=
  Do (read (user * seq role * seq nat) @ (fun hosp => [hosp]);;
      write @ (fun uar hosp => 
        [hosp, (get_user uar, remove_role rol (get_act uar), get_rost uar)])).
Next Obligation.
rewrite !gh; split=>
[a i [act][u][rost][j][h][[->]][[/= ->]] _ _ _ _ A
|a1 a2 i1 i2 [[[[[[[]]]]]]] a u r1 r2 [j1 j2][h1 h2][[[-> ->]]]
[[/= -> ->]][A1 A2]B C _ _ _ _]; first by sauto. 
vauto=> _ _; set jj'1 := (a1.1 :-> _); set jj'2 := (a2.1 :-> _).
exists (jj'1, jj'2); split=>//=. 
Qed.

Program
Definition grant_role (rol : role) :
  STsec [::: hospital; user] unit
    (fun hosp u' i =>
       exists act, exists u, exists rost, exists roles, 
       exists k, exists j, exists h,
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\ 
         admin \in act,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         exists jj', 
           mm = kk :++ jj' :++ hh /\
           kk \In hhshape hhosp aact uu rrost /\ 
           jj' \In uushape uu' (rol :: rroles.1, rol :: rroles.2)) :=
  Do (read (nat * seq role) @ (fun hosp u => [u.1]);;
      write @ (fun id_roles hosp u => [u.1, (id_roles.1, rol :: id_roles.2)])).
Next Obligation.
rewrite !gh; split.
move=> a i [act][u][rost][roles][k][j][h][[->]][A[[/= ->]]C] _. 
rewrite -unA -(unC (a.2.1.1 :-> _ :+ _)) -unA; sauto.
move=>a1 a2 i1 i2[[[[[[[[]]]]]]]]a u r1 r2 [j1 j2][k1 k2][h1 h2]
      [[[-> ->]]][[/= -> ->]][A1 A2]B C[[/= -> ->]]E F _ _.
rewrite -unA unC -unA -(unA (a2.1 :-> _)) (unC (a2.1 :-> _)) 
  -(unA (a2.2.1.1 :-> _)); vauto=> _ _.
rewrite unA unC unA. rewrite (unC (a2.2.1.1 :-> _)) -(unA h2) (unC h2).
set jj'1 := (a1.2.1.1 :-> _); set jj'2 := (a2.2.1.1 :-> _).
exists (jj'1, jj'2); split=>//=. 
Qed.

Program 
Definition revoke_role (rol : role) :
  STsec [::: hospital; user] unit
    (fun hosp u' i =>
       exists act, exists u, exists rost, exists roles, 
       exists k, exists j, exists h,
         i = k :+ j :+ h /\ 
         k \In hshape hosp act u rost /\ j \In ushape u' roles /\ 
         admin \in act /\ rol \in roles,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost rroles jj kk hh,
         ii = kk :++ jj :++ hh -> 
         kk \In hhshape hhosp aact uu rrost -> jj \In uushape uu' rroles ->
         exists jj', 
           mm = kk :++ jj' :++ hh /\
           kk \In hhshape hhosp aact uu rrost /\ 
           jj' \In uushape uu' (remove_role rol rroles.1, 
                                remove_role rol rroles.2)) :=
  Do (read (nat * seq role) @ (fun hosp u => [u.1]);;
      write @ (fun id_roles hosp u => 
        [u.1, (id_roles.1, remove_role rol id_roles.2)])).
Next Obligation.
rewrite !gh; split.
move=> a i [act][u][rost][roles][k][j][h][[->]][A[[/= ->]]C] _. 
rewrite -unA -(unC (a.2.1.1 :-> _ :+ _)) -unA; sauto.
move=>a1 a2 i1 i2[[[[[[[[]]]]]]]]a u r1 r2 [j1 j2][k1 k2][h1 h2]
      [[[-> ->]]][[/= -> ->]][A1 A2]B C[[/= -> ->]]E F _ _.
rewrite -unA unC -unA -(unA (a2.1 :-> _)) (unC (a2.1 :-> _)) 
  -(unA (a2.2.1.1 :-> _)); vauto=> _ _.
rewrite unA unC unA. rewrite (unC (a2.2.1.1 :-> _)) -(unA h2) (unC h2).
set jj'1 := (a1.2.1.1 :-> _); set jj'2 := (a2.2.1.1 :-> _).
exists (jj'1, jj'2); split=>//=. 
Defined.

Program 
Definition switch_user : 
  STsec [::: hospital; user] unit
    (fun hosp u' i => 
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ get_uid u' \in rost,
     fun hhosp uu' yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost -> 
         get_uid uu'.1 \in rrost.1 -> get_uid uu'.2 \in rrost.2 ->
         exists jj', 
           mm = jj' :++ hh /\ 
           jj' \In hhshape hhosp (nil, nil) uu' rrost) :=
  Do (read (user * seq role * seq nat) @ (fun hosp u => [hosp]);;
      write @ (fun uar hosp u => [hosp, (u, @Nil role, get_rost uar)])).
Next Obligation.
rewrite !gh; split=>[[c][u][]|[c1][u1][][c2][u2][]] /=.
- move=>i [a][u1][r][j][h][->] /= [H H0]; case: (H)=>[/= -> _ [U1 _] U2 _].
  by sauto; apply: sval_do=>/=; eexists _; eexists _.
move=>i1 i2 [[[[[]]]]][v1 v2][r1 r2][j1 j2][h1 h2] /=.
do 3 case. move=>[-> ->][/= -> -> [U1 U2] A0 A1 U3 U4] _ _ _ _. vauto=> _ _.
by set k1 := (c1 :-> _); set k2 := (c2 :-> _); exists (k1, k2); split.
Qed.

Program
Definition request_consent :
  STsec [::: hospital; user] unit
    (fun hosp _ i =>
       exists act, exists u, exists rost, 
       exists j, exists h,
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ clinician \in act,
     fun hhosp ppat yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost ->
         mm = ii /\ rrequested_consent (get_uid uu.1, get_uid uu.2) 
                                       (get_uid ppat.1, get_uid ppat.2)) :=
  Do (ret @ (fun _ _ => [tt])).
Next Obligation.
split; first by try sauto. 
by move=> a1 a2 i1 i2 A B _ _; vauto. 
Qed.

Program
Definition give_consent : 
  STsec [::: hospital; user] unit
    (fun hosp doc i =>
      exists act, exists u, exists rost, 
      exists j, exists h,
        i = j :+ h /\ 
        j \In hshape hosp act u rost /\ 
        patient \in act /\ requested_consent (get_uid doc) (get_uid u),
     fun hhosp ddoc yy ii mm => 
       forall aact uu rrost jj hh,
         ii = jj :++ hh -> 
         jj \In hhshape hhosp aact uu rrost ->
         mm = ii /\ cconsented (get_uid ddoc.1, get_uid ddoc.2) 
                               (get_uid uu.1, get_uid uu.2)) :=
  Do (ret @ (fun _ _ => [tt])).
Next Obligation.
split; first by try sauto. 
by move=> a1 a2 i1 i2 A B _ _; vauto. 
Qed.

Program
Definition read_emr : 
  STsec [::: hospital; user] nat
    (fun hosp pat i => 
       exists act, exists u, exists rost, 
       exists j, exists h, 
         i = j :+ h /\ 
         j \In hshape hosp act u rost /\ 
         can_read_emr (get_uid u) (get_uid pat),
     fun hhosp ppat yy ii mm => 
       mm = ii) :=
  Do (ret @ (fun _ _ => [0])).
Next Obligation.
split; first by try sauto. 
by move=> a1 a2 i1 i2 A B _ _; vauto. 
Qed.

End Hospital.

Module H := Hospital.

Canonical Structure role_eqMixin := EqMixin H.eqrP.
Canonical Structure role_eqType := Eval hnf in EqType H.role role_eqMixin.

Module HospitalGlueLemmas.
Lemma sbnd_new_hospital A h act (e: ST [::: H.hospital * H.user] A) :
  (forall hospu k j, 
    def (k :+ j :+ h) -> 
    k \In H.hshape hospu.1 [::] hospu.2 [:: H.get_uid hospu.2] -> 
    j \In H.ushape hospu.2 [:: H.admin] ->
    (k :+ j :+ h) \In safe (e @0 [hospu])) -> 
  def h -> h \In safe (H.new_hospital @0 act;; e).
Proof.
move=> H D; apply sbnd_do =>//=. 
move=> [q u] m [[j1 j2][[u1 u2]][[-> ->]]][/= E F] G.
by case/H.hrefl: (E)=> /= I J; case/H.urefl: (F)=> /= K L; apply: H.
Qed.

Lemma sbnd_switch_user A j h hosp act u u' rost (e: ST [::: unit] A) : 
  (forall j', def (j' :+ h) -> j' \In H.hshape hosp [::] u' rost -> 
    (j' :+ h) \In safe (e @0 [tt])) ->
  def (j :+ h) -> j \In H.hshape hosp act u rost -> H.get_uid u' \in rost ->
  (j :+ h) \In safe (H.switch_user @0 [hosp, u'];; e).
Proof.
move=> H D I Z; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m J K; specialize (J (act, act) (u, u) (rost, rost) (j, j) (h, h)).
case J =>//= [[j1' j2']][L M]; move: L K=>[-> ->] K.
by case/H.hrefl: (M)=>/=N O; case y; apply: H.
Qed.

Lemma sbnd_activate_role A k j h hosp act u rost roles rol 
                         (e: ST [::: unit] A) :
  (forall k', def (k' :+ j :+ h) -> 
    k' \In H.hshape hosp (rol :: act) u rost -> j \In H.ushape u roles ->
    (k' :+ j :+ h) \In safe (e @0 [tt])) ->
  def (k :+ j :+ h) -> 
  k \In H.hshape hosp act u rost -> j \In H.ushape u roles -> rol \in roles ->
  k :+ j :+ h \In safe (H.activate_role rol @0 [hosp];; e).
Proof.
move=> B C D E F; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m G;
specialize (G (act, act) (u, u) (rost, rost) (roles, roles) 
              (j, j) (k, k) (h, h)).
case G =>//=; move=>[j1' j2'][[-> ->]] H I.
by case/H.hrefl: (H)=>/=L M; case y; apply: B.
Qed.

Lemma sbnd_new_user A j h hosp act u rost roles (e: ST [::: H.user] A) :
  (forall y j' u', def (j' :+ u' :+ h) -> 
    j' \In H.hshape hosp act u (H.get_uid y :: rost) -> 
    u' \In H.ushape y roles ->
    (j' :+ u' :+ h) \In safe (e @0 [y])) ->
  def (j :+ h) -> j \In H.hshape hosp act u rost -> H.admin \in act -> 
  j :+ h \In safe (H.new_user @0 [hosp, roles];; e).
Proof.
move=> B C D E; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m G; specialize (G (act, act) (u, u) (rost, rost) (j, j) (h, h)).
case G =>//=; move=>[j1' j2'][[u1' u2']][[-> ->]][H I] J.
by case/H.hrefl: (H)=>/=L M; case/H.urefl: (I)=>/=N O; apply: B.
Qed.

Lemma sbnd_remove_user A k j h hosp act u u' rost roles (e: ST [::: unit] A) :
  (forall k', def (k' :+ h) -> H.get_uid u != H.get_uid u' ->
    k' \In H.hshape hosp act u (H.remove_uid (H.get_uid u') rost) -> 
    (k' :+ h) \In safe (e @0 [tt])) ->
  def (k :+ j :+ h) -> k \In H.hshape hosp act u rost -> 
  j \In H.ushape u' roles ->
  H.admin \in act -> H.get_uid u != H.get_uid u' ->
  k :+ j :+ h \In safe (H.remove_user @0 [hosp, u'];; e).
Proof.
move=> B C D E F G; apply sbnd_do =>//=; first by move=> _; 
  repeat eexists; eauto.
move=> y m H; specialize (H (act, act) (u, u) (rost, rost) (roles, roles) 
                            (j, j) (k, k) (h, h)).
case H =>//=; move=>[k1' k2'][[-> ->]] I J.
by case/H.hrefl: (I)=>/=K L; case y; apply: B.
Qed.

Lemma sbnd_request_consent A j h hosp act u rost pat (e: ST [::: unit] A) :
  (def (j :+ h) -> j \In H.hshape hosp act u rost -> 
    H.requested_consent (H.get_uid u) (H.get_uid pat) ->
    (j :+ h) \In safe (e @0 [tt])) ->
  def (j :+ h) -> j \In H.hshape hosp act u rost -> H.clinician \in act ->
  j :+ h \In safe (H.request_consent @0 [hosp, pat];; e).
Proof.
move=> B C D E; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m G; specialize (G (act, act) (u, u) (rost, rost) (j, j) (h, h)).
by case G =>//=; move=>[-> ->] I J; case y; apply: B.
Qed.

Lemma sbnd_give_consent A j h hosp act u rost doc (e: ST [::: unit] A) :
  (def (j :+ h) -> j \In H.hshape hosp act u rost -> 
    H.consented (H.get_uid doc) (H.get_uid u) ->
    (j :+ h) \In safe (e @0 [tt])) ->
  def (j :+ h) -> j \In H.hshape hosp act u rost -> 
  H.patient \in act -> H.requested_consent (H.get_uid doc) (H.get_uid u) ->
  j :+ h \In safe (H.give_consent @0 [hosp, doc];; e).
Proof.
move=> B C D E F; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m G; specialize (G (act, act) (u, u) (rost, rost) (j, j) (h, h)).
by case G =>//=; move=>[-> ->] I J; case y; apply: B.
Qed.

Lemma sbnd_grant_role A k j h hosp act u u' rost roles rol 
                      (e: ST [::: unit] A) :
  (forall j', def (k :+ j' :+ h) -> 
    k \In H.hshape hosp act u rost -> j' \In H.ushape u' (rol :: roles) ->
    (k :+ j' :+ h) \In safe (e @0 [tt])) ->
  def (k :+ j :+ h) -> 
  k \In H.hshape hosp act u rost -> j \In H.ushape u' roles -> 
  H.admin \in act ->  
  k :+ j :+ h \In safe (H.grant_role rol @0 [hosp, u'];; e).
Proof.
move=> B C D E F; apply sbnd_do =>//=; first by move=> _; repeat eexists; eauto.
move=> y m G; specialize (G (act, act) (u, u) (rost, rost) (roles, roles) 
                         (j, j) (k, k) (h, h)).
case G =>//=; move=>[j1' j2'][[-> ->]] [H I] J.
case/H.hrefl: (H)=>/=L M; case y; apply: B =>//=.
case/H.urefl: (I)=>//=.
Qed.

Lemma sbnd_revoke_role A k j h hosp act u u' rost roles rol 
                       (e: ST [::: unit] A) :
  (forall j', def (k :+ j' :+ h) -> 
    k \In H.hshape hosp act u rost -> 
    j' \In H.ushape u' (H.remove_role rol roles) ->
    (k :+ j' :+ h) \In safe (e @0 [tt])) ->
  def (k :+ j :+ h) -> 
  k \In H.hshape hosp act u rost -> j \In H.ushape u' roles -> 
  H.admin \in act -> rol \in roles ->
  k :+ j :+ h \In safe (H.revoke_role rol @0 [hosp, u'];; e).
Proof.
move=> B C D E F G; apply sbnd_do =>//=; first by move=> _; 
  repeat eexists; eauto.
move=> y m H; specialize (H (act, act) (u, u) (rost, rost) (roles, roles) 
  (j, j) (k, k) (h, h)).
case H =>//=; move=>[j1' j2'][[-> ->]] [I J] K.
case/H.hrefl: (I)=>/=L M; case y; apply: B =>//=.
case/H.urefl: (J)=>//=.
Qed.

End HospitalGlueLemmas. Import HospitalGlueLemmas.

(* 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 : Hospital.breflP bbshape.
Proof. by move=>[b1 b2][k1 k2][t1 t2][-> ->]. Qed.

Program
Definition counting_client :=
  Hospital.endorse (bcmp := bcmp) brefl
    (Do (Hospital.read_emr @ (fun hosp b pat => [hosp, pat]);;
         read _ @ (fun emr hosp b pat => [b]);;
         write @ (fun k emr hosp b pat => [b, emr]);;
         write @ (fun _ k emr hosp b pat => [b, k.+1]);; 
         ret @ (fun _ _ k emr hosp b pat => [emr./2]))).
Next Obligation.
rewrite /Hospital.epost !gh; split=>[[hosp][b][pat][]|[hosp1][b1][pat1][][hosp2][b2][pat2][]] /=.
- move=>i[act][u][rost][j][H1][k][t][h][->]H4 H5; sauto; apply: sbnd_do=>/= D1.
by exists act; exists u; exists rost; exists j; exists (t :+ h); rewrite -!unA. 
by move=>m [[/= -> ->]]; case: (H5)=>/=-> _; rewrite -unA unC -unA; sauto. 
move=>i1 i2 [[[[[[[[]]]]]]]][act1 act2][u1 u2][r1 r2][j1 j2][k1 k2][t1 t2][h1 h2] /=.
case=>[[[->->]]] S [/= -> ->]; case/Hospital.hrefl: (S)=>/= S1 S2 Q1 Q2.
rewrite -unA unC -unA; move/defUnl=>D1. 
rewrite -unA unC -unA; move/defUnl=> D2.
vauto. apply: bnd_do=>//=. 
case:(Q1)=>act3[u3][r3][j3][H1][k][t][h][E1]E2 E3.
case:(Q2)=>act4[u4][r4][j4][H2][k'][t'][h'][E4]E5 E6.
split=> _.
- rewrite unA unC unA E1.
by exists act3; exists u3; exists r3; exists j3; exists (t :+ h); rewrite unA; do !split.
- rewrite unA unC unA E4.
by exists act4; exists u4; exists r4; exists j4; exists (t' :+ h'); rewrite unA; do !split.
move=>y1 y2 m1 m2[[/=-> ->]]; vauto=> _ _.
exists (b1 :-> k1.+1, b2 :-> k2.+1); do !split=>//.
rewrite /plus2 /= unC (unC (b2 :-> _)) -unA -unA unC (unC h2)=>//.
move=>D; move:(D)(D); case/(pts_injP _)=>//<- _. 
case/(pts_inj D1)=>->//=.
Qed.
 
End CountingClient.

(*Safety of the medical records workflow from p.171 of "Roles, stacks,
  histories"*)

Program 
Definition workflow :
  STsec [:::] nat
    (fun i => True,
     fun yy ii mm => True) :=

  (*Create a new hospital with a single user, the hospital director.*)
  Do (H.new_hospital;;

     (*Log in as director.  The effect of this operation is 1) to change the
       current user in the hospital triple, and 2) to clear out any previously
       active roles. *) 
      H.switch_user @ (fun hosp_u => [hosp_u.1, hosp_u.2]);;

        (*Activate the admin role; something like "sudo"*)
        H.activate_role H.admin @ (fun _ hosp_u => [hosp_u.1]);;

        (*Add a new doctor, making her a member of the clinician role*)
        H.new_user @ (fun _ _ hosp_u => [hosp_u.1, [:: H.clinician]]);;

        (*Add a new patient, making her a member of the patient role*)
        H.new_user @ (fun doc _ _ hosp_u => [hosp_u.1, [:: H.patient]]);;

     (*Log in as doc, the doctor user just added to the system*)
      H.switch_user @ (fun pat doc _ _ hosp_u => [hosp_u.1, doc]);;

        (*Activate the clinician role*)
        H.activate_role H.clinician @ (fun _ pat doc _ _ hosp_u => [hosp_u.1]);;

        (*Request pat's consent to read her electronic health record*)
        H.request_consent @ (fun _ _ pat doc _ _ hosp_u => [hosp_u.1, pat]);; 

     (*Log in as pat*)
      H.switch_user @ (fun _ _ _ pat doc _ _ hosp_u => [hosp_u.1, pat]);;
        H.activate_role H.patient @ (fun _ _ _ _ pat doc _ _ hosp_u => 
          [hosp_u.1]);;

        (*Give doc consent.  This operation only succeeds because doc previously
          requested consent*)
        H.give_consent @ (fun _ _ _ _ _ pat doc _ _ hosp_u => [hosp_u.1, doc]);;

     (*Log in as doc*)
      H.switch_user @ (fun _ _ _ _ _ _ pat doc _ _ hosp_u => [hosp_u.1, doc]);;
        H.activate_role H.clinician @ (fun _ _ _ _ _ _ _ pat doc _ _ hosp_u => 
          [hosp_u.1]);;

        (*Read pat's health record*)
        H.read_emr @ (fun _ _ _ _ _ _ _ _ pat doc _ _ hosp_u => 
          [hosp_u.1, pat])).
Next Obligation.
split=>[a i _|]; last by done. sauto. 
(*new_hospital*)
apply: sbnd_new_hospital => y k j A B C. 
move: A; set h := _ :+ _ :+ _; sauto.
rewrite /h; move: h=> _.
rewrite -unA; set h := (j :+ _).
have Z: H.get_uid y.2 \in [:: H.get_uid y.2] by rewrite mem_seq1.
move=> A; move: A B Z. 
(*switch_user 0*)
apply: sbnd_switch_user. (*with (u' := y.2).*)
move: k => _ k; rewrite /h; clear h.
move=> D B; move: D; set h := (k :+ _); sauto.
rewrite /h; clear h; rewrite unA.
have D: H.admin \in [:: H.admin] by rewrite mem_seq1.
move=> A; move: A B C D. 
(*activate_role admin*)
apply sbnd_activate_role.
move: k => _ k; set h := (_ :+ _ :+ _); move=> A B C; move: A; sauto.
rewrite /h; rewrite -unA; set h' := (j :+ _).
have D: H.admin \in [:: H.admin] by rewrite mem_seq1.
move=> A; move: A B D. 
(*new_user doc*)
apply sbnd_new_user.
rewrite /h; clear h; move: j k C h' => ADMIN _ C h'.
move=> doc j DOC D E F.
move: C E; case y => q admn; move=> /= C E; clear y. 
rename h' into FRAME.
move: D; set h := j :+ _ :+ _; sauto.
have D: H.admin \in [:: H.admin] by rewrite mem_seq1.
rewrite /h; move=> G; move: G E D.
clear h; rewrite -unA; set h := (DOC :+ _).
(*new_user pat*)
apply sbnd_new_user.
clear j; move=> pat j PAT D E G; move: D; rewrite /h; clear h.
rewrite -unA; set h := (j :+ _); sauto.
rewrite /h; clear h; set h := (PAT :+ _).
have Z: H.get_uid doc \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or32 =>//.
move=> D; move: D E Z.
(*switch_user doc*)
apply sbnd_switch_user.
rewrite /h; clear h j; move=> j D E; move: D; set h := (j :+ _); sauto.
rewrite /h; clear h; rewrite -(unCA DOC) (unA j).
have: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> H D; move: D E F H; set h := (PAT :+ _).
(*activate_role clinician*)
apply sbnd_activate_role. 
move: j => _ j D A B; rewrite /h in D |- *; clear h.
move: D; rewrite -unA; set h := j :+ _; sauto.
rewrite /h; clear h; set h := (DOC :+ _).
have H: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> D; move: D A H. 
(*request_consent from pat*)
apply sbnd_request_consent.
move=> D E F; move: D.
rewrite /h; clear h; set h := j :+ _; sauto.
rewrite /h; clear h; set h := (DOC :+ _).
have Z: H.get_uid pat \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or31 =>//.
move=> D; move: D E Z.
(*switch_user pat*)
apply sbnd_switch_user.
clear j; move=> j D E; rewrite /h in D |- *; clear h.
move: D; set h := j :+ _; sauto.
rewrite /h; clear h; rewrite -(unCA PAT) (unA j).
have: H.patient \in [:: H.patient] by rewrite mem_seq1.
move=> H D; move: D E G H; set h := (DOC :+ _).
(*activate_role patient*)
apply sbnd_activate_role. 
rewrite /h; clear h j. move=> j D E G. move: D.
set h := j :+ _. sauto.
rewrite /h; clear h. rewrite -unA. set h := (PAT :+ _).
have H: H.patient \in [:: H.patient] by rewrite mem_seq1.
move=> D. move: D E H F. 
(*give_consent to doc*)
apply sbnd_give_consent. 
rewrite /h; clear h; set h := j :+ _. 
move=> D E F. move: D. sauto.
rewrite /h; clear h; set h := PAT :+ _. 
have Z: H.get_uid doc \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or32 =>//.
move=> D; move: D E Z.
(*switch_user doc*)
apply sbnd_switch_user.
rewrite /h; clear j h; move=> j D E. 
move: D; set h := j :+ _; sauto.
rewrite /h (unC PAT) -(unA DOC) (unA j); clear h.
set h := (FRAME :+ _).
have H: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> D; move: D E B H.
(*activate_role doctor*)
apply sbnd_activate_role.
rewrite /h; clear j h; move=> j D E H. 
move: D; rewrite -unA; set h := j :+ _; sauto.
(*read_emr*)
apply: sval_do =>//=.
rewrite /h; move=> D. 
repeat eexists; eauto.
by apply H.can_read_emr_consent.
Defined.

(*In this workflow, the administrator accidentally makes Doc a patient.  To fix
  the problem, the administrator revokes Doc's patient privileges and grants Doc
  clinician privileges. The rest of the workflow is exactly the same as the one
  above.*)

Program 
Definition workflow2 :
  STsec [:::] nat
    (fun i => True,
     fun yy ii mm => True) :=

  (*Create a new hospital with a single user, the hospital director.*)
  Do (H.new_hospital;;

     (*Log in as director.  The effect of this operation is 1) to change the
       current user in the hospital triple, and 2) to clear out any previously
       active roles. *)
      H.switch_user @ (fun hosp_u => [hosp_u.1, hosp_u.2]);; 

        (*Activate the admin role; something like "sudo"*)
        H.activate_role H.admin @ (fun _ hosp_u => [hosp_u.1]);;        

        (*Add a new doctor, accidentally making her a member of the patient
          role*) 
        H.new_user @ (fun _ _ hosp_u => [hosp_u.1, [:: H.patient]]);;
        
        (*Fix the problem by revoking the patient role and adding the clinician
          role*)
        H.revoke_role H.patient @ (fun doc _ _ hosp_u => [hosp_u.1, doc]);;
        H.grant_role H.clinician @ (fun _ doc _ _ hosp_u => [hosp_u.1, doc]);;

        (*Add a new patient, making her a member of the patient role*)
        H.new_user @ (fun _ _ doc _ _ hosp_u => [hosp_u.1, [:: H.patient]]);;

     (*Log in as doc, the doctor user just added to the system*)
      H.switch_user @ (fun pat _ _ doc _ _ hosp_u => [hosp_u.1, doc]);;

        (*Activate the clinician role*)
        H.activate_role H.clinician @ (fun _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1]);;
        (*Request pat's consent to read her electronic health record*)
        H.request_consent @ (fun _ _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1, pat]);; 

     (*Log in as pat*)
      H.switch_user @ (fun _ _ _ pat _ _ doc _ _ hosp_u => [hosp_u.1, pat]);;
        H.activate_role H.patient @ (fun _ _ _ _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1]);;

        (*Give doc consent.  This operation only succeeds because doc previously
          requested consent*)
        H.give_consent @ (fun _ _ _ _ _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1, doc]);;

     (*Log in as doc*)
      H.switch_user @ (fun _ _ _ _ _ _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1, doc]);;
        H.activate_role H.clinician @ 
          (fun _ _ _ _ _ _ _ pat _ _ doc _ _ hosp_u => [hosp_u.1]);;

        (*Read pat's health record*)
        H.read_emr @ (fun _ _ _ _ _ _ _ _ pat _ _ doc _ _ hosp_u => 
          [hosp_u.1, pat])).
Next Obligation.
split=>[a i _|]; last by done. sauto. 
(*new_hospital*)
apply: sbnd_new_hospital => y k j A B C. 
move: A; set h := _ :+ _ :+ _; sauto.
rewrite /h; move: h=> _.
rewrite -unA; set h := (j :+ _).
have Z: H.get_uid y.2 \in [:: H.get_uid y.2] by rewrite mem_seq1.
move=> A; move: A B Z. 
(*switch_user 0*)
apply: sbnd_switch_user. (*with (u' := y.2).*)
move: k => _ k; rewrite /h; clear h.
move=> D B; move: D; set h := (k :+ _); sauto.
rewrite /h; clear h; rewrite unA.
have D: H.admin \in [:: H.admin] by done.
move=> A; move: A B C D. 
(*activate_role admin*)
apply sbnd_activate_role.
move: k => _ k; set h := (_ :+ _ :+ _); move=> A B C; move: A; sauto.
rewrite /h; rewrite -unA; set h' := (j :+ _).
have D: H.admin \in [:: H.admin] by done.
move=> A; move: A B D. 
(*new_user doc*)
apply sbnd_new_user.
rewrite /h; clear h; move: j k C h' => ADMIN _ C h'.
move=> doc j DOC D E F.
move: C E; case y => q admn; move=> /= C E; clear y. 
rename h' into FRAME.
move: D; set h := j :+ _ :+ _; sauto.
have D: H.admin \in [:: H.admin] by done.
have D0: H.patient \in [:: H.patient] by done.
rewrite /h; move=> G. move: G E F D D0. clear h.
(*revoke_role pat*)
apply sbnd_revoke_role. 
rename j into k. move=> j D E /= F. move: D. sauto.
have G: H.admin \in [:: H.admin] by done.
move=> D; move: D E F G.
(*grant_role doc*) 
apply sbnd_grant_role.
clear j. move=> j D E F. clear DOC. 
rename j into DOC; rename k into j.
move: D. sauto. 
rewrite -unA. set (h := DOC :+ FRAME). move=> D.
have G: H.admin \in [:: H.admin] by done.
move: D E G.
(*new_user pat*)
apply sbnd_new_user.
clear j; move=> pat j PAT D E G; move: D; rewrite /h; clear h.
rewrite -unA; set h := (j :+ _); sauto.
rewrite /h; clear h; set h := (PAT :+ _).
have Z: H.get_uid doc \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or32 =>//.
move=> D; move: D E Z.
(*switch_user doc*)
apply sbnd_switch_user.
rewrite /h; clear h j; move=> j D E; move: D; set h := (j :+ _); sauto.
rewrite /h; clear h; rewrite -(unCA DOC) (unA j).
have: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> H D; move: D E F H; set h := (PAT :+ _).
(*activate_role clinician*)
apply sbnd_activate_role. 
move: j => _ j D A B; rewrite /h in D |- *; clear h.
move: D; rewrite -unA; set h := j :+ _; sauto.
rewrite /h; clear h; set h := (DOC :+ _).
have H: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> D; move: D A H. 
(*request_consent from pat*)
apply sbnd_request_consent.
move=> D E F; move: D.
rewrite /h; clear h; set h := j :+ _; sauto.
rewrite /h; clear h; set h := (DOC :+ _).
have Z: H.get_uid pat \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or31 =>//.
move=> D; move: D E Z.
(*switch_user pat*)
apply sbnd_switch_user.
clear j; move=> j D E; rewrite /h in D |- *; clear h.
move: D; set h := j :+ _; sauto.
rewrite /h; clear h; rewrite -(unCA PAT) (unA j).
have: H.patient \in [:: H.patient] by rewrite mem_seq1.
move=> H D; move: D E G H; set h := (DOC :+ _).
(*activate_role patient*)
apply sbnd_activate_role. 
rewrite /h; clear h j. move=> j D E G. move: D.
set h := j :+ _. sauto.
rewrite /h; clear h. rewrite -unA. set h := (PAT :+ _).
have H: H.patient \in [:: H.patient] by rewrite mem_seq1.
move=> D. move: D E H F. 
(*give_consent to doc*)
apply sbnd_give_consent. 
rewrite /h; clear h; set h := j :+ _. 
move=> D E F. move: D. sauto.
rewrite /h; clear h; set h := PAT :+ _. 
have Z: H.get_uid doc \in [:: H.get_uid pat; H.get_uid doc; H.get_uid admn].
  by rewrite mem_seq3; case or3P =>H //; exfalso; apply H; apply Or32 =>//.
move=> D; move: D E Z.
(*switch_user doc*)
apply sbnd_switch_user.
rewrite /h; clear j h; move=> j D E. 
move: D; set h := j :+ _; sauto.
rewrite /h (unC PAT) -(unA DOC) (unA j); clear h.
set h := (FRAME :+ _).
have H: H.clinician \in [:: H.clinician] by rewrite mem_seq1.
move=> D; move: D E B H.
(*activate_role doctor*)
apply sbnd_activate_role.
rewrite /h; clear j h; move=> j D E H. 
move: D; rewrite -unA; set h := j :+ _; sauto.
(*read_emr*)
apply: sval_do =>//=.
rewrite /h; move=> D. 
repeat eexists; eauto.
by apply H.can_read_emr_consent.
Qed.

