WIP: ppx

_oasis

@@ -51,6 +51,21 @@ Library "sqlexpr_syntax"
   XMETAType:        syntax
   XMETARequires:    camlp4, estring
 
+Library "ppx"
+  Path:             src/ppx/
+  FindlibName:      ppx
+  FindlibParent:    sqlexpr
+  XMETADescription: PPX extension for SQL statements/expressions
+  XMETARequires:    sqlexpr
+  XMETAExtraLines:  ppx = "ppx_sqlexpr"
+
+Executable "ppx_sqlexpr"
+  Path:             src/ppx/
+  MainIs:           ppx_sqlexpr.ml
+  BuildDepends:     unix, re.pcre, compiler-libs.common, ppx_tools.metaquot
+  CompiledObject:   best
+  Install:          true
+
 Executable "example"
   Path:             tests/
   MainIs:           example.ml

_tags

@@ -2,7 +2,7 @@
 <tests/*>: syntax_camlp4o, package(sqlexpr.syntax), package(sqlexpr), thread
 
 # OASIS_START
-# DO NOT EDIT (digest: 52e395909f3ee097352522e19988a462)
+# DO NOT EDIT (digest: 8c33eb34542ae662c8d9b52b2978ec0d)
 # Ignore VCS directories, you can use the same kind of rule outside
 # OASIS_START/STOP if you want to exclude directories that contains
 # useless stuff for the build process
@@ -32,6 +32,17 @@ true: annot, bin_annot
 <src/syntax/*.ml{,i,y}>: pkg_camlp4.lib
 <src/syntax/*.ml{,i,y}>: pkg_camlp4.quotations.r
 <src/syntax/*.ml{,i,y}>: pkg_estring
+# Library ppx
+"src/ppx/ppx.cmxs": use_ppx
+# Executable ppx_sqlexpr
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_compiler-libs.common
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_ppx_tools.metaquot
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_re.pcre
+<src/ppx/ppx_sqlexpr.{native,byte}>: pkg_unix
+<src/ppx/*.ml{,i,y}>: pkg_compiler-libs.common
+<src/ppx/*.ml{,i,y}>: pkg_ppx_tools.metaquot
+<src/ppx/*.ml{,i,y}>: pkg_re.pcre
+<src/ppx/*.ml{,i,y}>: pkg_unix
 # Executable example
 <tests/example.{native,byte}>: pkg_camlp4.lib
 <tests/example.{native,byte}>: pkg_camlp4.quotations.r

src/ppx/ppx_sqlexpr.ml

@@ -0,0 +1,147 @@
+open Ast_helper
+open Asttypes
+open Parsetree
+
+module AC = Ast_convenience
+
+let new_id =
+  let n = ref 0 in
+  fun () ->
+    incr n;
+    Printf.sprintf "__ppx_sql_%d" !n
+
+let gen_stmt ~cacheable sql inp =
+  let mkapply fn args = AC.app (AC.evar fn) args in
+
+  let k = new_id () in
+  let st = new_id () in
+  let id =
+    let signature =
+      Printf.sprintf "%d-%f-%d-%S"
+        Unix.(getpid ()) (Unix.gettimeofday ()) (Random.int 0x3FFFFFF) sql
+    in Digest.to_hex (Digest.string signature) in
+  let stmt_id =
+    if cacheable
+    then [%expr Some [%e AC.str id ]]
+    else [%expr None] in
+  let exp = List.fold_right (fun elem dir ->
+    let typ = Sqlexpr_parser.in_type2str elem in
+    [%expr [%e mkapply typ [dir]]])
+    inp
+    [%expr [%e AC.evar k]] in
+    let dir = [%expr fun [%p AC.pvar k] -> fun [%p AC.pvar st] ->
+      let open Sqlexpr.Directives in [%e exp] [%e AC.evar st]
+    ] in
+  [%expr {
+    Sqlexpr.sql_statement = [%e AC.str sql];
+    stmt_id = [%e stmt_id];
+    directive = [%e dir];
+  }]
+
+let gen_expr ~cacheable sql inp outp =
+  let stmt = gen_stmt ~cacheable sql inp in
+  let id = new_id () in
+  let conv s = Longident.(Ldot (Ldot (Lident "Sqlexpr", "Conversion"), s)) in
+  let conv_exprs = List.mapi (fun i elem ->
+    let txt = conv (Sqlexpr_parser.out_type2str elem) in
+    let fn = Exp.ident {txt; loc=(!default_loc)} in
+    let args = [%expr Array.get [%e AC.evar id] [%e AC.int i]] in
+    AC.app fn [args]) outp in
+  let tuple_func =
+    let e = match conv_exprs with
+        [] -> assert false
+      | [x] -> x
+      | hd::tl -> Exp.tuple conv_exprs in
+    [%expr fun [%p AC.pvar id] -> [%e e]] in
+  [%expr {
+    Sqlexpr.statement = [%e stmt];
+    get_data = ([%e AC.int (List.length outp)], [%e tuple_func]);
+  }]
+
+let stmts = ref []
+let init_stmts = ref []
+
+let gen_sql ?(init=false) ?(cacheable=false) str =
+  let (sql, inp, outp) = Sqlexpr_parser.parse str in
+
+  (* accumulate statements *)
+  if init
+  then init_stmts := sql :: !init_stmts
+  else stmts := sql :: !stmts;
+
+  if [] = outp
+  then gen_stmt ~cacheable sql inp
+  else gen_expr ~cacheable sql inp outp
+
+let sqlcheck_sqlite () =
+  let mkstr s = Exp.constant (Const_string (s, None)) in
+  let statement_check = [%expr
+    try ignore(Sqlite3.prepare db stmt)
+    with Sqlite3.Error s ->
+      ret := false;
+      Format.fprintf fmt "Error in statement %S: %s\n" stmt s
+  ] in
+  let stmt_expr_f acc elem = [%expr [%e mkstr elem] :: [%e acc]] in
+  let stmt_exprs = List.fold_left stmt_expr_f [%expr []] !stmts in
+  let init_exprs = List.fold_left stmt_expr_f [%expr []] !init_stmts in
+  let check_db_expr = [%expr fun db fmt ->
+    let ret = ref true in
+    List.iter (fun stmt -> [%e statement_check]) [%e stmt_exprs];
+    !ret
+  ] in
+  let init_db_expr = [%expr fun db fmt ->
+    let ret = ref true in
+    List.iter (fun stmt -> match Sqlite3.exec db stmt with
+      | Sqlite3.Rc.OK -> ()
+      | rc -> begin
+        ret := false;
+        Format.fprintf fmt "Error in init. SQL statement (%s)@ %S@\n"
+          (Sqlite3.errmsg db) stmt
+      end) [%e init_exprs];
+      !ret
+  ] in
+  let in_mem_check_expr = [%expr fun fmt ->
+    let db = Sqlite3.db_open ":memory:" in
+    init_db db fmt && check_db db fmt
+  ] in
+  [%expr
+    let init_db = [%e init_db_expr] in
+    let check_db = [%e check_db_expr] in
+    let in_mem_check = [%e in_mem_check_expr] in
+    (init_db, check_db, in_mem_check)
+  ]
+
+let call fn loc = function
+  | PStr [ {pstr_desc = Pstr_eval (
+    { pexp_desc = Pexp_constant(Const_string(sym, _))}, _)} ] ->
+      with_default_loc loc (fun () -> fn sym)
+  | _ -> raise (Location.Error(Location.error ~loc (
+    "sqlexpr extension accepts a string")))
+
+let call_sqlcheck loc = function
+  | PStr [ {pstr_desc = Pstr_eval ({ pexp_desc =
+    Pexp_constant(Const_string("sqlite", None))}, _)}] ->
+      with_default_loc loc sqlcheck_sqlite
+  | _ -> raise (Location.Error(Location.error ~loc (
+    "sqlcheck extension accepts \"sqlite\"")))
+
+let new_mapper argv = Ast_mapper.({
+  default_mapper with
+  expr = fun mapper expr ->
+    match expr with
+    (* is this an extension node? *)
+    | {pexp_desc = Pexp_extension ({txt = "sql"; loc}, pstr)} ->
+        call gen_sql loc pstr
+    | {pexp_desc = Pexp_extension ({txt = "sqlc"; loc}, pstr)} ->
+        call (gen_sql ~cacheable:true) loc pstr
+    | {pexp_desc = Pexp_extension ({txt = "sqlinit"; loc}, pstr)} ->
+        call (gen_sql ~init:true) loc pstr
+    | {pexp_desc = Pexp_extension ({txt = "sqlcheck"; loc}, pstr)} ->
+        call_sqlcheck loc pstr
+    (* Delegate to the default mapper *)
+    | x -> default_mapper.expr mapper x;
+})
+
+let () =
+  Random.self_init ();
+  Ast_mapper.register "sqlexpr" new_mapper

src/ppx/sqlexpr_parser.ml

@@ -0,0 +1,92 @@
+type typ = Int | Int32 | Int64 | Float | Text | Blob | Bool | Any
+type input = typ * bool
+type output = string * typ * bool
+
+let str2typ = function
+  | "d" -> Int
+  | "l" -> Int32
+  | "L" -> Int64
+  | "f" -> Float
+  | "s" -> Text
+  | "S" -> Blob
+  | "b" -> Bool
+  | "a" -> Any
+  | _ -> failwith "Invalid type"
+
+let typ2str = function
+  | Int -> "int"
+  | Int32 -> "int32"
+  | Int64 -> "int64"
+  | Float -> "float"
+  | Text -> "text"
+  | Blob -> "blob"
+  | Bool -> "bool"
+  | Any -> "any"
+
+let in_type2str ((typ, optional) : input) =
+  let typ = typ2str typ in
+  if optional then "maybe_" ^ typ else typ
+
+let out_type2str ((_, typ, optional) : output) =
+  in_type2str (typ, optional)
+
+let parse str =
+  (* grievous hack to escape everything within quotes *)
+  (* what about ignoring \' or \" ?       " *)
+  (* manually escape "" because {| ... |} notation breaks syntax highlighting *)
+  let escrgx = Re_pcre.regexp "('[^']*')|(\"[^\"]*\")" in
+  let esc_list = ref [] in
+  let esc_str = "<SQLEXPR_PRESERVED>" in
+  let esc_subst substrings =
+    let mtch = Re.get substrings 0 in
+    esc_list := mtch :: !esc_list;
+    esc_str in
+
+  let escaped = Re.replace ~f:esc_subst escrgx str in
+  esc_list := List.rev !esc_list;
+
+  (* logic to extract inputs and outputs *)
+  let inrgx = Re_pcre.regexp {|%([dlLfsSba])(\?)?|} in
+  let outrgx = Re_pcre.regexp {|@([dlLfsSba])(\?)?\{((\w|\.)+)\}|} in
+  let getin (acc : input list) s =
+    let groups = Re.get_all s in
+    let typ = Array.get groups 1 |> str2typ in
+    let optional = "?" = Array.get groups 2 in
+    let res = typ, optional in
+    res::acc in
+  let getout (acc : output list) s =
+    let groups = Re.get_all s in
+    let typ = Array.get groups 1 |> str2typ in
+    let optional = "?" = Array.get groups 2 in
+    let name = Array.get groups 3 |> String.trim in
+    let res = name, typ, optional in
+    res::acc in
+
+  (* execute extractions *)
+  let ins = Re.all inrgx escaped |> List.fold_left getin [] |> List.rev in
+  let outs = Re.all outrgx escaped |> List.fold_left getout [] |> List.rev in
+
+  (* replace input and output params with regular SQL *)
+  let in_subst substrs = "?" in
+
+  let rep_count_out = ref 0 in
+  let out_subst substrs =
+    let (name, _,_) = List.nth outs !rep_count_out in
+    incr rep_count_out;
+    name in
+
+  (* now restore the escaped strings *)
+  let rep_esc_count = ref 0 in
+  let unesc_subst substrs =
+    let restore = List.nth !esc_list !rep_esc_count in
+    incr rep_esc_count;
+    restore in
+
+  (* generate final sql *)
+  let sql =
+       Re.replace ~f:out_subst outrgx escaped
+    |> Re.replace ~f:in_subst inrgx
+    |> Re.replace ~f:unesc_subst (Re_pcre.regexp esc_str) in
+
+  (* final return *)
+  (sql, ins, outs)

tests/t_ppx_parse.ml

@@ -0,0 +1,70 @@
+open OUnit
+
+module Sqlexpr = Sqlexpr_sqlite.Make(Sqlexpr_concurrency.Id)
+module S = Sqlexpr
+
+let ae = assert_equal ~printer:(fun x -> x)
+
+let pqi (d : ('a , 'b) S.statement) = d.S.sql_statement
+let pq (d : ('a, 'b, 'c) S.expression) = pqi d.S.statement
+
+let test_sql _ =
+
+  let s = pqi [%sql "insert into values(%s{foo}, %s{bar})"] in
+  ae "insert into values(?{foo}, ?{bar})" s;
+
+  let s = pq [%sql "@d{kilroy} was @s{here}"] in
+  ae "kilroy was here" s;
+
+  (* dots in column names should be okay *)
+  let s = pq [%sql "select @d{t1.id}, @s{t1.label} from table as t1 ..."] in
+  ae "select t1.id, t1.label from table as t1 ..." s;
+
+  (* verifies the order of regex substitution. output substitution pass runs
+   * before the input pass to avoid injecting valid sqlexpr metacharacter '?'.
+   * For example, given the following string, running the input pass first would
+   * result in a valid sqlexpr string, leading to an incorrect substitiion in
+   * the output pass. never mind that immediately adjacent inputs+outputs in
+   *  valid SQL are extremely unlikely... *)
+  let s = pqi [%sql "@s%d{abc}"] in
+  ae "@s?{abc}" s;
+
+  (* test invalid expressions and adjacencies *)
+  let s = pq [%sql "@s@s %d@s{abc}%d@s%d@s%d{def}%d{ghi}@s"] in
+  ae "@s@s ?abc?@s?@s?{def}?{ghi}@s" s;
+
+  (* column name is not alphanumeric so leave as-is (only dots are allowed) *)
+  (* also check that whitespace is preserved *)
+  let s = pqi [%sql "@s{:kilroy}     @@was %@{here}"] in
+  ae "@s{:kilroy}     @@was %@{here}" s;
+
+  let s = pqi [%sql "excellent"] in
+  ae "excellent" s
+
+
+let test_quotes _ =
+
+  (* single quotes *)
+  let s = pq [%sql "strftime('%s-%d', %s-%d @s{abc}%d{def} '@s{abc}%d{def}')"] in
+  ae "strftime('%s-%d', ?-? abc?{def} '@s{abc}%d{def}')" s;
+
+  (* double quotes *)
+  let s = pq [%sql{|strftime("%s-%d", %s-%d @s{abc}%d{def} "@s{abc}%d{def}")|}] in
+  ae {|strftime("%s-%d", ?-? abc?{def} "@s{abc}%d{def}")|} s;
+
+  (* mixed quotes and nested quotes *)
+  let s = pq [%sql {|@s{abc}"@s{def}"'@d{ghi}''%f'%f"%S"%S "'@s{jkl}%d'" '"%d'"|}] in
+  ae {|abc"@s{def}"'@d{ghi}''%f'?"%S"? "'@s{jkl}%d'" '"%d'"|} s;
+
+  (* more nested and unbalanced quotes *)
+  let s = pqi [%sql {|"'%d'" %d '"%d"' "'%d"'|}] in
+  ae {|"'%d'" ? '"%d"' "'%d"'|} s
+
+
+let tests =
+  "ppx_tests">::: [
+    "test_sql">::test_sql;
+    "test_quotes">::test_quotes;
+  ]
+
+let _ = run_test_tt_main tests