ocaml: add uuid bindings.

Signed-off-by: Vincent Hanquez <vincent.hanquez@eu.citrix.com>

4 files changed, 171 insertions, 0 deletions

diff --git a/tools/ocaml/libs/uuid/META.in b/tools/ocaml/libs/uuid/META.in
new file mode 100644
index 0000000000..f33c9804e2
--- /dev/null
+++ b/tools/ocaml/libs/uuid/META.in
@@ -0,0 +1,4 @@
+version = "@VERSION@"
+description = "Uuid - universal identifer"
+archive(byte) = "uuid.cma"
+archive(native) = "uuid.cmxa"
diff --git a/tools/ocaml/libs/uuid/Makefile b/tools/ocaml/libs/uuid/Makefile
new file mode 100644
index 0000000000..8ddb0e2854
--- /dev/null
+++ b/tools/ocaml/libs/uuid/Makefile
@@ -0,0 +1,26 @@
+TOPLEVEL=../..
+include $(TOPLEVEL)/common.make
+
+OBJS = uuid
+INTF = $(foreach obj, $(OBJS),$(obj).cmi)
+LIBS = uuid.cma uuid.cmxa
+
+all: $(INTF) $(LIBS) $(PROGRAMS)
+
+bins: $(PROGRAMS)
+
+libs: $(LIBS)
+
+uuid_OBJS = $(OBJS)
+OCAML_NOC_LIBRARY = uuid
+
+.PHONY: install
+install: $(LIBS) META
+	ocamlfind install -destdir $(DESTDIR)$(shell ocamlfind printconf destdir) -ldconf ignore uuid META $(INTF) $(LIBS) *.a *.cmx
+
+.PHONY: uninstall
+uninstall:
+	ocamlfind remove uuid
+
+include $(TOPLEVEL)/Makefile.rules
+
diff --git a/tools/ocaml/libs/uuid/uuid.ml b/tools/ocaml/libs/uuid/uuid.ml
new file mode 100644
index 0000000000..7c252473f8
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.ml
@@ -0,0 +1,88 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** Type-safe UUIDs. *)
+
+(** Internally, a UUID is simply a string. *)
+type 'a t = string
+
+type cookie = string
+
+let of_string s = s
+let to_string s = s
+
+(* deprecated: we don't need to duplicate the uuid prefix/suffix *)
+let uuid_of_string = of_string
+let string_of_uuid = to_string
+
+let string_of_cookie s = s
+
+let cookie_of_string s = s
+
+(** FIXME: using /dev/random is too slow but using /dev/urandom is too
+    deterministic. *)
+let dev_random = "/dev/urandom"
+
+let read_random n = 
+  let ic = open_in_bin dev_random in
+  try
+    let result = Array.init n (fun _ -> input_byte ic) in
+    close_in ic;
+    result
+  with e ->
+    close_in ic;
+    raise e
+
+let uuid_of_int_array uuid =
+  Printf.sprintf "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+    uuid.(0) uuid.(1) uuid.(2) uuid.(3) uuid.(4) uuid.(5)
+    uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11)
+    uuid.(12) uuid.(13) uuid.(14) uuid.(15)
+
+(** Return a new random UUID *)
+let make_uuid() = uuid_of_int_array (read_random 16)
+
+(** Return a new random, big UUID (hopefully big and random enough to be
+    unguessable) *)
+let make_cookie() =
+  let bytes = Array.to_list (read_random 64) in
+  String.concat "" (List.map (Printf.sprintf "%1x") bytes)
+(*
+  let hexencode x = 
+    let nibble x =
+      char_of_int (if x < 10 
+		   then int_of_char '0' + x
+		   else int_of_char 'a' + (x - 10)) in
+    let result = String.make (String.length x * 2) ' ' in
+    for i = 0 to String.length x - 1 do
+      let byte = int_of_char x.[i] in
+      result.[i * 2 + 0] <- nibble((byte lsr 4) land 15);
+      result.[i * 2 + 1] <- nibble((byte lsr 0) land 15);
+    done;
+    result in
+  let n = 64 in
+  hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of_int x)) (Array.to_list (read_n_random_bytes n))))
+*)
+
+let int_array_of_uuid s =
+  try
+    let l = ref [] in
+    Scanf.sscanf s "%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
+      (fun a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15 ->
+      l := [ a0; a1; a2; a3; a4; a5; a6; a7; a8; a9;
+             a10; a11; a12; a13; a14; a15; ]);
+    Array.of_list !l
+  with _ -> invalid_arg "Uuid.int_array_of_uuid"
diff --git a/tools/ocaml/libs/uuid/uuid.mli b/tools/ocaml/libs/uuid/uuid.mli
new file mode 100644
index 0000000000..3b4a937696
--- /dev/null
+++ b/tools/ocaml/libs/uuid/uuid.mli
@@ -0,0 +1,53 @@
+(*
+ * Copyright (C) 2006-2007 XenSource Ltd.
+ * Copyright (C) 2008      Citrix Ltd.
+ * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published
+ * by the Free Software Foundation; version 2.1 only. with the special
+ * exception on linking described in file LICENSE.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *)
+
+(** Type-safe UUIDs.
+    Probably need to refactor this; UUIDs are used in two places:
+    1. to uniquely name things across the cluster
+    2. as secure session IDs
+    There is the additional constraint that current Xen tools use 
+    a particular format of UUID (the 16 byte variety generated by fresh ())
+*)
+
+(** A 128-bit UUID referencing a value of type 'a. *)
+type 'a t
+
+(** A 512-bit UUID. *)
+type cookie
+
+(** Create a fresh (unique!) UUID *)
+val make_uuid : unit -> 'a t
+
+(** Create a fresh secure (bigger and hopefully unguessable) UUID *)
+val make_cookie : unit -> cookie
+
+(** Create a type-safe UUID. *)
+val of_string : string -> 'a t
+
+(** Marshal a UUID to a (type-unsafe) string. *)
+val to_string : 'a t -> string
+
+(* deprecated alias for previous one *)
+val uuid_of_string : string -> 'a t
+val string_of_uuid : 'a t -> string
+
+val cookie_of_string : string -> cookie
+
+val string_of_cookie : cookie -> string
+
+val uuid_of_int_array : int array -> 'a t
+
+val int_array_of_uuid : 'a t -> int array