14. Database Access


(* OCaml's standard library includes bindings to the NDBM database.
   Bindings to other database systems can be found on the web. *)




Making and Using a DBM File

#load "dbm.cma";;

(* open database *)
let db = Dbm.opendbm filename [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666

(* retrieve from database *)
let v = Dbm.find db key

(* put value into database *)
let () = Dbm.replace db key value

(* check whether in database *)
let () =
    ignore (Dbm.find db key);
    (* ... *)
  with Not_found ->
    (* ... *)

(* delete from database *)
let () = Dbm.remove db key

(* close the database *)
let () = Dbm.close db


(* userstats - generates statistics on who is logged in. *)
(* call with an argument to display totals *)

#load "dbm.cma";;
#load "str.cma";;
#load "unix.cma";;

let db_file = "/tmp/userstats.db"  (* where data is kept between runs *)
let db = Dbm.opendbm db_file [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666

let () =
  if Array.length Sys.argv > 1
      let sort a = Array.sort compare a; a in
      let keys db = Array.of_list
        (let accu = ref [] in
         Dbm.iter (fun key _ -> accu := key :: !accu) db;
         !accu) in
      let users = Array.sub Sys.argv 1 (Array.length Sys.argv - 1) in
      let users = if users = [|"ALL"|] then sort (keys db) else users in
        (fun user ->
           Printf.printf "%s\t%s\n"
             user (try Dbm.find db user with Not_found -> ""))
      let who = Unix.open_process_in "who" in
      let regexp = Str.regexp "[ \t]+" in
        while true do
          (* extract username (first thing on the line) and update *)
          let line = input_line who in
          let user = List.hd (Str.split_delim regexp line) in
          let count =
            try int_of_string (Dbm.find db user)
            with Not_found -> 0 in
          Dbm.replace db user (string_of_int (count + 1))
      with End_of_file ->
        ignore (Unix.close_process_in who)

let () = Dbm.close db

Emptying a DBM File

let () =
  let db = Dbm.opendbm filename [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666 in
    let keys = ref [] in
    Dbm.iter (fun key _ -> keys := key :: !keys) db;
    List.iter (Dbm.remove db) !keys;
    Dbm.close db


let () =
  Sys.remove filename;
  ignore (Dbm.opendbm filename [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666)

Converting Between DBM Files

(* OCaml does not come with support for any DBM-style databases other
   than NDBM, and no third-party libraries appear to be available. *)

Merging DBM Files

let () = Dbm.iter (Dbm.replace output) input


let () =
    (fun key value ->
         let existing = Dbm.find output key value in
         (* decide which value to use and replace if necessary *)
       with Not_found ->
         Dbm.replace output key value)

Locking DBM Files

(* dblockdemo - demo locking dbm databases *)
(* Thanks to Janne Hellsten for posting sample code on caml-list! *)

#load "dbm.cma";;
#load "unix.cma";;

let db_file = "/tmp/foo.db"
let lock_file = "/tmp/foo.lock"

let key = try Sys.argv.(1) with Invalid_argument _ -> "default"
let value = try Sys.argv.(2) with Invalid_argument _ -> "magic"
let value = value ^ " " ^ (string_of_int (Unix.getpid ()))

let finally handler f x =
  let result = try f x with e -> handler (); raise e in handler (); result

let create_lock name =
  if not (Sys.file_exists name) then
    let out_channel = open_out name in close_out out_channel

let with_lock name command f =
  create_lock name;
  let fd = Unix.openfile name [Unix.O_RDWR] 0o660 in
    (fun () -> Unix.close fd)
    (fun () -> Unix.lockf fd command 0; f ()) ()

let create_db name =
  if not (Sys.file_exists (name ^ ".dir")) then
    let db = Dbm.opendbm name [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o660 in
    Dbm.close db

let () =
  create_db db_file;

  let do_read () =
    let db = Dbm.opendbm db_file [Dbm.Dbm_rdonly] 0o660 in
    Printf.printf "%d: Read lock granted\n" (Unix.getpid ());
    flush stdout;
    let oldval = try Dbm.find db key with Not_found -> "" in
    Printf.printf "%d: Old value was %s\n" (Unix.getpid ()) oldval;
    flush stdout;
    Dbm.close db in

  let do_write () =
    let db = Dbm.opendbm db_file [Dbm.Dbm_rdwr] 0o660 in
    Printf.printf "%d: Write lock granted\n" (Unix.getpid ());
    flush stdout;
    Dbm.replace db key value;
    Unix.sleep 10;
    Dbm.close db in

      with_lock lock_file Unix.F_TRLOCK do_read;
    with Unix.Unix_error (error, "lockf", _) ->
      Printf.printf "%d: CONTENTION; can't read during write update! \
                         Waiting for read lock (%s) ...\n"
        (Unix.getpid ()) (Unix.error_message error);
      flush stdout;
      with_lock lock_file Unix.F_RLOCK do_read

      with_lock lock_file Unix.F_TLOCK do_write;
    with Unix.Unix_error (error, "lockf", _) ->
      Printf.printf "%d: CONTENTION; must have exclusive lock! \
                         Waiting for write lock (%s) ...\n"
        (Unix.getpid ()) (Unix.error_message error);
      flush stdout;
      with_lock lock_file Unix.F_LOCK do_write

  Printf.printf "%d: Updated db to %s=%s\n" (Unix.getpid ()) key value

Sorting Large DBM Files

(* OCaml's Dbm module does not provide any mechanism for a custom
   comparison function. If you need the keys in a particular order
   you can load them into memory and use List.sort, Array.sort, or
   a Set. This may not be practical for very large data sets. *)

Treating a Text File as a Database Array

let with_lines_in_file name f =
  if not (Sys.file_exists name)
  then (let out_channel = open_out name in close_out out_channel);

  let in_channel = open_in name in
  let in_lines = ref [] in
      while true do
        in_lines := input_line in_channel :: !in_lines
    with End_of_file ->
      close_in in_channel

  let out_lines = f (List.rev !in_lines) in
  let out_channel = open_out name in
    (fun line ->
       output_string out_channel line;
       output_string out_channel "\n")
  flush out_channel;
  close_out out_channel

let () =
  (* first create a text file to play with *)
  with_lines_in_file "/tmp/textfile"
    (fun lines ->
       ["zero"; "one"; "two"; "three"; "four"]);

  with_lines_in_file "/tmp/textfile"
    (fun lines ->
       (* print the records in order. *)
       print_endline "ORIGINAL\n";
       Array.iteri (Printf.printf "%d: %s\n") (Array.of_list lines);

       (* operate on the end of the list *)
       let lines = List.rev lines in
       let a = List.hd lines in
       let lines = List.rev ("last" :: lines) in
       Printf.printf "\nThe last record was [%s]\n" a;

       (* and the beginning of the list *)
       let a = List.hd lines in
       let lines = "first" :: (List.tl lines) in
       Printf.printf "\nThe first record was [%s]\n" a;

       (* remove the record "four" *)
       let lines =
         List.filter (function "four" -> false | _ -> true) lines in

       (* replace the record "two" with "Newbie" *)
       let lines =
         List.map (function "two" -> "Newbie" | x -> x) lines in

       (* add a new record after "first" *)
       let lines =
           (fun x a ->
              if x = "first"
              then x :: "New One" :: a
              else x :: a)
           lines [] in

       (* now print the records in reverse order *)
       print_endline "\nREVERSE\n";
       List.iter print_string
                  (fun i line -> Printf.sprintf "%d: %s\n" i line)
                  (Array.of_list lines))));

       (* return the new list, which will be written back to the file *)


0: zero
1: one
2: two
3: three
4: four

The last record was [four]

The first record was [zero]


5: last
4: three
3: Newbie
2: one
1: New One
0: first

Storing Complex Data in a DBM File

(* OCaml includes a Marshal module which does binary serialization and
   deserialization of arbitrary data structures. However, it is not
   type-safe, so coding errors can result in segmentation faults.

   One way to eliminate this risk is to use functors. The following
   example builds a functor called "MakeSerializedDbm" which extends
   the Dbm module to provide type-safe serialization of values using
   a user-defined method such as (but not limited to) Marshal. *)

#load "dbm.cma";;

(* This module type defines a serialization method. It contains a type
   and functions to convert values of that type to and from strings. *)
module type SerializedDbmMethod =
  type value
  val serialize : value -> string
  val deserialize : string -> value

(* This module type defines an enhanced Dbm interface that includes a
   type for values to be used instead of strings. *)
module type SerializedDbm =
  type t
  type value
  val opendbm : string -> Dbm.open_flag list -> int -> t
  val close : t -> unit
  val find : t -> string -> value
  val add : t -> string -> value -> unit
  val replace : t -> string -> value -> unit
  val remove : t -> string -> unit
  val firstkey : t -> string
  val nextkey : t -> string
  val iter : (string -> value -> 'a) -> t -> unit

(* Here is the functor itself. It takes a SerializedDbmMethod as an
   argument and returns a SerializedDbm module instance as a result.
   It is defined mainly in terms of Dbm, with a few overridden
   definitions where the value type is needed. *)
module MakeSerializedDbm (Method : SerializedDbmMethod)
  : SerializedDbm with type value = Method.value =
  include Dbm
  type value = Method.value
  let find db key = Method.deserialize (find db key)
  let add db key value = add db key (Method.serialize value) 
  let replace db key value = replace db key (Method.serialize value)
  let iter f db = iter (fun key value -> f key (Method.deserialize value)) db

(* Now, we can easily build typed Dbm interfaces by providing the type
   and conversion functions. In this case, we use Marshal, but we could
   also use other string-based serialization formats like JSON or XML. *)
module StringListDbm =
                      type value = string list
                      let serialize x = Marshal.to_string x []
                      let deserialize x = Marshal.from_string x 0

let db = StringListDbm.opendbm "data.db" [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666
let () =
  StringListDbm.replace db "Tom Christiansen"
    [ "book author"; "tchrist@perl.com" ];
  StringListDbm.replace db "Tom Boutell"
    [ "shareware author"; "boutell@boutell.com" ];

  (* names to compare *)
  let name1 = "Tom Christiansen" in
  let name2 = "Tom Boutell" in

  let tom1 = StringListDbm.find db name1 in
  let tom2 = StringListDbm.find db name2 in

  let show strings =
    "[" ^ (String.concat "; "
             (List.map (fun s -> "\"" ^ s ^ "\"") strings)) ^ "]" in
  Printf.printf "Two Toming: %s %s\n" (show tom1) (show tom2)

Persistent Data

type data = {mutable variable1: string; mutable variable2: string}

module PersistentStore =
                      type value = data
                      let serialize x = Marshal.to_string x []
                      let deserialize x = Marshal.from_string x 0

let with_persistent_data f =
  let db =
    PersistentStore.opendbm "data.db" [Dbm.Dbm_rdwr; Dbm.Dbm_create] 0o666 in
  let data =
    try PersistentStore.find db "data"
    with Not_found -> {variable1=""; variable2=""} in
  f data;
  PersistentStore.replace db "data" data
  PersistentStore.close db

let () =
    (fun data ->
         Printf.printf "variable1 = %s\nvariable2 = %s\n"
           data.variable1 data.variable2;
         data.variable1 <- "foo";
         data.variable2 <- "bar";

Executing an SQL Command Using DBI and DBD

(* This example uses OCaml DBI, a component of the mod_caml web development
   library that provides a database abstraction API very similar to that of
   Perl DBI. It is available for download here:


   Drivers for particular databases are listed in the introduction. *)

#load "nums.cma";;
#directory "+num-top";;
#load "num_top.cma";;

#directory "+mysql";;
#load "mysql.cma";;

#directory "+dbi";;
#load "dbi.cma";;
#load "dbi_mysql.cmo";;

(* With dbi installed via findlib, the above can be shortened to:

   #use "topfind";;
   #require "dbi.mysql";;

let () =
  let dbh =
      "database" in

  let _ = dbh#ex sql [] in

  let sth = dbh#prepare sql in
  sth#execute [];
    (fun row ->
       print_endline (Dbi.sdebug row);
       (* ... *)

  sth#finish ();
  dbh#close ()


(* dbusers - manage MySQL user table *)

(* This example uses the Mysql module directly rather than going through
   OCaml DBI. See the introduction for a link to the Mysql library. *)

#load "unix.cma";;
#directory "+mysql";;
#load "mysql.cma";;

let () =
  let db =
      ~database:"dbname" () in

  ignore (Mysql.exec db "CREATE TABLE users (uid INT, login CHAR(8))");

  let passwd = open_in "/etc/passwd" in
      while true do
        let line = input_line passwd in
        let user = String.sub line 0 (String.index line ':') in
        let {Unix.pw_uid=uid; pw_name=name} = Unix.getpwnam user in
        let sql =
          Printf.sprintf "INSERT INTO users VALUES( %s, %s )"
            (Mysql.ml2int uid)
            (Mysql.ml2str name) in
        ignore (Mysql.exec db sql)
    with End_of_file ->
      close_in passwd

  ignore (Mysql.exec db "DROP TABLE users");

  Mysql.disconnect db

Program: ggh - Grep Netscape Global History

(* Search the history using the Places SQLite database, new in Firefox 3.
   Pattern-matching uses simple substrings, but it could be expanded to use
   Str or Pcre by installing a user-defined function. *)

#directory "+sqlite3";;
#load "sqlite3.cma";;
#load "unix.cma";;

type history = { visit_date : Unix.tm;
                 url        : string;
                 title      : string; }

let days = [| "Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat" |]
let months = [| "Jan"; "Feb"; "Mar"; "Apr"; "May"; "Jun";
                "Jul"; "Aug"; "Sep"; "Oct"; "Nov"; "Dec" |]

let string_of_tm tm =
  Printf.sprintf "%s %s %2d %02d:%02d:%02d %04d"
    (tm.Unix.tm_year + 1900)

let tm_of_micros micros =
  let time = float_of_string micros /. 1000000. in
  Unix.localtime time

let () =
  if Array.length Sys.argv < 2 then
      Printf.printf "Usage: %s path/to/places.sqlite [pattern]\n"
      exit 0

let file =
  if Array.length Sys.argv > 1 then Sys.argv.(1) else "places.sqlite"

let pattern =
  if Array.length Sys.argv > 2 then Some Sys.argv.(2) else None

let db = Sqlite3.db_open file

let sql =
    "SELECT   visit_date, url, title
     FROM     moz_places p
     JOIN     moz_historyvisits v
     ON       p.id = v.place_id
     ORDER BY visit_date DESC"
    (match pattern with
       | None -> ""
       | Some s ->
           (Printf.sprintf "WHERE url LIKE '%%%s%%' OR title LIKE '%%%s%%'"
              s s))

let data = ref []

let res =
  Sqlite3.exec_not_null_no_headers db
    ~cb:(fun row ->
           data := {visit_date = tm_of_micros row.(0);
                    url = row.(1);
                    title = row.(2)} :: !data) sql

let () =
  match res with
    | Sqlite3.Rc.OK ->
          (fun history ->
             Printf.printf "[%s] %s \"%s\"\n"
               (string_of_tm history.visit_date)
    | r ->
        Printf.eprintf "%s: %s\n"
          (Sqlite3.Rc.to_string r)
          (Sqlite3.errmsg db)