1.1 --- a/tools/ocaml/libs/uuid/uuid.ml	Thu Jan 06 17:28:13 2011 +0000
     1.2 +++ b/tools/ocaml/libs/uuid/uuid.ml	Thu Jan 06 17:33:00 2011 +0000
     1.3 @@ -1,6 +1,5 @@
     1.4  (*
     1.5 - * Copyright (C) 2006-2007 XenSource Ltd.
     1.6 - * Copyright (C) 2008      Citrix Ltd.
     1.7 + * Copyright (C) 2006-2010 Citrix Systems Inc.
     1.8   * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
     1.9   *
    1.10   * This program is free software; you can redistribute it and/or modify
    1.11 @@ -14,9 +13,7 @@
    1.12   * GNU Lesser General Public License for more details.
    1.13   *)
    1.14  
    1.15 -(** Type-safe UUIDs. *)
    1.16 -
    1.17 -(** Internally, a UUID is simply a string. *)
    1.18 +(* Internally, a UUID is simply a string. *)
    1.19  type 'a t = string
    1.20  
    1.21  type cookie = string
    1.22 @@ -24,6 +21,8 @@ type cookie = string
    1.23  let of_string s = s
    1.24  let to_string s = s
    1.25  
    1.26 +let null = ""
    1.27 +
    1.28  (* deprecated: we don't need to duplicate the uuid prefix/suffix *)
    1.29  let uuid_of_string = of_string
    1.30  let string_of_uuid = to_string
    1.31 @@ -32,12 +31,34 @@ let string_of_cookie s = s
    1.32  
    1.33  let cookie_of_string s = s
    1.34  
    1.35 -(** FIXME: using /dev/random is too slow but using /dev/urandom is too
    1.36 -    deterministic. *)
    1.37 -let dev_random = "/dev/urandom"
    1.38 +let dev_random = "/dev/random"
    1.39 +let dev_urandom = "/dev/urandom"
    1.40  
    1.41 -let read_random n = 
    1.42 -  let ic = open_in_bin dev_random in
    1.43 +let rnd_array n =
    1.44 +	let fstbyte i = 0xff land i in
    1.45 +	let sndbyte i = fstbyte (i lsr 8) in
    1.46 +	let thdbyte i = sndbyte (i lsr 8) in
    1.47 +	let rec rnd_list n acc = match n with
    1.48 +		| 0 -> acc
    1.49 +		| 1 ->
    1.50 +			let b = fstbyte (Random.bits ()) in
    1.51 +			b :: acc
    1.52 +		| 2 ->
    1.53 +			let r = Random.bits () in
    1.54 +			let b1 = fstbyte r in
    1.55 +			let b2 = sndbyte r in
    1.56 +			b1 :: b2 :: acc
    1.57 +		| n -> 
    1.58 +			let r = Random.bits () in
    1.59 +			let b1 = fstbyte r in
    1.60 +			let b2 = sndbyte r in
    1.61 +			let b3 = thdbyte r in
    1.62 +			rnd_list (n - 3) (b1 :: b2 :: b3 :: acc)
    1.63 +	in
    1.64 +	Array.of_list (rnd_list n [])
    1.65 +
    1.66 +let read_array dev n = 
    1.67 +  let ic = open_in_bin dev in
    1.68    try
    1.69      let result = Array.init n (fun _ -> input_byte ic) in
    1.70      close_in ic;
    1.71 @@ -52,30 +73,14 @@ let uuid_of_int_array uuid =
    1.72      uuid.(6) uuid.(7) uuid.(8) uuid.(9) uuid.(10) uuid.(11)
    1.73      uuid.(12) uuid.(13) uuid.(14) uuid.(15)
    1.74  
    1.75 -(** Return a new random UUID *)
    1.76 -let make_uuid() = uuid_of_int_array (read_random 16)
    1.77 +let make_uuid_prng () = uuid_of_int_array (rnd_array 16)
    1.78 +let make_uuid_urnd () = uuid_of_int_array (read_array dev_urandom 16)
    1.79 +let make_uuid_rnd () = uuid_of_int_array (read_array dev_random 16)
    1.80 +let make_uuid = make_uuid_urnd
    1.81  
    1.82 -(** Return a new random, big UUID (hopefully big and random enough to be
    1.83 -    unguessable) *)
    1.84  let make_cookie() =
    1.85 -  let bytes = Array.to_list (read_random 64) in
    1.86 +  let bytes = Array.to_list (read_array dev_urandom 64) in
    1.87    String.concat "" (List.map (Printf.sprintf "%1x") bytes)
    1.88 -(*
    1.89 -  let hexencode x = 
    1.90 -    let nibble x =
    1.91 -      char_of_int (if x < 10 
    1.92 -		   then int_of_char '0' + x
    1.93 -		   else int_of_char 'a' + (x - 10)) in
    1.94 -    let result = String.make (String.length x * 2) ' ' in
    1.95 -    for i = 0 to String.length x - 1 do
    1.96 -      let byte = int_of_char x.[i] in
    1.97 -      result.[i * 2 + 0] <- nibble((byte lsr 4) land 15);
    1.98 -      result.[i * 2 + 1] <- nibble((byte lsr 0) land 15);
    1.99 -    done;
   1.100 -    result in
   1.101 -  let n = 64 in
   1.102 -  hexencode (String.concat "" (List.map (fun x -> String.make 1 (char_of_int x)) (Array.to_list (read_n_random_bytes n))))
   1.103 -*)
   1.104  
   1.105  let int_array_of_uuid s =
   1.106    try
   1.107 @@ -86,3 +91,10 @@ let int_array_of_uuid s =
   1.108               a10; a11; a12; a13; a14; a15; ]);
   1.109      Array.of_list !l
   1.110    with _ -> invalid_arg "Uuid.int_array_of_uuid"
   1.111 +
   1.112 +let is_uuid str =
   1.113 +	try
   1.114 +		Scanf.sscanf str
   1.115 +			"%02x%02x%02x%02x-%02x%02x-%02x%02x-%02x%02x-%02x%02x%02x%02x%02x%02x"
   1.116 +			(fun _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ -> true)
   1.117 +	with _ -> false

     2.1 --- a/tools/ocaml/libs/uuid/uuid.mli	Thu Jan 06 17:28:13 2011 +0000
     2.2 +++ b/tools/ocaml/libs/uuid/uuid.mli	Thu Jan 06 17:33:00 2011 +0000
     2.3 @@ -1,6 +1,5 @@
     2.4  (*
     2.5 - * Copyright (C) 2006-2007 XenSource Ltd.
     2.6 - * Copyright (C) 2008      Citrix Ltd.
     2.7 + * Copyright (C) 2006-2010 Citrix Systems Inc.
     2.8   * Author Vincent Hanquez <vincent.hanquez@eu.citrix.com>
     2.9   *
    2.10   * This program is free software; you can redistribute it and/or modify
    2.11 @@ -13,41 +12,56 @@
    2.12   * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    2.13   * GNU Lesser General Public License for more details.
    2.14   *)
    2.15 -
    2.16  (** Type-safe UUIDs.
    2.17      Probably need to refactor this; UUIDs are used in two places:
    2.18 -    1. to uniquely name things across the cluster
    2.19 -    2. as secure session IDs
    2.20 +    + to uniquely name things across the cluster
    2.21 +    + as secure session IDs
    2.22 +
    2.23      There is the additional constraint that current Xen tools use 
    2.24      a particular format of UUID (the 16 byte variety generated by fresh ())
    2.25 +
    2.26 +	Also, cookies aren't UUIDs and should be put somewhere else.
    2.27  *)
    2.28  
    2.29 -(** A 128-bit UUID referencing a value of type 'a. *)
    2.30 +(** A 128-bit UUID.  Using phantom types ('a) to achieve the requires type-safety. *)
    2.31  type 'a t
    2.32  
    2.33 -(** A 512-bit UUID. *)
    2.34 +(** Create a fresh UUID *)
    2.35 +val make_uuid : unit -> 'a t
    2.36 +val make_uuid_prng : unit -> 'a t
    2.37 +val make_uuid_urnd : unit -> 'a t
    2.38 +val make_uuid_rnd : unit -> 'a t
    2.39 +
    2.40 +(** Create a UUID from a string. *)
    2.41 +val of_string : string -> 'a t
    2.42 +
    2.43 +(** Marshal a UUID to a string. *)
    2.44 +val to_string : 'a t -> string
    2.45 +
    2.46 +(** A null UUID, as if such a thing actually existed.  It turns out to be
    2.47 + * useful though. *)
    2.48 +val null : 'a t
    2.49 +
    2.50 +(** Deprecated alias for {! Uuid.of_string} *)
    2.51 +val uuid_of_string : string -> 'a t
    2.52 +
    2.53 +(** Deprecated alias for {! Uuid.to_string} *)
    2.54 +val string_of_uuid : 'a t -> string
    2.55 +
    2.56 +(** Convert an array to a UUID. *)
    2.57 +val uuid_of_int_array : int array -> 'a t
    2.58 +
    2.59 +(** Convert a UUID to an array. *)
    2.60 +val int_array_of_uuid : 'a t -> int array
    2.61 +
    2.62 +(** Check whether a string is a UUID. *)
    2.63 +val is_uuid : string -> bool
    2.64 +
    2.65 +(** A 512-bit cookie. *)
    2.66  type cookie
    2.67  
    2.68 -(** Create a fresh (unique!) UUID *)
    2.69 -val make_uuid : unit -> 'a t
    2.70 -
    2.71 -(** Create a fresh secure (bigger and hopefully unguessable) UUID *)
    2.72  val make_cookie : unit -> cookie
    2.73  
    2.74 -(** Create a type-safe UUID. *)
    2.75 -val of_string : string -> 'a t
    2.76 -
    2.77 -(** Marshal a UUID to a (type-unsafe) string. *)
    2.78 -val to_string : 'a t -> string
    2.79 -
    2.80 -(* deprecated alias for previous one *)
    2.81 -val uuid_of_string : string -> 'a t
    2.82 -val string_of_uuid : 'a t -> string
    2.83 -
    2.84  val cookie_of_string : string -> cookie
    2.85  
    2.86  val string_of_cookie : cookie -> string
    2.87 -
    2.88 -val uuid_of_int_array : int array -> 'a t
    2.89 -
    2.90 -val int_array_of_uuid : 'a t -> int array