libmojave/util/lm_db.ml

   1 (*
   2  * Simple value database.  The entries in the database have
   3  * the following format.
   4  *
   5  *     - Field label (int)
   6  *     - Hostname (string)
   7  *     - Magic number (16 bytes)
   8  *     - Digest (used on the source file, for up-to-date info)
   9  *     - Value (marshaled)
  10  *
  11  * Invariant:
  12  *     - There is at most one entry for each host/field label.
  13  *
  14  *       If the magic number doesn't match, then the entry is
  15  *       out-of-date, and should be replaced.
  16  *
  17  * In some cases, the hostname doesn't matter.  Even so, if there
  18  * is an entry with the current hostname, and the magic number
  19  * doesn't match, it is out-of-date.
  20  *
  21  * NOTE: This has been updated to allowed for key-value pairs
  22  * in the header.  It looks pretty dumb, but I (jyh) want to keep
  23  * the file format backward-compatible.  So we stuff all the key/value
  24  * pairs in the magic number.
  25  *
  26  * ----------------------------------------------------------------
  27  *
  28  * @begin[license]
  29  * Copyright (C) 2004-2007 Mojave Group, California Institute of Technology and
  30  * HRL Laboratories, LLC
  31  *
  32  * This library is free software; you can redistribute it and/or
  33  * modify it under the terms of the GNU Lesser General Public
  34  * License as published by the Free Software Foundation,
  35  * version 2.1 of the License.
  36  *
  37  * This library is distributed in the hope that it will be useful,
  38  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  39  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  40  * Lesser General Public License for more details.
  41  *
  42  * You should have received a copy of the GNU Lesser General Public
  43  * License along with this library; if not, write to the Free Software
  44  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
  45  *
  46  * Additional permission is given to link this library with the
  47  * OpenSSL project's "OpenSSL" library, and with the OCaml runtime,
  48  * and you may distribute the linked executables.  See the file
  49  * LICENSE.libmojave for more details.
  50  *
  51  * Author: Jason Hickey @email{jyh@cs.caltech.edu}
  52  * Modified By: Aleksey Nogin @email{anogin@hrl.com}
  53  * @end[license]
  54  *)
  55 open Lm_printf
  56 open Lm_debug
  57
  58 let debug_db =
  59    create_debug (**)
  60       { debug_name = "db";
  61         debug_description = "Display debugging information for marshaling operations";
  62         debug_value = false
  63       }
  64
  65 type t = Unix.file_descr
  66
  67 type tag = int
  68 type magic = string
  69 type digest = string
  70 type hostname = string
  71 type named_value = string * string
  72
  73 type entry_pred = tag -> named_value list -> hostname -> digest -> bool
  74
  75 let first_entry_tag = 1000
  76
  77 (*
  78  * Some kinds of entries are host-independent.
  79  *)
  80 type host =
  81    HostIndependent
  82  | HostDependent
  83
  84 (*
  85  * Codes during unmarshaling.
  86  *)
  87 type 'a unmarshal =
  88    UnmarshalValue of 'a
  89  | UnmarshalNext
  90
  91 (*
  92  * Codes during removal.
  93  *)
  94 type remove =
  95    RemoveEntry of int
  96  | RemoveNext
  97  | RemoveRest
  98
  99 (*
 100  * Version number.
 101  *)
 102 let magic = 0x56e50f8b
 103
 104 (*
 105  * Marshaling.
 106  *)
 107 let hostname = Unix.gethostname ()
 108 let digest_length = 16
 109
 110 (*
 111  * File operations.
 112  *)
 113
 114 (*
 115  * Win32 doesn't have a general truncate, so seek and truncate.
 116  *)
 117 let seek_and_truncate fd pos =
 118    let _ = Unix.lseek fd pos Unix.SEEK_SET in
 119       Lm_unix_util.ftruncate fd
 120
 121 (*
 122  *
 123  * When an entry is removed, copy the remaining parts of
 124  * the file.
 125  *)
 126 let bufsize = 4096
 127
 128 let file_shift fd pos1 pos2 =
 129    let buf = String.create bufsize in
 130    let rec copy pos1 pos2 =
 131       let _ = Unix.lseek fd pos2 Unix.SEEK_SET in
 132       let amount = Unix.read fd buf 0 bufsize in
 133          if amount <> 0 then
 134             let _ = Unix.lseek fd pos1 Unix.SEEK_SET in
 135                assert (Unix.write fd buf 0 amount = amount);
 136                copy (pos1 + amount) (pos2 + amount)
 137          else
 138             pos1
 139    in
 140    let pos = copy pos1 pos2 in
 141       seek_and_truncate fd pos;
 142       ignore (Unix.lseek fd pos1 Unix.SEEK_SET)
 143
 144 (*
 145  * If some kind of error happens while removing an entry,
 146  * truncate the file at this point.
 147  *)
 148 let remove_entry fd pos off =
 149    try file_shift fd pos off with
 150       Unix.Unix_error _ ->
 151          seek_and_truncate fd pos
 152
 153 (*
 154  * Unmarshaling.
 155  *)
 156 let unmarshal_magic inx =
 157    try input_binary_int inx = magic with
 158       End_of_file ->
 159          false
 160
 161 let unmarshal_tag inx =
 162    input_binary_int inx
 163
 164 let unmarshal_digest inx =
 165    let s = String.create digest_length in
 166       really_input inx s 0 digest_length;
 167       s
 168
 169 let unmarshal_string inx =
 170    let len = input_binary_int inx in
 171       if len < 0 || len >= 1024 then
 172          raise (Failure "unmarshal_string")
 173       else
 174          let s = String.create len in
 175             really_input inx s 0 len;
 176             s
 177
 178 let unmarshal_strings_old inx =
 179    let magic = unmarshal_string inx in
 180       ["MAGIC", magic]
 181
 182 let unmarshal_strings_new inx =
 183    (* Total size of all the entries *)
 184    let _ = input_binary_int inx in
 185
 186    (* Number of key/value pairs *)
 187    let len = input_binary_int inx in
 188       (* Read the key/value pairs *)
 189       if len < 0 || len >= 1024 then
 190          raise (Failure "unmarshal_string")
 191       else
 192          let rec loop strings i =
 193             if i = len then
 194                List.rev strings
 195             else
 196                let key = unmarshal_string inx in
 197                let value = unmarshal_string inx in
 198                   loop ((key, value) :: strings) (i + 1)
 199          in
 200             loop [] 0
 201
 202 let unmarshal_strings inx tag =
 203    if tag < first_entry_tag then
 204       unmarshal_strings_old inx
 205    else
 206       unmarshal_strings_new inx
 207
 208 (*
 209  * Search for the appropriate entry.
 210  *)
 211 let find_entry fd filename test =
 212    let _ = Unix.lseek fd 0 Unix.SEEK_SET in
 213    let inx = Unix.in_channel_of_descr fd in
 214    let head = String.create Marshal.header_size in
 215
 216    (* Find the appropriate entry *)
 217    let unmarshal_entry () =
 218       (* Get the header *)
 219       let tag = unmarshal_tag inx in
 220       let host = unmarshal_string inx in
 221       let strings = unmarshal_strings inx tag in
 222       let digest = unmarshal_digest inx in
 223          if test tag strings host digest then begin
 224             (* Found a matching entry *)
 225             if !debug_db then
 226                eprintf "@[<v 3>Marshal.from_channel: %s@ save tag/digest: %d/%s@." (**)
 227                   filename
 228                   tag (Lm_string_util.hexify digest);
 229             let x = UnmarshalValue (Marshal.from_channel inx) in
 230                if !debug_db then
 231                   eprintf "Marshal.from-channel: done@.";
 232                x
 233          end
 234          else
 235             (* Skip over this entry *)
 236             let () = really_input inx head 0 Marshal.header_size in
 237             let size = Marshal.data_size head 0 in
 238             let pos = pos_in inx + size in
 239                seek_in inx pos;
 240                UnmarshalNext
 241    in
 242
 243    (*
 244     * Search through the entries.  If an exception is raised,
 245     * truncate the file at the start of the entry.
 246     *)
 247    let rec search () =
 248       let start = pos_in inx in
 249       let code =
 250          try unmarshal_entry () with
 251             End_of_file
 252           | Failure _
 253           | Sys_error _
 254           | Invalid_argument _ ->
 255                if !debug_db then
 256                   eprintf "Lm_db.find: %s: failed@." filename;
 257                seek_and_truncate fd start;
 258                raise Not_found
 259       in
 260          match code with
 261             UnmarshalValue x ->
 262                x
 263           | UnmarshalNext ->
 264                search ()
 265    in
 266       if unmarshal_magic inx then
 267          search ()
 268       else
 269          raise Not_found
 270
 271 let find fd filename (tag, host_mode) magic digest =
 272    let test tag' strings host' digest' =
 273       match strings with
 274          ["MAGIC", magic'] ->
 275             tag' = tag && magic' = magic && digest' = digest && (host_mode = HostIndependent || host' = hostname)
 276        | _ ->
 277             false
 278    in
 279       find_entry fd filename test
 280
 281 (*
 282  * Remove an entry.  Search through the existing entries
 283  * to find one with the same tag.  If the host is significant,
 284  * remove only the entry with the same hostname.  Otherwise,
 285  * remove the entry with the same magic number.
 286  *)
 287 let marshal_magic fd =
 288    seek_and_truncate fd 0;
 289    let outx = Unix.out_channel_of_descr fd in
 290       output_binary_int outx magic;
 291       Pervasives.flush outx
 292
 293 let remove_entry fd filename test =
 294    let head = String.create Marshal.header_size in
 295
 296    (* Find the appropriate entry *)
 297    let unmarshal_entry inx =
 298       (* Get the header *)
 299       let tag = unmarshal_tag inx in
 300       let host = unmarshal_string inx in
 301       let strings = unmarshal_strings inx tag in
 302       let digest = unmarshal_digest inx in
 303       let () = really_input inx head 0 Marshal.header_size in
 304       let size = Marshal.data_size head 0 in
 305       let pos = pos_in inx + size in
 306          if test tag strings host digest then
 307             RemoveEntry pos
 308          else begin
 309             seek_in inx pos;
 310             RemoveNext
 311          end
 312    in
 313
 314    (*
 315     * Search through the entries.  If an exception is raised,
 316     * truncate the file at the start of the entry.
 317     *)
 318    let rec search inx =
 319       let start = pos_in inx in
 320       let code =
 321          try unmarshal_entry inx with
 322             End_of_file
 323           | Failure _
 324           | Sys_error _
 325           | Invalid_argument _ ->
 326                RemoveRest
 327       in
 328          match code with
 329             RemoveEntry pos ->
 330                remove_entry fd start pos;
 331                ignore(Unix.lseek fd 0 Unix.SEEK_SET);
 332                let inx = Unix.in_channel_of_descr fd in
 333                   seek_in inx start;
 334                   search inx
 335           | RemoveNext ->
 336                search inx
 337           | RemoveRest ->
 338                seek_and_truncate fd start
 339    in
 340    let _ = Unix.lseek fd 0 Unix.SEEK_SET in
 341    let inx = Unix.in_channel_of_descr fd in
 342       if unmarshal_magic inx then
 343          search inx
 344       else
 345          marshal_magic fd
 346
 347 let remove fd filename (tag, host_mode) magic =
 348    let test tag' strings host' digest' =
 349       match strings with
 350          ["MAGIC", magic'] ->
 351             tag' = tag && (host' = hostname || host_mode = HostIndependent && magic' = magic)
 352        | _ ->
 353             false
 354    in
 355       remove_entry fd filename test
 356
 357 (*
 358  * Add an entry.
 359  * Remove any existing entry, and add the new one to the end of the
 360  * file.
 361  *)
 362 let marshal_tag outx tag =
 363    output_binary_int outx tag
 364
 365 let marshal_digest outx digest =
 366    assert (String.length digest = digest_length);
 367    Pervasives.output_string outx digest
 368
 369 let marshal_string outx s =
 370    let len = String.length s in
 371       output_binary_int outx len;
 372       Pervasives.output_string outx s
 373
 374 let marshal_strings outx sl =
 375    let len =
 376       List.fold_left (fun len (key, value) ->
 377             len + String.length key + String.length value + 8) 4 sl
 378    in
 379       output_binary_int outx len;
 380       output_binary_int outx (List.length sl);
 381       List.iter (fun (key, value) ->
 382             marshal_string outx key;
 383             marshal_string outx value) sl
 384
 385 let marshal_entry fd filename tag magic_number digest x =
 386    let outx = Unix.out_channel_of_descr fd in
 387       marshal_tag outx tag;
 388       marshal_string outx hostname;
 389       marshal_string outx magic_number;
 390       marshal_digest outx digest;
 391       if !debug_db then
 392          eprintf "@[<v 3>Marshal.to_channel: %s@ tag/digest: %d/%s@]@." (**)
 393             filename
 394             tag (Lm_string_util.hexify digest);
 395       Marshal.to_channel outx x [];
 396       if !debug_db then
 397          eprintf "Marshal.to_channel: %s: done@." filename;
 398       Pervasives.flush outx
 399
 400 let add fd filename ((code, _) as tag) magic digest x =
 401    remove fd filename tag magic;
 402    marshal_entry fd filename code magic digest x
 403
 404 let append_entry fd filename tag strings digest x =
 405    let _ = Unix.lseek fd 0 Unix.SEEK_END in
 406    let outx = Unix.out_channel_of_descr fd in
 407       marshal_tag outx tag;
 408       marshal_string outx hostname;
 409       marshal_strings outx strings;
 410       marshal_digest outx digest;
 411       if !debug_db then
 412          eprintf "@[<v 3>Marshal.to_channel: %s@ tag/digest: %d/%s@]@." (**)
 413             filename
 414             tag (Lm_string_util.hexify digest);
 415       Marshal.to_channel outx x [];
 416       if !debug_db then
 417          eprintf "Marshal.to_channel: %s: done@." filename;
 418       Pervasives.flush outx
 419
 420 (*
 421  * -*-
 422  * Local Variables:
 423  * End:
 424  * -*-
 425  *)