Section LockServ.
Variable num_Clients : nat.
Definition Client_index := (fin num_Clients).
Inductive Name :=
| Client : Client_index -> Name
| Server : Name.
Definition list_Clients := map Client (all_fin num_Clients).
Definition Name_eq_dec : forall a b : Name, {a = b} + {a <> b}.
decide equality. apply fin_eq_dec.
Qed.
Inductive Msg :=
| Lock   : Msg
| Unlock : Msg
| Locked : Msg.
Definition Msg_eq_dec : forall a b : Msg, {a = b} + {a <> b}.
decide equality.
Qed.
Definition Input := Msg.
Definition Output := Msg.
Record Data := mkData { queue : list Client_index ; held : bool }.
Definition init_data (n : Name) : Data := mkData [] false.
Inductive Label :=
| InputLock : Client_index -> Label
| InputUnlock : Client_index -> Label
| MsgUnlock : Label
| MsgLock : Client_index -> Label
| MsgLocked : Client_index -> Label
| Nop
| Silent.
Definition Handler (S : Type) := GenHandler (Name * Msg) S Output Label.
Definition ClientNetHandler (i : Client_index) (m : Msg) : Handler Data :=
match m with
| Locked => (put (mkData [] true)) ;; write_output Locked ;; ret (MsgLocked i)
| _ => ret Nop
end.
Definition ClientIOHandler (i : Client_index) (m : Msg) : Handler Data :=
match m with
| Lock => send (Server, Lock) ;; ret (InputLock i)
| Unlock => data <- get ;;
when (held data)
(put (mkData [] false) >>
send (Server, Unlock));;
ret (InputUnlock i)
| _ => ret Nop
end.
Definition ServerNetHandler (src : Name) (m : Msg) : Handler Data :=
st <- get ;;
let q := queue st in
match m with
| Lock =>
match src with
| Server => ret Nop
| Client c =>
when (null q) (send (src, Locked)) >> put (mkData (q++[c]) (held st)) >> ret (MsgLock c)
end
| Unlock => match q with
| _ :: x :: xs => put (mkData (x :: xs) (held st)) >> send (Client x, Locked)
| _ => put (mkData [] (held st))
end ;;
ret MsgUnlock
| _ => ret Nop
end.
Definition ServerIOHandler (m : Msg) : Handler Data := ret Nop.
Definition NetHandler (nm src : Name) (m : Msg) : Handler Data :=
match nm with
| Client c => ClientNetHandler c m
| Server   => ServerNetHandler src m
end.
Definition InputHandler (nm : Name) (m : Msg) : Handler Data :=
match nm with
| Client c => ClientIOHandler c m
| Server   => ServerIOHandler m
end.
Ltac handler_unfold :=
repeat (monad_unfold; unfold NetHandler,
InputHandler,
ServerNetHandler,
ClientNetHandler,
ClientIOHandler,
ServerIOHandler in *).
Definition Nodes := Server :: list_Clients.
Proof using.
intros.
unfold Nodes, list_Clients.
simpl.
destruct n.
- right.
apply in_map.
apply all_fin_all.
- left.
reflexivity.
Qed.
Proof using.
unfold Nodes, list_Clients.
apply NoDup_cons.
- in_crush. discriminate.
- apply NoDup_map_injective.
+ intros. congruence.
+ apply all_fin_NoDup.
Qed.
Global Instance LockServ_BaseParams : BaseParams :=
{
data   := Data ;
input  := Input ;
output := Output
}.
Global Instance LockServ_LabeledParams : LabeledMultiParams LockServ_BaseParams :=
{
lb_name := Name ;
lb_msg  := Msg ;
lb_msg_eq_dec := Msg_eq_dec ;
lb_name_eq_dec := Name_eq_dec ;
lb_nodes := Nodes ;
lb_all_names_nodes := In_n_Nodes ;
lb_no_dup_nodes := nodup ;
label := Label ;
label_silent := Silent;
lb_init_handlers := init_data ;
lb_net_handlers := fun dst src msg s =>
runGenHandler s (NetHandler dst src msg) ;
lb_input_handlers := fun nm msg s =>
runGenHandler s (InputHandler nm msg)
}.
Global Instance LockServ_MultiParams : MultiParams LockServ_BaseParams :=
unlabeled_multi_params.
(* This is the fundamental safety property of the system: No two different clients can (think they) hold the lock at once. *)
Definition mutual_exclusion (sigma : name -> data) : Prop :=
forall m n,
held (sigma (Client m)) = true ->
held (sigma (Client n)) = true ->
m = n.
(* The system enforces mutual exclusion at the server. Whenever a client believs it holds the lock, that client is at the head of the server's queue. *)
Definition locks_correct (sigma : name -> data) : Prop :=
forall n,
held (sigma (Client n)) = true ->
exists t,
queue (sigma Server) = n :: t.
Proof using.
unfold locks_correct, mutual_exclusion.
intros.
repeat find_apply_hyp_hyp.
break_exists.
find_rewrite. find_inversion.
auto.
Qed.
Definition valid_unlock q h c p :=
pSrc p = Client c /\
(exists t, q = c :: t) /\
h = false.
Definition locks_correct_unlock (sigma : name -> data) (p : packet) : Prop :=
pBody p = Unlock ->
exists c, valid_unlock (queue (sigma Server)) (held (sigma (Client c))) c p.
Definition valid_locked q h c p :=
pDst p = Client c /\
(exists t, q = c :: t) /\
h = false.
Definition locks_correct_locked (sigma : name -> data) (p : packet) : Prop :=
pBody p = Locked ->
exists c, valid_locked (queue (sigma Server)) (held (sigma (Client c))) c p.
Definition LockServ_network_invariant (sigma : name -> data) (p : packet) : Prop :=
locks_correct_unlock sigma p /\
locks_correct_locked sigma p.
Definition LockServ_network_network_invariant (p q : packet) : Prop :=
(pBody p = Unlock -> pBody q = Unlock -> False) /\
(pBody p = Locked -> pBody q = Unlock -> False) /\
(pBody p = Unlock -> pBody q = Locked -> False) /\
(pBody p = Locked -> pBody q = Locked -> False).
Proof using.
unfold LockServ_network_network_invariant.
intuition.
Qed.
Proof using.
unfold locks_correct. simpl. discriminate.
Qed.
Proof using.
handler_unfold.
intros.
repeat break_match; repeat tuple_inversion;
subst; simpl in *; subst; simpl in *.
- left. eexists. intuition.
- left. eexists. intuition.
- left. eexists. intuition.
- auto.
- auto.
Qed.
Proof using.
unfold locks_correct.
intuition.
destruct (Name_eq_dec (Client x) (Client n)).
- find_inversion. exfalso.
rewrite_update.
congruence.
- rewrite_update.
auto.
Qed.
Ltac set_up_input_handlers :=
intros;
find_apply_lem_hyp InputHandler_cases;
intuition idtac; try break_exists; intuition idtac; subst;
repeat find_rewrite;
simpl in *; intuition idtac; repeat find_inversion;
try now rewrite update_nop_ext.
Proof using.
set_up_input_handlers;
auto using locks_correct_update_false.
Qed.
Proof using.
handler_unfold.
intros.
repeat break_match; repeat tuple_inversion; subst; intuition (auto; congruence).
Qed.
Proof using.
handler_unfold.
intros.
repeat break_match; repeat tuple_inversion; subst.
- find_apply_lem_hyp null_sound. find_rewrite. simpl.
intuition. left. eexists. intuition.
- simpl. find_apply_lem_hyp null_false_neq_nil.
intuition. left. eexists. intuition.
- simpl. intuition (auto; congruence).
- simpl. destruct st; simpl in *; subst; intuition (auto; congruence).
- simpl in *. intuition.
- simpl in *. intuition eauto.
- simpl. intuition (auto; congruence).
Qed.
Definition at_head_of_queue sigma c := (exists t, queue (sigma Server) = c :: t).
Proof using.
unfold at_head_of_queue.
firstorder.
Qed.
Proof using.
unfold locks_correct.
intros.
destruct (Name_eq_dec (Client c) (Client n)); rewrite_update; try find_inversion; auto.
Qed.
Proof using.
unfold locks_correct_locked.
firstorder.
repeat find_rewrite. find_inversion.
eauto using at_head_of_queue_intro.
Qed.
Proof using.
unfold locks_correct.
intros.
rewrite_update.
now find_higher_order_rewrite.
Qed.
Proof using.
unfold locks_correct.
intros.
find_apply_hyp_hyp. break_exists.
eauto using at_head_of_queue_intro.
Qed.
Proof using.
unfold at_head_of_queue.
firstorder.
congruence.
Qed.
Proof using.
intuition.
destruct (held (sigma (Client c))) eqn:?; auto.
exfalso. eauto using at_head_of_nil, locks_correct_true_at_head_of_queue.
Qed.
Proof using.
intros.
destruct (held (sigma (Client c))) eqn:?; auto.
firstorder.
find_copy_apply_lem_hyp locks_correct_true_at_head_of_queue; auto.
unfold at_head_of_queue in *. break_exists.
congruence.
Qed.
Proof using.
unfold locks_correct, at_head_of_queue.
firstorder.
rewrite_update.
eauto.
Qed.
Proof using.
unfold at_head_of_queue.
intuition. break_exists.
rewrite_update.
find_rewrite.
eauto.
Qed.
Ltac set_up_net_handlers :=
intros;
match goal with
| [ H : context [ NetHandler (pDst ?p) _ _ _ ] |- _ ] =>
destruct (pDst p) eqn:?
end; simpl in *;
[find_apply_lem_hyp ClientNetHandler_cases |
find_apply_lem_hyp ServerNetHandler_cases; intuition; try break_exists ];
intuition; subst;
simpl in *; intuition;
repeat find_rewrite;
repeat find_inversion;
simpl in *;
try now rewrite update_nop_ext.

Lemma locks_correct_net_handlers :
forall p sigma u st' out ms,
NetHandler (pDst p) (pSrc p) (pBody p) (sigma (pDst p)) = (u, out, st', ms) ->
locks_correct sigma ->
locks_correct_unlock sigma p ->
locks_correct_locked sigma p ->
locks_correct (update name_eq_dec sigma (pDst p) st').