Source

amall / src / dbi / dbi.ml

Full commit
    open Am_Ops
    ;

    type sql_t =
      [= `Null
      |  `String of string
      |  `Binary of string
      ]
    ;

    type dbd_error = exn
    ;

    type dbi_error = (dbd_error * (dbd_error -> string))
    ;

    exception Edbi of dbi_error
    ;

    exception EGeneric of string
    ;

    exception Ecolumn of string
    ;

    exception Econnection_closed of string
    ;

    value (string_of_dbi_error : dbi_error -> string) (dbd_error, to_string) =
      to_string dbd_error
    ;

    value () = Printexc.register_printer
      (fun [ Edbi (err, to_string) -> Some ("Edbi: " ^ to_string err)
           | _ -> None
           ])
    ;

    exception End_of_result
    ;

    open Printf
    ;

    value string_of_exn = fun
      [ Edbi e -> sprintf "database error: %s" &
          string_of_dbi_error e
      | e -> sprintf "non-database error: %s" &
          Printexc.to_string e
      ]
    ;

    value (error : dbi_error -> 'a) e =
      raise & Edbi e
    ;

    value error_gen msg =
      error &
      ( EGeneric msg
      , fun [ EGeneric msg -> msg | _ -> assert False ]
      )
    ;

    value error_eor () =
      error &
      ( End_of_result
      , fun [ End_of_result -> "end of result set" | _ -> assert False ]
      )
    ;

    value error_column msg =
      error &
      ( Ecolumn msg
      , fun [ Ecolumn msg -> msg | _ -> assert False ]
      )
    ;

    value error_connection_closed backend =
      error &
      ( Econnection_closed backend
      , fun [ Econnection_closed b -> sprintf
                "connection to database is closed (backend: %s)"
                b
            | _ -> assert False
            ]
      )
    ;


    class virtual conn_info ?host ?port ?dbname ?user ?password () =
      object
        method host : option string = host;
        method port : option string = port;
        method dbname : option string = dbname;
        method user : option string = user;
        method password : option string = password;
      end
    ;


(* pg's:
    type result_status =
      [ Empty_query     (** (err) String sent to the backend was empty *)
      | Command_ok      (** (ok) Successful completion of a command returning no data *)
      | Tuples_ok       (** (ok) The query successfully executed *)
      | Copy_out        (** (err) Copy Out (from server) data transfer started *)
      | Copy_in         (** (err) Copy In (to server) data transfer started *)
      | Bad_response    (** (err) The server's response was not understood *)
      | Err Nonfatal_error  (* (err) *)
      | Err Fatal_error     (* (err) *)
      ]
    ;
*)

    (* result_status compatible with Res.res *)
    type result_status =
      [= `Ok of ok_result_status
      |  `Error of exn
      ]
    and ok_result_status =
      [= `Cmd
      |  `Data
      ]
    ;


    (* no {co,contra}variances because of arrays of 'v and 'p. *)

    class virtual result_data =
      object (_self)
        method virtual status : result_status;

        method virtual ncols : int;
        method virtual names : array string;
        method virtual nrows : option int;  (* None for stream-fetching  *)
        method virtual affected : string;  (* for >2^30 rows maybe? *)

(*
        method fetchrow_array () : array 'v =
          Array.of_list (self#fetchrow_list ());
        method fetchrow_list () : list 'v =
          Array.to_list (self#fetchrow_array ());

        method virtual current_nrow : int;
        method virtual is_eor : bool;

        (* true if there is a next row *)
        method virtual next_row : unit -> bool;

        method fetchrow_array_opt () : option (array 'v) =
          try Some (self#fetchrow_array ())
          with [ End_of_result -> None ]
        ;

        method fetchall_list_of_lists : list (list 'v) =
        method fetchall_array_of_lists : array (list 'v) =
        method fetchall_list_of_arrays : list (array 'v) =
        method fetchall_array_of_arrays : array (array 'v) =

        method fold_row_arrays
          : ! 'a . ('a -> array 'v -> 'a) -> 'a -> 'a
          = fun func init ->
            if self#is_eor
            then init
            else
              inner init
              where rec inner acc =
                match self#fetchrow_array_opt () with
                [ None -> acc
                | Some row -> inner (func acc row)
                ]
        ;
*)

      end
    ;


    class virtual result_cmd =
      object (_self)
        method virtual affected : string;
      end
    ;


(*
    type result =
      [= `Error of exn
      |  `Data of #result_data
      |  `Cmd of #result_cmd
      ]
    ;
*)

    value fold_result func init res =
      if res#is_eor
      then init
      else
        inner init
        where rec inner init =
          (* let () = Printf.printf "fold_res: row=%i\n" res#current_nrow in *)
          let new_acc = func init res in
          if res#next_row ()
          then
            inner new_acc
          else
            new_acc
    ;


(*
    use res#map_to_list

    value map_result_to_list func res =
      List.rev &
      fold_result
        (fun rev_acc res ->
           [(func res) :: rev_acc]
        )
        []
        res
    ;
*)


(*
    class virtual connection ['v, 'p, 'stmt, 'res] (conn_info : conn_info)
     =
      object (self)

        constraint 'res = #result 'v;
        constraint 'stmt = #statement 'v 'p (#result 'v);


        method virtual disconnect : unit -> unit;

        method virtual start : unit -> unit;
        method virtual commit : unit -> unit;
        method virtual rollback : unit -> unit;

        method virtual prepare : string -> 'stmt;

        (* there could be "execute without prepare": *)
        method execute
          (sql : string)
          : 'res
          =
            (self#prepare sql)#execute ()
        ;

        (* there could be "execute_p without prepare": *)
        method execute_p
          (sql : string)
          (params : array 'p)
          : 'res
          =
            (self#prepare sql)#execute_p params
        ;

        method virtual quote : string -> string;
        method virtual quote_ident : string -> string;

        (* . *)

        (* method ping () = (); *)
      end

    and virtual statement ['v, 'p, 'res] =
      object

        constraint 'res = #result 'v;


        method virtual execute : unit -> 'res;

        method virtual execute_p : array 'p -> 'res;

      end
    ;
*)


    open Res;


    exception Execute_ok of string
    ;

    value execute_ok conn cmd =
      let error msg = error_gen &
        sprintf "expected success while executing %S, but %s" cmd msg
      in
      match conn#execute cmd with
      [ `Cmd _ -> ()
      | `Data _ -> error "data returned"
      | `Error e -> error & sprintf "occured a %s" & string_of_exn e
      ]
    ;