Ocaml/FAQ/Database Access

(* OCaml's standard library includes bindings to the NDBM database.
   Bindings to other database systems can be found on the web. *)
 
MySQL:
http://raevnos.pennmush.org/code/ocaml-mysql/index.html
 
PostgreSQL:
http://www.ocaml.info/home/ocaml_sources.html#postgresql-ocaml
 
SQLite:
http://www.ocaml.info/home/ocaml_sources.html#ocaml-sqlite3

#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 () =
  try
    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
  then
    begin
      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
      Array.iter
        (fun user ->
           Printf.printf "%s\t%s\n"
             user (try Dbm.find db user with Not_found -> ""))
        users
    end
  else
    begin
      let who = Unix.open_process_in "who" in
      let regexp = Str.regexp "[ \t]+" in
      try
        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))
        done
      with End_of_file ->
        ignore (Unix.close_process_in who)
    end
 
let () = Dbm.close db

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)

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

let () = Dbm.iter (Dbm.replace output) input
 
(*-----------------------------*)
 
let () =
  Dbm.iter
    (fun key value ->
       try
         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)
    input

(* 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
  finally
    (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
 
  begin
    try
      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
  end;
 
  begin
    try 
      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
  end;
 
  Printf.printf "%d: Updated db to %s=%s\n" (Unix.getpid ()) key value

(* 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. *)

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
  begin
    try
      while true do
        in_lines := input_line in_channel :: !in_lines
      done
    with End_of_file ->
      close_in in_channel
  end;
 
  let out_lines = f (List.rev !in_lines) in
  let out_channel = open_out name in
  List.iter
    (fun line ->
       output_string out_channel line;
       output_string out_channel "\n")
    out_lines;
  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 =
         List.fold_right
           (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
         (List.rev
            (Array.to_list
               (Array.mapi
                  (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 *)
       lines)
 
(*-----------------------------
ORIGINAL
 
0: zero
1: one
2: two
3: three
4: four
 
The last record was [four]
 
The first record was [zero]
 
REVERSE
 
5: last
4: three
3: Newbie
2: one
1: New One
0: first
-----------------------------*)

(* 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 =
sig
  type value
  val serialize : value -> string
  val deserialize : string -> value
end
 
(* This module type defines an enhanced Dbm interface that includes a
   type for values to be used instead of strings. *)
module type SerializedDbm =
sig
  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
end
 
(* 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 =
struct
  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
end
 
(* 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 =
  MakeSerializedDbm(struct
                      type value = string list
                      let serialize x = Marshal.to_string x []
                      let deserialize x = Marshal.from_string x 0
                    end)
 
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)

type data = {mutable variable1: string; mutable variable2: string}
 
module PersistentStore =
  MakeSerializedDbm(struct
                      type value = data
                      let serialize x = Marshal.to_string x []
                      let deserialize x = Marshal.from_string x 0
                    end)
 
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 () =
  with_persistent_data
    (fun data ->
       begin
         Printf.printf "variable1 = %s\nvariable2 = %s\n"
           data.variable1 data.variable2;
         data.variable1 <- "foo";
         data.variable2 <- "bar";
       end)

(* 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:
 
   http://merjis.com/developers/mod_caml
 
   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 =
    Dbi_mysql.connect
      ~user:"user"
      ~password:"auth"
      "database" in
 
  let _ = dbh#ex sql [] in
 
  let sth = dbh#prepare sql in
  sth#execute [];
  sth#iter
    (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 =
    Mysql.quick_connect
      ~user:"user"
      ~password:"password"
      ~database:"dbname" () in
 
  ignore (Mysql.exec db "CREATE TABLE users (uid INT, login CHAR(8))");
 
  let passwd = open_in "/etc/passwd" in
  begin
    try
      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)
      done
    with End_of_file ->
      close_in passwd
  end;
 
  ignore (Mysql.exec db "DROP TABLE users");
 
  Mysql.disconnect db

(* 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"
    days.(tm.Unix.tm_wday)
    months.(tm.Unix.tm_mon)
    tm.Unix.tm_mday
    tm.Unix.tm_hour
    tm.Unix.tm_min
    tm.Unix.tm_sec
    (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
    begin
      Printf.printf "Usage: %s path/to/places.sqlite [pattern]\n"
        Sys.argv.(0);
      exit 0
    end
 
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 =
  Printf.sprintf
    "SELECT   visit_date, url, title
     FROM     moz_places p
     JOIN     moz_historyvisits v
     ON       p.id = v.place_id
     %s
     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 ->
        List.iter
          (fun history ->
             Printf.printf "[%s] %s \"%s\"\n"
               (string_of_tm history.visit_date)
               history.url
               history.title)
          !data
    | r ->
        Printf.eprintf "%s: %s\n"
          (Sqlite3.Rc.to_string r)
          (Sqlite3.errmsg db)