From 05f0550f29bb9b99251aef52eb545b59741e3687 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Tue, 17 Sep 2013 12:17:23 +0100
Subject: [PATCH] Implement persistent Memory.

---
 goaljobs.ml | 60 ++++++++++++++++++++++++++++++++++++++++++++++++++++++------
 1 file changed, 54 insertions(+), 6 deletions(-)

diff --git a/goaljobs.ml b/goaljobs.ml
index 39c9007..0d6f56b 100644
--- a/goaljobs.ml
+++ b/goaljobs.ml
@@ -195,13 +195,61 @@ let change_file_extension ext filename =
 val filter_file_extension : string -> string list -> string
 *)
 
-(* XXX The Memory is not actually persistent yet. *)
-let memory = Hashtbl.create 13
+(* Persistent memory is stored in $HOME/.goaljobs-memory.  We have to
+ * lock this file each time we read or write because multiple concurrent
+ * jobs may access it at the same time.
+ *
+ * XXX Replace this with a more efficient and less fragile implementation.
+ *)
+
+type ('a, 'b) alternative = Either of 'a | Or of 'b
+let with_memory_locked ?(write = false) f =
+  let filename = getenv "HOME" // ".goaljobs-memory" in
+  let fd = openfile filename [O_RDWR; O_CREAT] 0o644 in
+  lockf fd (if write then F_LOCK else F_RLOCK) 0;
+  let r = try Either (f fd) with exn -> Or (exn) in
+  lockf fd F_ULOCK 0;
+  match r with
+  | Either x -> x
+  | Or exn -> raise exn
+
+let memory_exists key =
+  with_memory_locked (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.mem memory key
+  )
 
-let memory_exists = Hashtbl.mem memory
-let memory_set = Hashtbl.replace memory
-let memory_get k = try Some (Hashtbl.find memory k) with Not_found -> None
-let memory_delete = Hashtbl.remove memory
+let memory_get key =
+  with_memory_locked (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      try Some (Hashtbl.find memory key) with Not_found -> None
+  )
+
+let memory_set key value =
+  with_memory_locked ~write:true (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.replace memory key value;
+      let chan = out_channel_of_descr fd in
+      seek_out chan 0;
+      output_value chan memory
+  )
+
+let memory_delete key =
+  with_memory_locked ~write:true (
+    fun fd ->
+      let chan = in_channel_of_descr fd in
+      let memory : (string, string) Hashtbl.t = input_value chan in
+      Hashtbl.remove memory key;
+      let chan = out_channel_of_descr fd in
+      seek_out chan 0;
+      output_value chan memory
+  )
 
 let published_goals = ref []
 let publish name fn = published_goals := (name, fn) :: !published_goals
-- 
1.8.3.1