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

(* Another module for singly-linked lists, this time *)
(* with a shape predicate that is not abstract, but *)
(* precisely captures and reveals how the list is linked *)
(* The latter allows reasoning about the security of the linkage *)
(* e.g., inserting, then removing, did not change the security *)
(* of the linkage. *)

Module List2. Section List2.
Variable T : Type.
Inductive node : Type := Node {elem : T; next : ptr}.

Definition list := ptr : Type.

Fixpoint lseq (x : ptr) (vs : seq (T * ptr)) : Pred heap := 
  if vs is (v, z)::vt then 
    fun i => exists j, i = x :-> Node v z :+ j /\ j \In lseq z vt
  else fun i => x = null /\ i = empty.

Lemma lseq_null vs i : def i -> i \In lseq null vs -> vs = [::] /\ i = empty.
Proof.
elim: vs i=>[|[v z] vs IH] i D; first by case.
by case=>j [E]; move: E D => -> E; move: (defPt_null E).
Qed.

Lemma lseq_pos vs (x : ptr) i : 
        x != null -> i \In lseq x vs -> 
        exists v, exists z, exists j, 
          [/\ vs = (v, z) :: (behead vs), i = x :-> Node v z :+ j & 
              j \In lseq z (behead vs)].
Proof.
case: vs=>[|[v z] vt] E /=; first by move=>H; case: H E=>->.
by case=>j [->] H; exists v; exists z; exists j.
Qed.

Lemma lseq_func x vs h1 h2 : h1 \In lseq x vs -> h2 \In lseq x vs -> h1 = h2.
Proof.
elim: vs x h1 h2=>[|[z v] vs IH] /= x h1 h2; first by case=>-> -> [_ ->].
by case=>j1 [->] H1 [j2][->] H2; rewrite (IH _ _ _ H1 H2).
Qed. 

Definition shape (p : list) (z : ptr) (vs : seq (T * ptr)) : Pred heap :=
  fun i => exists j, i = p :-> z :+ j /\ j \In lseq z vs.

Definition sshape (pp : d list) (zz : d ptr) 
                  (vvs : d (seq (T * ptr))) : Pred (d heap) := 
  fun ii => ii.1 \In shape pp.1 zz.1 vvs.1 /\ ii.2 \In shape pp.2 zz.2 vvs.2.

Lemma shape_func p z vs h1 h2 : 
        h1 \In shape p z vs -> h2 \In shape p z vs -> h1 = h2.
Proof. by case=>j1 [->] H1 [j2][->] H2; rewrite (lseq_func H1 H2). Qed.

Program 
Definition new : 
  STsec [:::] list
    (fun i => True, 
     fun ii yy mm => 
       exists jj, exists zz, 
         mm = jj :++ ii /\ jj \In sshape yy zz (nil, nil) /\
         ii.1 =~ ii.2 -> yy.1 = yy.2 /\ zz.1 = zz.2) :=
  Do (lalloc @0 [null]).
Next Obligation.
split; first by case=>i _; sstep.
case=>[[]] i1 i2 _ _; v2step=>y1 y2 D1 D2 L _.
exists (y1 :-> null, y2 :-> null); exists (null, null)=>[[_]][_] /=.  
by case/L=>->.
Qed.

(* inserting low *)
Program 
Definition insert : 
  STsec [::: ptr; T] unit 
    (fun p v i => exists h, exists j, exists z, exists vs,
                    i = j :+ h /\ j \In shape p z vs, 
     fun pp vv ii yy mm => 
       forall hh jj zz vvs, 
         ii = jj :++ hh -> jj \In sshape pp zz vvs -> 
       exists jj', exists zz', 
         mm = jj' :++ hh /\ 
         jj' \In sshape pp zz' ((vv.1, zz.1)::vvs.1, 
                                (vv.2, zz.2)::vvs.2) /\
         (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> zz'.1 = zz'.2)) :=
  Do (read ptr @ (fun p v => [p]);;
      lalloc @ (fun head p v => [Node v head]);;
      write @ (fun x (head :ptr) p v => [p, x])).
Next Obligation.
rewrite !gh; split=>[[p][v][]|[p1][v1][][p2][v2][]] /=.
- move=>i [h][_][z][vs][->][j][->] H; rewrite -unA.
  by sstep=>l; sstep.
move=>i1 i2 [[[[[]]]]] /= h [j1 j2][z1 z2] vs [[[-> ->]]][/=].
case=>k1 [->] H1 [k2][->] H2 _ _; apply: vrf2D=>D1 D2.
rewrite -!unA in D1 D2 *; v2step=>l1 l2; v2step=>_ _.
rewrite !unA -!(pull p1) -!(pull p2) /plus2 => H.
eexists (_, _); exists (l1, l2); rewrite /plus2 /=.
split=>//; rewrite -!unA; split; first by hhauto.
by rewrite !unA; case/H.
Qed. 

Program 
Definition remove : 
  STsec [::: list] (option T)
    (fun p i => exists h, exists j, exists z, exists vs, 
                  i = j :+ h /\ j \In shape p z vs,
     fun pp ii yy mm => 
       forall hh jj zz vvs, 
         ii = jj :++ hh -> jj \In sshape pp zz vvs -> 
       exists jj', exists zz',
         mm = jj' :++ hh /\ jj' \In sshape pp zz' (behead vvs.1, behead vvs.2) /\ 
         (if vvs.1 is (v1, z1)::vs1 return Prop then 
             zz'.1 = z1 /\ yy.1 = Some v1 else zz'.1 = null /\ yy.1 = None) /\
         (if vvs.2 is (v2, z2)::vs2 return Prop then 
             zz'.2 = z2 /\ yy.2 = Some v2 else zz'.2 = null /\ yy.2 = None)) := 
  Do (read ptr @ (fun p => [p]);; 
      Ifbool (fun head p => head == null) then 
        ret @ (fun head p => [None])
      else
        read _ @ (fun head p => [head]);;
        write @ (fun v head p => [p, next v]);;
        dealloc @ (fun _ v head p => [head]);;
        ret @ (fun _ _ v head p => [Some (elem v)])
      with [::: ptr; ptr], option T, 
        (fun head p i => exists h, exists j, exists vs, 
                           i = p :-> head :+ j :+ h /\ j \In lseq head vs,
         fun head p i y m => 
           forall h j vs, 
             i = (p.1 :-> head.1, p.2 :-> head.2) :++ j :++ h ->
             j.1 \In lseq head.1 vs.1 -> j.2 \In lseq head.2 vs.2 -> 
           exists s, exists z',
             m = s :++ h /\
             s.1 \In shape p.1 z'.1 (behead vs.1) /\ 
             s.2 \In shape p.2 z'.2 (behead vs.2) /\ 
             (if vs.1 is (v1, z1)::vs1 return Prop then 
                 z'.1 = z1 /\ y.1 = Some v1 else z'.1 = null /\ y.1 = None) /\
             (if vs.2 is (v2, z2)::vs2 return Prop then 
                 z'.2 = z2 /\ y.2 = Some v2 else z'.2 = null /\ y.2 = None))).
Next Obligation.
rewrite !gh; split=>[[head][p][]|[head1][p1][][head2][p2][]] /=.
- move=>i [h][j][vs][->] H.
  case: ifP=>E; first by sstep.
  case: (lseq_pos (negbT E) H)=>x [z][k][_][->] H1.
  by rewrite -!unA; sstep.
move=>i1 i2 [[[[]]]] [h1 h2] j vs /= [[[-> ->]]] H1 H2 _ _. 
case: vs.1 H1=>[|[v1 z1] vs1] /=; case: vs.2 H2=>[|[v2 z2] vs2] /=.
- case=>-> -> [-> ->]; rewrite eq_refl !unh0.
  by v2step=>_ _; eexists (_, _); eexists (_, _); hhauto.
- case=>h [->] H1 [-> ->]; apply: vrf2D=>_; rewrite -!unA unCA =>D2. 
  rewrite (negbTE (defPt_null D2)) !un0h. 
  apply/vrfS1; vstep=>_; vstep.
  exists (p1 :-> null, p2 :-> z2 :+ h); exists (null, z2). 
  by rewrite !unA !un0h; hhauto.
- case=>-> -> [h][->] H1; apply: vrf2D; rewrite -!unA unCA=>D1 _.
  rewrite (negbTE (defPt_null D1)) !un0h.
  apply/vrfS2; vstep=>_; vstep.
  exists (p1 :-> z1 :+ h, p2 :-> null); exists (z1, null).
  by rewrite !unA un0h; hhauto.
case=>j2 [->] H2 [j1][->] H1.
rewrite -!unA -(pull head1) -(pull head2); apply: vrf2D=>D1 D2.
rewrite (negbTE (defPt_null D1)) (negbTE (defPt_null D2)).
v2step=>_ _; exists (p1 :-> z1 :+ j1, p2 :-> z2 :+ j2); exists (z1, z2).
by rewrite !unA !un0h; hhauto.
Qed.
Next Obligation.
rewrite !gh;split=>[[p][]|[p1][][p2][]] /=.
- move=>i [h][j][head][vs][->][k][->] H1; rewrite -!unA.
  by sstep; ssimpl; apply: sval_do=>/=; rewrite unA; eauto.
move=>i1 i2 [[[[[]]]]] h j z' vs /= [[[-> ->]]][] /=.
case=>k1 [->] H1 [k2][->] H2 _ _.
rewrite -!unA; v2step; v2simpl; apply: val_do=>/=[|y1 y2 m1 m2]; rewrite !unA.
- by eauto 10.
case/(_ (_, _) (_, _) vs (erefl _) H1 H2)=>t [[z1' z2']][[-> ->]]{H1 H2} /=.
case=>[[s1]][->] H1 [[s2]][->]; move: H1. 
case: vs.1 => [|[v1 z1] vs1]; case: vs.2 => [|[v2 z2] vs2] /=;
[case=>-> -> [-> ->][[_ ->]][_ ->]; rewrite !unh0 |
 case=>-> -> /= H2 [[_ ->]][<- ->]; rewrite !unh0 |
 move=>H1 [-> ->][[<- ->]][_ ->] | 
 move=>H1 H2 [[<- ->]][[<- ->]]];
by eexists (_, _); eexists (_, _); hhauto.
Qed.

End List2. End List2.

(* okay, now the ratification for this implementation of linked lists *)

Module Type AliceSig4.
Parameter alice : Type.

Parameter sshape : d alice -> d nat -> d nat -> Pred (d heap).
Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Parameter srefl : 
  forall aa ss pp ii, ii \In sshape aa ss pp -> 
    ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2. 

Parameter rreadable : d alice -> Pred (d heap). 
Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Parameter rrefl : 
  forall aa ii, ii \In rreadable aa -> 
                ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2. 

Parameter read_salary : 
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> 
         jj \In rreadable aa -> mm = ii /\ yy = ss).

Section Ratify.
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 a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Parameter ratify : 
  breflP -> 
  STsec [::: alice; bob] nat 
    (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
     fun aa bb ii yy mm => 
       forall jj, rreadable aa jj -> epost aa bb jj yy ii mm) ->
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm).

End Ratify.

End AliceSig4.

Module Alice4 : AliceSig4.

Definition alice : Type := (ptr * ptr) % type.

Definition salary (a : alice) := a.1.
Definition passwd (a : alice) := a.2.

Definition sshape (aa : d alice) (ss : d nat) (pp : d nat) : Pred (d heap) := 
  [Pred ii | [/\ ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1, 
                 ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2,
                 ss.1 = ss.2 & pp.1 = pp.2]]. 

Definition shape a s p : Pred heap := 
  fun m => (m, m) \In sshape (a, a) (s, s) (p, p). 

Lemma srefl : forall aa ss pp ii,
        ii \In sshape aa ss pp -> 
        ii.1 \In shape aa.1 ss.1 pp.1 /\ ii.2 \In shape aa.2 ss.2 pp.2.
Proof. by move=>[a1 a2][s1 s2][p1 p2][i1 i2][/= -> ->]. Qed.

Definition rreadable (aa : d alice) : Pred (d heap) := 
  [Pred ii | exists ss:d nat, exists pp:d nat, 
               ii.1 = salary aa.1 :-> ss.1 :+ passwd aa.1 :-> pp.1 /\
               ii.2 = salary aa.2 :-> ss.2 :+ passwd aa.2 :-> pp.2].

Definition readable a : Pred heap := 
  fun m => (m, m) \In rreadable (a, a).

Lemma rrefl aa ii : 
        ii \In rreadable aa -> 
        ii.1 \In readable aa.1 /\ ii.2 \In readable aa.2.
Proof.
move: aa ii=>[a1 a2][i1 i2][[s1 s2]][[p1 p2]][/= -> ->].
by split; [exists (s1, s1); exists (p1, p1) | 
           exists (s2, s2); exists (p2, p2)].
Qed.

Program
Definition read_salary :
  STsec [::: alice] nat
    (fun a i => exists s, exists p, exists j, exists h, 
                  i = j :+ h /\ j \In shape a s p /\ j \In readable a, 
     fun aa ii yy mm => 
       forall ss pp jj hh, 
         ii = jj :++ hh -> jj \In sshape aa ss pp -> jj \In rreadable aa -> 
         mm = ii /\ yy = ss) :=
  Do (read _ @ (fun a => [salary a])).
Next Obligation.
rewrite !gh; split=>[[a][]|[a1][[a2]][]] /=. 
- by move=>i [s][p][j][h][->][[/= -> _ _ _]] _; sstep.
move=>i1 i2 [[[[[]]]]][s1 s2][p1 p2][j1 j2][h1 h2][[[-> ->]]][/= -> -> -> ->] _.
by move=>_ _; v2step.
Qed.

Section Ratify.
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 a b j : Pred heap := 
  fun i => exists s, exists p, exists k, exists t, exists h, 
           [/\ i = j :+ t :+ h, j \In shape a s p & t \In bshape b k].

Definition epost aa bb jj (yy : d nat) ii mm := 
  forall ss pp kk tt hh, 
    ii = jj :++ tt :++ hh -> 
    jj \In sshape aa ss pp -> tt \In bbshape bb kk ->
  exists jj', exists tt', 
    mm = jj' :++ tt' :++ hh /\ jj' \In sshape aa ss pp /\ 
    tt' \In bbshape bb (bcmp kk.1, bcmp kk.2) /\
    (jj.1 :+ hh.1 =~ jj.2 :+ hh.2 -> tt.1 = tt.2 -> tt'.1 = tt'.2). 

Program
Definition ratify (pf : breflP) 
  (e : STsec [::: alice; bob] nat 
         (fun a b i => exists j, j \In readable a /\ i \In epre a b j,
          fun aa bb ii yy mm => 
            forall jj, rreadable aa jj -> epost aa bb jj yy ii mm)) : 
  STsec [::: alice; bob] nat
    (fun a b i => exists j, i \In epre a b j, 
     fun aa bb ii yy mm => forall jj, epost aa bb jj yy ii mm) :=
   Do (e @ (fun a b => [a, b])).
Next Obligation.
rewrite !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][s][p][k][t][h][->][/= -> _ _ _] H.
  ssimpl; apply: sval_do=>/=.
  eexists _; split; last by exists s, p, k, t, h.
  by exists (s, s), (p, p).
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[-> ->]]] H1; case: (H1)=>/= E1 E2 E3 E4 H _ _.
rewrite {s1}E3 {p1}E4 in E1 E2 H1 *. 
case: (pf _ _ _ H)=>/= H2 H3; rewrite E1 E2.
have H4 : (j1, j2) \In rreadable (a1, a2).
- by rewrite /rreadable E1 E2; eexists (_, _); eexists (_, _).
v2simpl; apply: val_do=>[|y1 y2 m1 m2] /=.
- by split; (eexists _; split; last by [hhauto; eauto];
             by eexists (_, _), (_, _)).
move/(_ (j1, j2) H4 (s2, s2) (p2, p2) (k1, k2) (t1, t2) (h1, h2))=>/= L _ _.
by rewrite -E1 -E2 in L *; apply: L.
Qed.

End Ratify.

End Alice4.

(* now let's say Bob is using this kind of lists for his local state *)

Module LinkedListClient2.

Definition bob := List2.list.
Definition G := seq nat : Type.

Definition bbshape (bb : d bob) (kk : d G) := 
  [Pred ii | exists zz, exists xx, 
               ii \In List2.sshape bb zz (zip kk.1 xx.1, zip kk.2 xx.2) 
               /\ bb.1 = bb.2].
Definition bcmp : G -> G := fun k => [:: 1 & k]. 

Lemma brefl : Alice4.breflP bbshape.
Proof.
move=>[b1 b2][k1 k2][t1 t2][[/= z1 z2]][[x1 x2]][[/= H1 H2]] E. 
by split; [exists (z1, z1); exists (x1, x1) | exists (z2, z2); exists (x2, x2)].
Qed.

Program
Definition linked_client :=
  Alice4.ratify (bcmp := bcmp) brefl
    (Do (Alice4.read_salary @ (fun a b => [a]);;
         hide (List2.insert _) @ (fun x a b => [b, 1]);;
         ret @ (fun _ x a b => [x./2]))).
Next Obligation.
rewrite /Alice4.epost !gh; split=>[[a][b][]|[a1][b1][][a2][b2][]] /=.
- move=>i [j][H1][s][p][k][t][h][->] H2 [[/= z1 z2]][[x1 x2]].
  case=>[[/= H3 H4]] E; rewrite -!unA.
  ssimpl; apply: sbnd_do=>[|y m] /=; first by eauto 10.     
  case/(_ (s, s) (p, p) (_, _) (_, _) (erefl _) H2 H1)=>[[-> _]][-> _].
  ssimpl; apply: sbnd_do=>[|y1 m1] /=; rewrite unCA; first by eauto 10.
  case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) (conj H3 H3))=>[[t1' t2']] /=.
  by case=>[[z1' z2']][[->]] E1 {H3 H4} [[/= H3 H4]] F; sstep. 
move=>i1 i2 [[[[[[[]]]]]]][j1 j2][s1 s2][p1 p2][k1 k2][t1 t2][h1 h2] /=.
move=>[[[R]]][-> ->] S [[z1 z2]][[x1 x2]][[/= H1 H2]] E1 _ _.
apply: vrf2D; rewrite -!unA=>D1 D2.
case/Alice4.srefl: (S)=>/= S1 S2; case/Alice4.rrefl: (R)=>/= R1 R2.
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; first by split; eauto 10.
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) S R)=>
     [[->{m1}->{m2}]][->{y1}->{y2}].
v2simpl; apply: bnd_do=>[|y1 y2 m1 m2] /=; rewrite -(unCA t1) -(unCA t2).
- by split; eauto 10. 
case/(_ (_, _) (_, _) (_, _) (_, _) (erefl _) (conj H1 H2))=>/= [[t1' t2']].
case=>[[z1' z2']][[->{m1} ->{m2}]][[/= H1' H2' H3']]; v2step=>D1' D2'.
exists (j1, j2); exists (t1', t2'); rewrite (unCA t1') (unCA t2') !unA. 
do !split=>//; first by exists (z1', z2'); exists (z1::x1, z2::x2). 
move=>E2 E3 /=. 
case: H1' H2' D1' D2'=>l1 [->] /= [l1'][->] H1' [l2][/= ->][l2'][->]  
      H2' D1' D2'.
case: H1 H2 D1 D2 E3 H3' =>r1' [->] R1' [r2'][->] R2'.
rewrite (unCA j1) (unCA j2) -E1=>D1 D2; move/defUnl: (D1)=>D3.
heap_cancel=>// _ E3 Z3 E. 
rewrite (_ : l1' = l2').
- by rewrite -Z3 E //; apply: lowUn=>//; rewrite E3 Z3.
by rewrite (List2.lseq_func H1' R1') (List2.lseq_func H2' R2').
Qed.

End LinkedListClient2.

(* todo : in-place reversal for lists of this kind *)
(* it has a weird loop invariant, because one has to *)
(* specify how the reversal modifies the linkage *)
