From 7467ab44ff266a1529979a1747b53b757912e693 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 4 Jul 2016 15:25:24 +0200 Subject: [PATCH 01/44] add SQL backend for ocsipersist --- README.md | 1 + configure | 18 ++++- opam | 1 + src/Makefile.filelist | 4 ++ src/extensions/Makefile | 11 +++ src/extensions/ocsipersist-sql/Makefile | 69 +++++++++++++++++++ src/extensions/ocsipersist-sql/ocsipersist.ml | 58 ++++++++++++++++ 7 files changed, 161 insertions(+), 1 deletion(-) create mode 100644 src/extensions/ocsipersist-sql/Makefile create mode 100644 src/extensions/ocsipersist-sql/ocsipersist.ml diff --git a/README.md b/README.md index e2ad2e0c6..43f71a3a0 100644 --- a/README.md +++ b/README.md @@ -23,6 +23,7 @@ Libraries: * tyxml (need version 3) * ipaddr (need version >= 2.1) * ocamlsqlite3 (tested with 2.0.2) OR + * macaque (untested) OR * dbm (tested with 1.0) diff --git a/configure b/configure index 40ddb3870..63c18baaa 100755 --- a/configure +++ b/configure @@ -78,6 +78,7 @@ set_defaults () { enable_debug=1 enable_annot=1 with_sqlite=1 + with_sql=1 with_camlzip=1 with_dbm=1 with_preempt=1 @@ -107,7 +108,7 @@ full_pwd=`pwd` ## Which options exist? eoptions for enable/disable, woptions for with/without: eoptions="debug annot natdynlink" -woptions="sqlite dbm camlzip preempt" +woptions="sql sqlite dbm camlzip preempt" print_options () { for opt in $eoptions; do @@ -184,6 +185,7 @@ usage: ./configure [ options ] --enable-natdynlink, --disable-natdynlink Enable/disable nativecode dynamic linking --with-sqlite, --without-sqlite Compile ocsipersist with SQLite for persistent storage + --with-sql, --without-sql Compile ocsipersist with SQL for persistent storage --with-dbm, --without-dbm Compile ocsipersist with DBM for persistent storage --with-camlzip, --without-camlzip Compile deflatemod extension, requires camlzip @@ -424,6 +426,12 @@ check_library cryptokit "See: http://pauillac.inria.fr/~xleroy/software.html#cry check_library tyxml "See: http://ocsigen.org/tyxml/" +# Check Sql +case "$with_sql" in + 1) if test_library macaque; then with_sql=1; else with_sql=0; fi;; + 2) check_library macaque "See: https://github.com/ocsigen/macaque";; +esac + # Check Sqlite3 case "$with_sqlite" in 1) if test_library sqlite3; then with_sqlite=1; else with_sqlite=0; fi;; @@ -514,6 +522,11 @@ if [ $with_sqlite -gt 0 ] ; then else with_sqlite="NO" fi +if [ $with_sql -gt 0 ] ; then + with_sql="YES" +else + with_sql="NO" +fi if [ $with_camlzip -gt 0 ] ; then with_camlzip="YES" else @@ -569,6 +582,9 @@ CAMLZIPNAME:=$zipname # Do you want ocsipersist with sqlite? YES/NO OCSIPERSISTSQLITE:=$with_sqlite +# Do you want ocsipersist with sql? YES/NO +OCSIPERSISTSQL:=$with_sql + # Do you want ocsipersist with dbm? YES/NO OCSIPERSISTDBM:=$with_dbm diff --git a/opam b/opam index bff451014..f73eecbb0 100644 --- a/opam +++ b/opam @@ -30,6 +30,7 @@ depends: [ "tyxml" {> "3.6.0"} "dbm" "sqlite3" + "macaque" "ipaddr" {>= "2.1"} "camlp4" ] diff --git a/src/Makefile.filelist b/src/Makefile.filelist index 6bcd747ff..41937bd5a 100644 --- a/src/Makefile.filelist +++ b/src/Makefile.filelist @@ -82,6 +82,10 @@ ifeq "$(OCSIPERSISTSQLITE)" "YES" PLUGINS_IMPL += extensions/ocsipersist-sqlite.cma endif +ifeq "$(OCSIPERSISTSQL)" "YES" +PLUGINS_IMPL += extensions/ocsipersist-sql.cma +endif + ifeq "$(OCSIPERSISTDBM)" "YES" PLUGINS_IMPL += extensions/ocsipersist-dbm.cma PLUGINS_BIN += extensions/ocsipersist-dbm/ocsidbm diff --git a/src/extensions/Makefile b/src/extensions/Makefile index b7185f0f7..cd102fefd 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -46,6 +46,14 @@ ifeq "$(NATDYNLINK)" "YES" opt:: ${FILES:.ml=.cmxs} endif +### SQL ### + +ifeq "$(OCSIPERSISTSQL)" "YES" +byte:: + $(MAKE) -C ocsipersist-sql byte +opt:: + $(MAKE) -C ocsipersist-sql opt +endif ### SQLite ### ifeq "$(OCSIPERSISTSQLITE)" "YES" @@ -80,6 +88,7 @@ endif clean: clean.local ${MAKE} -C ocsipersist-dbm clean ${MAKE} -C ocsipersist-sqlite clean + ${MAKE} -C ocsipersist-sql clean clean.local: -rm -f *.cm* *.o *.a *.annot -rm -f ${PREDEP} @@ -87,6 +96,7 @@ distclean: clean.local -rm -f *~ \#* .\#* ${MAKE} -C ocsipersist-dbm distclean ${MAKE} -C ocsipersist-sqlite distclean + ${MAKE} -C ocsipersist-sql distclean ## Dependencies @@ -94,6 +104,7 @@ depend: ${PREDEP} $(OCAMLDEP) ${LIBS} *.mli *.ml > .depend ${MAKE} -C ocsipersist-dbm depend ${MAKE} -C ocsipersist-sqlite depend + ${MAKE} -C ocsipersist-sql depend FORCE: -include .depend diff --git a/src/extensions/ocsipersist-sql/Makefile b/src/extensions/ocsipersist-sql/Makefile new file mode 100644 index 000000000..2508cb580 --- /dev/null +++ b/src/extensions/ocsipersist-sql/Makefile @@ -0,0 +1,69 @@ +include ../../../Makefile.config + +PACKAGE := lwt.preemptive \ + tyxml.parser \ + macaque.syntax \ + pgocaml.syntax \ + +LIBS := -I ../../baselib -I ../../http -I ../../server \ + ${addprefix -package ,${PACKAGE}} +OCAMLC := $(OCAMLFIND) ocamlc${BYTEDBG} ${THREAD} +OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD} +OCAMLDOC := $(OCAMLFIND) ocamldoc +OCAMLDEP := $(OCAMLFIND) ocamldep + +all: byte opt + +### + +byte: ocsipersist-sql.cma +opt:: ocsipersist-sql.cmxa +ifeq "$(NATDYNLINK)" "YES" +opt:: ocsipersist-sql.cmxs +endif + +PREDEP := ocsipersist.mli + +ocsipersist-sql.cma: ocsipersist.cmo + $(OCAMLC) -a -o $@ $^ + cp ocsipersist.cmi .. + cp $@ .. + +ocsipersist-sql.cmxa: ocsipersist.cmx + $(OCAMLOPT) -a -o $@ $^ + cp ocsipersist.cmi .. + cp $@ ${patsubst %.cmxa,%.a,$@} .. + +ocsipersist-sql.cmxs: ocsipersist-sql.cmxa + $(OCAMLOPT) -shared -linkall -o $@ $^ + cp $@ .. + +ocsipersist.mli: + ln -s ../ocsipersist.mli . + +########## + +%.cmi: %.mli + $(OCAMLC) ${LIBS} -c $< +%.cmo: %.ml + $(OCAMLC) ${LIBS} -c $< +%.cmx: %.ml + $(OCAMLOPT) ${LIBS} -c $< +%.cmxs: %.cmxa + $(OCAMLOPT) -shared -linkall -o $@ $< + +## Clean up + +clean: + -rm -f *.cm[ioax] *.cmxa *.cmxs *.o *.a *.annot + -rm -f ${PREDEP} +distclean: clean + -rm -f *~ \#* .\#* + +## Dependencies + +depend: ${PREDEP} + $(OCAMLDEP) ${LIBS} *.mli *.ml > .depend + +FORCE: +-include .depend diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml new file mode 100644 index 000000000..fbc4558a2 --- /dev/null +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -0,0 +1,58 @@ +let section = Lwt_log.Section.make "ocsipersist:sql" + +(** Module Ocsipersist: persistent data *) + +open Lwt +open Printf + +module Lwt_thread = struct + include Lwt + include Lwt_chan +end +module Lwt_PGOCaml = PGOCaml_generic.Make(Lwt_thread) +module Lwt_Query = Query.Make_with_Db(Lwt_thread)(Lwt_PGOCaml) + + +type store = string Lwt.t (*TODO*) + +exception Ocsipersist_error + + +open Simplexmlparser +let parse_global_config (host, port, db) = function + | [] -> (None, None, None) + | (Element ("database", attrs, []))::[] -> + let rec parse_attrs (host, port, db) = function + | ("host", h) :: xs -> parse_attrs (Some h, port, db) xs + | ("port", p) :: xs -> begin try + parse_attrs (host, Some (int_of_string p), db) xs + with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file + ("port is not an integer")) + end + | ("db", db) :: xs -> parse_attrs (host, port, Some db) xs + | [] -> (host, port, db) + | _ -> raise (Ocsigen_extensions.Error_in_config_file + ("Unexpected content inside Ocsipersist config")) + in parse_attrs (host, port, db) attrs + | _ -> raise (Ocsigen_extensions.Error_in_config_file + ("Unexpected content inside Ocsipersist config")) + + +(* Registration of the extension *) + +let dbh = ref (failwith "undefined" : string Lwt_PGOCaml.t Lwt_PGOCaml.monad) + +let init config = + let default maybe value = match maybe with | None -> value | Some x -> x in + let (host, port, db) = parse_global_config (None, None, None) config in + let host = default host "localhost" in + let port = default port 3000 in + let db = default db "ocsipersist" in + dbh := Lwt_PGOCaml.connect ~host ~port ~database:db (); + () + + +let _ = Ocsigen_extensions.register_extension + ~name:"ocsipersist" + ~init_fun:init + () From 349d333ea03849375b5c11177d79b971980d6dc0 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 4 Jul 2016 16:36:15 +0200 Subject: [PATCH 02/44] added function skeletons for ocsipersist-sql --- src/extensions/ocsipersist-sql/ocsipersist.ml | 90 ++++++++++++------- .../ocsipersist-sqlite/ocsipersist.ml | 59 ++++++------ 2 files changed, 88 insertions(+), 61 deletions(-) diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index fbc4558a2..4454f6665 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -1,58 +1,86 @@ let section = Lwt_log.Section.make "ocsipersist:sql" -(** Module Ocsipersist: persistent data *) - -open Lwt -open Printf - module Lwt_thread = struct include Lwt include Lwt_chan end module Lwt_PGOCaml = PGOCaml_generic.Make(Lwt_thread) module Lwt_Query = Query.Make_with_Db(Lwt_thread)(Lwt_PGOCaml) +open Lwt + +type 'a t = string * 'a + +type store = string Lwt_PGOCaml.t Lwt_PGOCaml.monad + +let host = ref "localhost" +let port = ref 3000 + +let open_store db = Lwt_PGOCaml.connect ~host:!host ~port:!port ~database:db () + +let make_persistent ~store ~name ~default = failwith "TODO" + +let make_persistent_lazy ~store ~name ~default = failwith "TODO" + +let make_persistent_lazy_lwt ~store ~name ~default = failwith "TODO" + +let get = failwith "TODO" + +let set = failwith "TODO" + +type 'value table = string Lwt.t +let table_name = failwith "TODO" -type store = string Lwt.t (*TODO*) +let open_table = failwith "TODO" -exception Ocsipersist_error +let find = failwith "TODO" + +let add = failwith "TODO" + +let replace_if_exists = failwith "TODO" + +let remove = failwith "TODO" + +let length = failwith "TODO" + +let iter_step = failwith "TODO" + +let iter_table = failwith "TODO" + +let fold_step = failwith "TODO" + +let fold_table = failwith "TODO" + + +let iter_block = failwith "TODO" + +(*exception Ocsipersist_error*) open Simplexmlparser -let parse_global_config (host, port, db) = function - | [] -> (None, None, None) +let parse_global_config (host, port) = function + | [] -> (None, None) | (Element ("database", attrs, []))::[] -> - let rec parse_attrs (host, port, db) = function - | ("host", h) :: xs -> parse_attrs (Some h, port, db) xs + let rec parse_attrs (host, port) = function + | ("host", h) :: xs -> parse_attrs (Some h, port) xs | ("port", p) :: xs -> begin try - parse_attrs (host, Some (int_of_string p), db) xs + parse_attrs (host, Some (int_of_string p)) xs with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file ("port is not an integer")) end - | ("db", db) :: xs -> parse_attrs (host, port, Some db) xs - | [] -> (host, port, db) + | [] -> (host, port) | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Ocsipersist config")) - in parse_attrs (host, port, db) attrs + in parse_attrs (host, port) attrs | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Ocsipersist config")) -(* Registration of the extension *) - -let dbh = ref (failwith "undefined" : string Lwt_PGOCaml.t Lwt_PGOCaml.monad) - -let init config = - let default maybe value = match maybe with | None -> value | Some x -> x in - let (host, port, db) = parse_global_config (None, None, None) config in - let host = default host "localhost" in - let port = default port 3000 in - let db = default db "ocsipersist" in - dbh := Lwt_PGOCaml.connect ~host ~port ~database:db (); - () +let init_fun config = + let maybe m f = match m with | None -> () | Some x -> f x in + let (h, p) = parse_global_config (None, None) config in + maybe h (fun h -> host := h); + maybe p (fun p -> port := p) -let _ = Ocsigen_extensions.register_extension - ~name:"ocsipersist" - ~init_fun:init - () +let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () diff --git a/src/extensions/ocsipersist-sqlite/ocsipersist.ml b/src/extensions/ocsipersist-sqlite/ocsipersist.ml index 1238959ae..b2b70ddec 100644 --- a/src/extensions/ocsipersist-sqlite/ocsipersist.ml +++ b/src/extensions/ocsipersist-sqlite/ocsipersist.ml @@ -23,7 +23,6 @@ let section = Lwt_log.Section.make "ocsipersist:sqlite" (** Module Ocsipersist: persistent data *) open Lwt -open Sqlite3 open Printf (** Data are divided into stores. @@ -58,10 +57,10 @@ let yield () = let rec bind_safely stmt = function | [] -> stmt | (value, name)::q as l -> - match Sqlite3.bind stmt (bind_parameter_index stmt name) value with - | Rc.OK -> bind_safely stmt q - | Rc.BUSY | Rc.LOCKED -> yield () ; bind_safely stmt l - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + match Sqlite3.bind stmt (Sqlite3.bind_parameter_index stmt name) value with + | Sqlite3.Rc.OK -> bind_safely stmt q + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; bind_safely stmt l + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) let close_safely db = if not (db_close db) then @@ -98,9 +97,9 @@ let db_create table = let stmt = prepare db sql in let rec aux () = match step stmt with - | Rc.DONE -> ignore(finalize stmt) - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in @@ -113,9 +112,9 @@ let db_remove (table, key) = let stmt = bind_safely (prepare db sql) [Data.TEXT key,":key"] in let rec aux () = match step stmt with - | Rc.DONE -> ignore(finalize stmt) - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in exec_safely remove @@ -126,16 +125,16 @@ let (db_get, db_replace, db_replace_if_exists) = let stmt = bind_safely (prepare db sqlget) [Data.TEXT key,":key"] in let rec aux () = match step stmt with - | Rc.ROW -> + | Sqlite3.Rc.ROW -> let value = match column stmt 0 with | Data.BLOB s -> s | _ -> assert false in ignore (finalize stmt); value - | Rc.DONE -> ignore(finalize stmt) ; raise Not_found - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) ; raise Not_found + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in let replace (table, key) value db = @@ -147,9 +146,9 @@ let (db_get, db_replace, db_replace_if_exists) = in let rec aux () = match step stmt with - | Rc.DONE -> ignore(finalize stmt) - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in ((fun tablekey -> exec_safely (get tablekey)), @@ -165,15 +164,15 @@ let db_iter_step table rowid = let stmt = bind_safely (prepare db sql) [Data.INT rowid, ":rowid"] in let rec aux () = match step stmt with - | Rc.ROW -> + | Sqlite3.Rc.ROW -> (match (column stmt 0,column stmt 1, column stmt 2) with | (Data.TEXT k, Data.BLOB v, Data.INT rowid) -> ignore(finalize stmt) ; Some (k, v, rowid) | _ -> assert false ) - | Rc.DONE -> ignore(finalize stmt) ; None - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) ; None + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in exec_safely iter @@ -184,13 +183,13 @@ let db_iter_block table f = let stmt = prepare db sql in let rec aux () = match step stmt with - | Rc.ROW -> + | Sqlite3.Rc.ROW -> (match (column stmt 0,column stmt 1) with | (Data.TEXT k, Data.BLOB v) -> f k (Marshal.from_string v 0); aux() | _ -> assert false ) - | Rc.DONE -> ignore(finalize stmt) - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in exec_safely iter @@ -201,16 +200,16 @@ let db_length table = let stmt = prepare db sql in let rec aux () = match step stmt with - | Rc.ROW -> + | Sqlite3.Rc.ROW -> let value = match column stmt 0 with | Data.INT s -> Int64.to_int s | _ -> assert false in ignore (finalize stmt); value - | Rc.DONE -> ignore(finalize stmt) ; raise Not_found - | Rc.BUSY | Rc.LOCKED -> yield () ; aux () - | rc -> ignore(finalize stmt) ; failwith (Rc.to_string rc) + | Sqlite3.Rc.DONE -> ignore(finalize stmt) ; raise Not_found + | Sqlite3.Rc.BUSY | Sqlite3.Rc.LOCKED -> yield () ; aux () + | rc -> ignore(finalize stmt) ; failwith (Sqlite3.Rc.to_string rc) in aux () in exec_safely length From 5c6b5a75432df4f825e188aac49dc16ad7c8a21f Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 4 Jul 2016 17:07:08 +0200 Subject: [PATCH 03/44] Enabled lwt PPX syntax for ocsipersist-sql --- src/extensions/ocsipersist-sql/Makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/src/extensions/ocsipersist-sql/Makefile b/src/extensions/ocsipersist-sql/Makefile index 2508cb580..b30f5895f 100644 --- a/src/extensions/ocsipersist-sql/Makefile +++ b/src/extensions/ocsipersist-sql/Makefile @@ -2,6 +2,7 @@ include ../../../Makefile.config PACKAGE := lwt.preemptive \ tyxml.parser \ + lwt.ppx \ macaque.syntax \ pgocaml.syntax \ From 78e53a345c7208e37e8684d48ed5c33a5c88f605 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 4 Jul 2016 18:05:17 +0200 Subject: [PATCH 04/44] store = table = string; allow to specify database --- src/extensions/ocsipersist-sql/ocsipersist.ml | 29 ++++++++++++------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index 4454f6665..6ff6c43b8 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -6,18 +6,23 @@ module Lwt_thread = struct end module Lwt_PGOCaml = PGOCaml_generic.Make(Lwt_thread) module Lwt_Query = Query.Make_with_Db(Lwt_thread)(Lwt_PGOCaml) +module PGOCaml = Lwt_PGOCaml open Lwt type 'a t = string * 'a -type store = string Lwt_PGOCaml.t Lwt_PGOCaml.monad +type store = string let host = ref "localhost" let port = ref 3000 +let db = ref "ocsipersist" -let open_store db = Lwt_PGOCaml.connect ~host:!host ~port:!port ~database:db () +let connect = Lwt_PGOCaml.connect ~host:!host ~port:!port ~database:!db () + +let open_store table = table let make_persistent ~store ~name ~default = failwith "TODO" + (* PGSQL(store) "SELECT a FROM b" *) let make_persistent_lazy ~store ~name ~default = failwith "TODO" @@ -58,29 +63,31 @@ let iter_block = failwith "TODO" open Simplexmlparser -let parse_global_config (host, port) = function - | [] -> (None, None) +let parse_global_config (host, port, db) = function + | [] -> (None, None, None) | (Element ("database", attrs, []))::[] -> - let rec parse_attrs (host, port) = function - | ("host", h) :: xs -> parse_attrs (Some h, port) xs + let rec parse_attrs (host, port, db) = function + | ("host", h) :: xs -> parse_attrs (Some h, port, db) xs | ("port", p) :: xs -> begin try - parse_attrs (host, Some (int_of_string p)) xs + parse_attrs (host, Some (int_of_string p), db) xs with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file ("port is not an integer")) end - | [] -> (host, port) + | ("database", db) :: xs -> parse_attrs (host, port, Some db) xs + | [] -> (host, port, db) | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Ocsipersist config")) - in parse_attrs (host, port) attrs + in parse_attrs (host, port, db) attrs | _ -> raise (Ocsigen_extensions.Error_in_config_file ("Unexpected content inside Ocsipersist config")) let init_fun config = let maybe m f = match m with | None -> () | Some x -> f x in - let (h, p) = parse_global_config (None, None) config in + let (h, p, d) = parse_global_config (None, None, None) config in maybe h (fun h -> host := h); - maybe p (fun p -> port := p) + maybe p (fun p -> port := p); + maybe d (fun d -> db := d) let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () From 4225b35a404b0c31877d6c7cfbd50fe3c41066ad Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Wed, 6 Jul 2016 09:55:01 +0200 Subject: [PATCH 05/44] use higher-order function instead of primitive recursion --- src/extensions/ocsipersist-sql/ocsipersist.ml | 51 ++++++++----------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index 6ff6c43b8..383d27018 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -13,11 +13,11 @@ type 'a t = string * 'a type store = string -let host = ref "localhost" -let port = ref 3000 -let db = ref "ocsipersist" +let host = ref None +let port = ref None +let db = ref None -let connect = Lwt_PGOCaml.connect ~host:!host ~port:!port ~database:!db () +let connect = Lwt_PGOCaml.connect ?host:!host ?port:!port ?database:!db () let open_store table = table @@ -63,31 +63,24 @@ let iter_block = failwith "TODO" open Simplexmlparser -let parse_global_config (host, port, db) = function - | [] -> (None, None, None) - | (Element ("database", attrs, []))::[] -> - let rec parse_attrs (host, port, db) = function - | ("host", h) :: xs -> parse_attrs (Some h, port, db) xs - | ("port", p) :: xs -> begin try - parse_attrs (host, Some (int_of_string p), db) xs - with Failure _ -> raise (Ocsigen_extensions.Error_in_config_file - ("port is not an integer")) - end - | ("database", db) :: xs -> parse_attrs (host, port, Some db) xs - | [] -> (host, port, db) - | _ -> raise (Ocsigen_extensions.Error_in_config_file - ("Unexpected content inside Ocsipersist config")) - in parse_attrs (host, port, db) attrs - | _ -> raise (Ocsigen_extensions.Error_in_config_file - ("Unexpected content inside Ocsipersist config")) - - -let init_fun config = - let maybe m f = match m with | None -> () | Some x -> f x in - let (h, p, d) = parse_global_config (None, None, None) config in - maybe h (fun h -> host := h); - maybe p (fun p -> port := p); - maybe d (fun d -> db := d) +let parse_global_config = function + | [] -> () + | [Element ("database", attrs, [])] -> let parse_attr = function + | ("host", h) -> host := Some h + | ("port", p) -> begin + try port := Some (int_of_string p) + with Failure _ -> raise @@ Ocsigen_extensions.Error_in_config_file + "port is not an integer" + end + | ("database", d) -> db := Some d + | _ -> raise @@ Ocsigen_extensions.Error_in_config_file + "Unexpected content inside Ocsipersist config" + in ignore @@ List.map parse_attr attrs; () + | _ -> raise @@ Ocsigen_extensions.Error_in_config_file + "Unexpected content inside Ocsipersist config" + + +let init_fun config = parse_global_config config let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () From a69d40437fd0722f56dffde8c09245301bc19e3b Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Wed, 6 Jul 2016 10:00:28 +0200 Subject: [PATCH 06/44] added more config options for DB connection --- src/extensions/ocsipersist-sql/ocsipersist.ml | 20 +++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index 383d27018..416dbbb51 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -15,9 +15,18 @@ type store = string let host = ref None let port = ref None -let db = ref None - -let connect = Lwt_PGOCaml.connect ?host:!host ?port:!port ?database:!db () +let user = ref None +let password = ref None +let database = ref None +let unix_domain_socket_dir = ref None + +let connect = Lwt_PGOCaml.connect + ?host:!host + ?port:!port + ?user:!user + ?password:!password + ?database:!database () + ?unix_domain_socket_dir:!unix_domain_socket_dir let open_store table = table @@ -72,7 +81,10 @@ let parse_global_config = function with Failure _ -> raise @@ Ocsigen_extensions.Error_in_config_file "port is not an integer" end - | ("database", d) -> db := Some d + | ("user", u) -> user := Some u + | ("password", pw) -> password := Some pw + | ("database", db) -> database := Some db + | ("unix_domain_socket_dir", udsd) -> unix_domain_socket_dir := Some udsd | _ -> raise @@ Ocsigen_extensions.Error_in_config_file "Unexpected content inside Ocsipersist config" in ignore @@ List.map parse_attr attrs; () From 72baade17334902cc129b8c497202924af63a05d Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Wed, 6 Jul 2016 11:03:23 +0200 Subject: [PATCH 07/44] copy connection-handling code from Eba_db --- src/extensions/ocsipersist-sql/ocsipersist.ml | 47 +++++++++++++++++-- 1 file changed, 44 insertions(+), 3 deletions(-) diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index 416dbbb51..392689161 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -25,13 +25,54 @@ let connect = Lwt_PGOCaml.connect ?port:!port ?user:!user ?password:!password - ?database:!database () + ?database:!database ?unix_domain_socket_dir:!unix_domain_socket_dir +let db_handle = ref None + +let do_if cond actions = if cond then actions else Lwt.return () + +(* ensure that connection to database is alive; throws exception otherwise. *) +let with_db action = + let%lwt () = do_if (!db_handle = None) begin + let%lwt db = connect () in + db_handle := Some db; + Lwt.return () + end in + let%lwt () = match !db_handle with + | None -> failwith "forgot to use with_db?" + | Some db -> + let%lwt alive = PGOCaml.alive db in + do_if (not alive) begin + let%lwt db = connect () in + db_handle := Some db; + PGOCaml.ping db + end + in action + +let transaction_block db f = (* copied from Eba_db *) + Lwt_PGOCaml.begin_work db >>= fun _ -> + try%lwt + let%lwt r = f () in + let%lwt () = Lwt_PGOCaml.commit db in + Lwt.return r + with e -> + let%lwt () = Lwt_PGOCaml.rollback db in + Lwt.fail e + +(* copied from Eba_db *) +let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Lwt_pool.t = + Lwt_pool.create 16 ~validate:PGOCaml.alive connect + +let full_transaction_block f = (* copied from Eba_db *) + Lwt_pool.use pool (fun db -> transaction_block db (fun () -> f db)) + + let open_store table = table -let make_persistent ~store ~name ~default = failwith "TODO" - (* PGSQL(store) "SELECT a FROM b" *) +let make_persistent ~store ~name ~default = full_transaction_block @@ fun dbh -> + failwith "TODO" + (* PGSQL(store) "UPDATE $store SET $name = $default" *) let make_persistent_lazy ~store ~name ~default = failwith "TODO" From c1a73b688e04cb08cb456dfc5a5a474d66de05a9 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Wed, 6 Jul 2016 11:56:59 +0200 Subject: [PATCH 08/44] syntax flags --- src/extensions/ocsipersist-sql/Makefile | 10 +++---- src/extensions/ocsipersist-sql/ocsipersist.ml | 26 +++++++++---------- 2 files changed, 16 insertions(+), 20 deletions(-) diff --git a/src/extensions/ocsipersist-sql/Makefile b/src/extensions/ocsipersist-sql/Makefile index b30f5895f..861949921 100644 --- a/src/extensions/ocsipersist-sql/Makefile +++ b/src/extensions/ocsipersist-sql/Makefile @@ -1,10 +1,6 @@ include ../../../Makefile.config -PACKAGE := lwt.preemptive \ - tyxml.parser \ - lwt.ppx \ - macaque.syntax \ - pgocaml.syntax \ +PACKAGE := pgocaml.syntax lwt.syntax LIBS := -I ../../baselib -I ../../http -I ../../server \ ${addprefix -package ,${PACKAGE}} @@ -44,10 +40,12 @@ ocsipersist.mli: ########## +SYNTAX_FLAGS=-syntax camlp4o + %.cmi: %.mli $(OCAMLC) ${LIBS} -c $< %.cmo: %.ml - $(OCAMLC) ${LIBS} -c $< + $(OCAMLC) ${LIBS} ${SYNTAX_FLAGS} -c $< %.cmx: %.ml $(OCAMLOPT) ${LIBS} -c $< %.cmxs: %.cmxa diff --git a/src/extensions/ocsipersist-sql/ocsipersist.ml b/src/extensions/ocsipersist-sql/ocsipersist.ml index 392689161..a066f1294 100644 --- a/src/extensions/ocsipersist-sql/ocsipersist.ml +++ b/src/extensions/ocsipersist-sql/ocsipersist.ml @@ -34,45 +34,43 @@ let do_if cond actions = if cond then actions else Lwt.return () (* ensure that connection to database is alive; throws exception otherwise. *) let with_db action = - let%lwt () = do_if (!db_handle = None) begin - let%lwt db = connect () in + lwt () = do_if (!db_handle = None) begin + lwt db = connect () in db_handle := Some db; Lwt.return () end in - let%lwt () = match !db_handle with + lwt () = match !db_handle with | None -> failwith "forgot to use with_db?" | Some db -> - let%lwt alive = PGOCaml.alive db in + lwt alive = PGOCaml.alive db in do_if (not alive) begin - let%lwt db = connect () in + lwt db = connect () in db_handle := Some db; PGOCaml.ping db end in action -let transaction_block db f = (* copied from Eba_db *) +let transaction_block db f = Lwt_PGOCaml.begin_work db >>= fun _ -> - try%lwt - let%lwt r = f () in - let%lwt () = Lwt_PGOCaml.commit db in + try_lwt + lwt r = f () in + lwt () = Lwt_PGOCaml.commit db in Lwt.return r with e -> - let%lwt () = Lwt_PGOCaml.rollback db in + lwt () = Lwt_PGOCaml.rollback db in Lwt.fail e -(* copied from Eba_db *) let pool : (string, bool) Hashtbl.t Lwt_PGOCaml.t Lwt_pool.t = Lwt_pool.create 16 ~validate:PGOCaml.alive connect -let full_transaction_block f = (* copied from Eba_db *) +let full_transaction_block f = Lwt_pool.use pool (fun db -> transaction_block db (fun () -> f db)) let open_store table = table let make_persistent ~store ~name ~default = full_transaction_block @@ fun dbh -> - failwith "TODO" - (* PGSQL(store) "UPDATE $store SET $name = $default" *) + PGSQL(store) "SELECT a FROM b" let make_persistent_lazy ~store ~name ~default = failwith "TODO" From 54b5365ebf52f19fb47e94b8aaeb4ea56a2e896d Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Wed, 6 Jul 2016 12:36:49 +0200 Subject: [PATCH 09/44] added SQL options to config file --- src/files/ocsigenserver.conf.in | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/src/files/ocsigenserver.conf.in b/src/files/ocsigenserver.conf.in index 065af3345..dfe259200 100644 --- a/src/files/ocsigenserver.conf.in +++ b/src/files/ocsigenserver.conf.in @@ -30,6 +30,21 @@ --> + + + + --> + Date: Fri, 8 Jul 2016 15:25:57 +0200 Subject: [PATCH 31/44] updated docs --- src/extensions/ocsipersist.mli | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/extensions/ocsipersist.mli b/src/extensions/ocsipersist.mli index 6cc99f8f5..8d31122d4 100644 --- a/src/extensions/ocsipersist.mli +++ b/src/extensions/ocsipersist.mli @@ -22,9 +22,9 @@ (** Persistent data on hard disk. *) (** - There are currently two implementations of this module, - one using a DBM database, and the other using SQLITE. - Link the one your want with your program. + There are currently three implementations of this module, + one using a DBM database, on the PostgreSQL database, + and one using SQLITE. Link the one your want with your program. *) From 3f5713e6517f7458dd9b9d7f1b49f5d753a8bdd4 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Fri, 8 Jul 2016 15:40:58 +0200 Subject: [PATCH 32/44] Delete .depend file on distclean --- src/extensions/Makefile | 1 + src/extensions/ocsipersist-dbm/Makefile | 1 + src/extensions/ocsipersist-pgsql/Makefile | 1 + src/extensions/ocsipersist-sqlite/Makefile | 1 + 4 files changed, 4 insertions(+) diff --git a/src/extensions/Makefile b/src/extensions/Makefile index 59691dfdb..bce0f50b5 100644 --- a/src/extensions/Makefile +++ b/src/extensions/Makefile @@ -97,6 +97,7 @@ distclean: clean.local ${MAKE} -C ocsipersist-dbm distclean ${MAKE} -C ocsipersist-sqlite distclean ${MAKE} -C ocsipersist-pgsql distclean + -rm -f .depend ## Dependencies diff --git a/src/extensions/ocsipersist-dbm/Makefile b/src/extensions/ocsipersist-dbm/Makefile index 58060ddf2..e2a9a09f2 100644 --- a/src/extensions/ocsipersist-dbm/Makefile +++ b/src/extensions/ocsipersist-dbm/Makefile @@ -71,6 +71,7 @@ clean: -rm -f ocsidbm ocsidbm.opt distclean: clean -rm -f *~ \#* .\#* + -rm -f .depend ## Dependencies diff --git a/src/extensions/ocsipersist-pgsql/Makefile b/src/extensions/ocsipersist-pgsql/Makefile index 137e6e3f3..3fe00d9a3 100644 --- a/src/extensions/ocsipersist-pgsql/Makefile +++ b/src/extensions/ocsipersist-pgsql/Makefile @@ -58,6 +58,7 @@ clean: -rm -f ${PREDEP} distclean: clean -rm -f *~ \#* .\#* + -rm -f .depend ## Dependencies diff --git a/src/extensions/ocsipersist-sqlite/Makefile b/src/extensions/ocsipersist-sqlite/Makefile index 1721e7559..ab83ade60 100644 --- a/src/extensions/ocsipersist-sqlite/Makefile +++ b/src/extensions/ocsipersist-sqlite/Makefile @@ -58,6 +58,7 @@ clean: -rm -f ${PREDEP} distclean: clean -rm -f *~ \#* .\#* + -rm -f .depend ## Dependencies From 8e5e467493deb4d5909adf8f2c5e48ff83456eb3 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Fri, 8 Jul 2016 16:31:25 +0200 Subject: [PATCH 33/44] string escape key names --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 418249077..bb215d23e 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -47,21 +47,22 @@ let full_transaction_block f = (* copied from Eba_db *) let exec db query params = PGOCaml.prepare db ~query () >> - PGOCaml.execute db ~params:(List.map (fun x -> Some x) params) () + let params = params |> List.map @@ fun x -> Some (PGOCaml.string_of_bytea x) in + PGOCaml.execute db ~params () let (@.) f g = fun x -> f (g x) (* function composition *) let key_value_of_row = function - | [Some key; Some value] -> (key, value) + | [Some key; Some value] -> (PGOCaml.bytea_of_string key, PGOCaml.bytea_of_string value) | _ -> raise Ocsipersist_error (* get one value from the result of a query *) let one = function - | [Some value]::xs -> value + | [Some value]::xs -> PGOCaml.bytea_of_string value | _ -> raise Not_found -let marshal value = PGOCaml.string_of_bytea @@ Marshal.to_string value [] -let unmarshal str = Marshal.from_string (PGOCaml.bytea_of_string str) 0 +let marshal value = Marshal.to_string value [] +let unmarshal str = Marshal.from_string str 0 let create_table db table = let query = sprintf "CREATE TABLE IF NOT EXISTS %s \ @@ -139,7 +140,9 @@ let iter_step f table = full_transaction_block @@ fun db -> let query = sprintf "SELECT * FROM %s " table in PGOCaml.prepare db ~query () >> PGOCaml.cursor db ~params:[] @@ - fun row -> let (key,value) = key_value_of_row row in f key (unmarshal value) + fun row -> let (key,value) = key_value_of_row row in f + (PGOCaml.bytea_of_string key) + (unmarshal @@ PGOCaml.bytea_of_string value) let iter_table = iter_step From 022ac438b5b36d7a81dbf29f6891d9ac6a3f21d9 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Fri, 8 Jul 2016 16:51:56 +0200 Subject: [PATCH 34/44] use as default database name "ocsipersist" --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index bb215d23e..918ee3e95 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -14,7 +14,7 @@ let host = ref None let port = ref None let user = ref None let password = ref None -let database = ref None +let database = ref (Some "ocsipersist") let unix_domain_socket_dir = ref None let connect () = PGOCaml.connect From 2c61c8aef5a5904fc5658d07b89c058690753233 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Fri, 8 Jul 2016 17:10:28 +0200 Subject: [PATCH 35/44] don't use unnecessary transaction blocks --- .../ocsipersist-pgsql/ocsipersist.ml | 34 ++++++------------- 1 file changed, 11 insertions(+), 23 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 918ee3e95..d1402ad68 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -28,22 +28,10 @@ let connect () = PGOCaml.connect let (>>) f g = f >>= fun _ -> g -let transaction_block db f = - PGOCaml.begin_work db >>= fun _ -> - try_lwt - lwt r = f () in - PGOCaml.commit db >> - Lwt.return r - with e -> - print_endline (Printexc.to_string e); - PGOCaml.rollback db >> - Lwt.fail e - let pool : (string, bool) Hashtbl.t PGOCaml.t Lwt_pool.t = Lwt_pool.create 16 ~validate:PGOCaml.alive connect -let full_transaction_block f = (* copied from Eba_db *) - Lwt_pool.use pool (fun db -> transaction_block db (fun () -> f db)) +let use_pool f = Lwt_pool.use pool (fun db -> f db) let exec db query params = PGOCaml.prepare db ~query () >> @@ -81,10 +69,10 @@ type 'a t = { name : string; } -let open_store store = full_transaction_block @@ fun db -> +let open_store store = use_pool @@ fun db -> create_table db store >> Lwt.return store -let make_persistent_lazy_lwt ~store ~name ~default = full_transaction_block @@ fun db -> +let make_persistent_lazy_lwt ~store ~name ~default = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " store in lwt result = exec db query [name] in lwt _ = begin match result with @@ -102,25 +90,25 @@ let make_persistent_lazy ~store ~name ~default = let make_persistent ~store ~name ~default = make_persistent_lazy ~store ~name ~default:(fun () -> default) -let get p = full_transaction_block @@ fun db -> +let get p = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " p.store in Lwt.map (unmarshal @. one) (exec db query [p.name]) -let set p v = full_transaction_block @@ fun db -> +let set p v = use_pool @@ fun db -> insert db p.store p.name v type 'value table = string let table_name table = Lwt.return table -let open_table table = full_transaction_block @@ fun db -> +let open_table table = use_pool @@ fun db -> create_table db table >> Lwt.return table -let find table key = full_transaction_block @@ fun db -> +let find table key = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " table in Lwt.map (unmarshal @. one) (exec db query [key]) -let add table key value = full_transaction_block @@ fun db -> +let add table key value = use_pool @@ fun db -> insert db table key value let replace_if_exists table key value = @@ -128,15 +116,15 @@ let replace_if_exists table key value = find table key >> add table key value with Not_found -> Lwt.return () -let remove table key = full_transaction_block @@ fun db -> +let remove table key = use_pool @@ fun db -> let query = sprintf "DELETE FROM %s WHERE key = $1 " table in exec db query [key] >> Lwt.return () -let length table = full_transaction_block @@ fun db -> +let length table = use_pool @@ fun db -> let query = sprintf "SELECT count(*) FROM %s " table in Lwt.map (unmarshal @. one) (exec db query []) -let iter_step f table = full_transaction_block @@ fun db -> +let iter_step f table = use_pool @@ fun db -> let query = sprintf "SELECT * FROM %s " table in PGOCaml.prepare db ~query () >> PGOCaml.cursor db ~params:[] @@ From 3235c59ffa77eadcf7704fd4c05dc3f7416a1cbf Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 10:12:13 +0200 Subject: [PATCH 36/44] use UPDATE for [set] instead of INSERT --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index d1402ad68..b26b0a264 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -1,3 +1,5 @@ +(** PostgreSQL (>= 9.5) backend for Ocsipersist. *) + let section = Lwt_log.Section.make "ocsipersist:sql" module Lwt_thread = struct @@ -95,7 +97,8 @@ let get p = use_pool @@ fun db -> Lwt.map (unmarshal @. one) (exec db query [p.name]) let set p v = use_pool @@ fun db -> - insert db p.store p.name v + let query = sprintf "UPDATE %s SET value = $2 WHERE key = $1 " p.store + in exec db query [p.name; marshal v] >> Lwt.return () type 'value table = string From dc9a24224679f1f105269299983a1fb744b23cfb Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 10:36:08 +0200 Subject: [PATCH 37/44] Wiki documentation for ocsipersist-pgsql --- doc/manual-wiki/config.wiki | 17 +++++++++++++---- doc/manual-wiki/libraries.wiki | 26 ++++++++++++++++++++++---- 2 files changed, 35 insertions(+), 8 deletions(-) diff --git a/doc/manual-wiki/config.wiki b/doc/manual-wiki/config.wiki index f3be2f8cb..d8d60664e 100644 --- a/doc/manual-wiki/config.wiki +++ b/doc/manual-wiki/config.wiki @@ -148,7 +148,10 @@ Here is a simple example: }}} -Here is another example, for use as unprivileged user toto on port 8000: +Here is another example, for use as unprivileged user toto on port 8000. +We use the PostgreSQL (version >= 9.5) backend for ocsipersist. Note that the +ocsipersist-database under the specified name (default: "ocsipersist") needs to +exist. To create it run {{{psql}}} and execute {{{CREATE TABLE ocsipersist;}}}. {{{ @@ -167,8 +170,14 @@ Here is another example, for use as unprivileged user toto on port 8000: - - + + + port="3000" + user="toto" + password="toto's secret" + /> + + @@ -182,7 +191,7 @@ Here is another example, for use as unprivileged user toto on port 8000: - + diff --git a/doc/manual-wiki/libraries.wiki b/doc/manual-wiki/libraries.wiki index 481c75e23..7dfef8e8e 100644 --- a/doc/manual-wiki/libraries.wiki +++ b/doc/manual-wiki/libraries.wiki @@ -5,15 +5,17 @@ ==Ocsipersist -<
> is needed in {{{ eliom.cma }}}, thus you need to dynlink it in the configuration file before {{{ Eliom }}}). There are currently two implementations of {{{ Ocsipersist }}}: -{{{ ocsipersist-dbm.cma }}} (uses the DBM database) and -{{{ ocsipersist-sqlite.cma }}} (uses the SQLite database, -and depends on {{{ sqlite3.cma }}}). +{{{ ocsipersist-dbm.cma }}} (uses the DBM database); +{{{ ocsipersist-sqlite.cma }}} (uses the SQLite database +and depends on {{{ sqlite3.cma }}}); +{{{ ocsipersist-pgsql.cma }}} (uses the PostgreSQL (version >= 9.5) +database and depends on {{{ pa_pgsql.cma }}}); >> It is possible to customize the location of the database on the @@ -31,3 +33,19 @@ name of the {{{ocsidbm}}} process you want to use: }}} +PostgreSQL has more options to specify how to connect to the database. +Note that the ocsipersist-database under the specified name (default: +"ocsipersist") needs to exist. To create it run {{{psql}}} and execute +{{{CREATE TABLE ocsipersist;}}}. +{{{ + + + host="localhost" + port="3000" + user="Aerobic Respirator" + password="Guess what I need!" + database="ocsipersist" + unix_domain_socket_dir="./udsd" + /> + +}}} From 23b1bf7d6c1946b947ebf7425064bec9ce23b240 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 11:37:12 +0200 Subject: [PATCH 38/44] cache queries in a hash table --- doc/manual-wiki/libraries.wiki | 1 + .../ocsipersist-pgsql/ocsipersist.ml | 66 +++++++++++++------ 2 files changed, 48 insertions(+), 19 deletions(-) diff --git a/doc/manual-wiki/libraries.wiki b/doc/manual-wiki/libraries.wiki index 7dfef8e8e..f758671fc 100644 --- a/doc/manual-wiki/libraries.wiki +++ b/doc/manual-wiki/libraries.wiki @@ -46,6 +46,7 @@ Note that the ocsipersist-database under the specified name (default: password="Guess what I need!" database="ocsipersist" unix_domain_socket_dir="./udsd" + hashtbl_size="16" /> }}} diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index b26b0a264..b10c1d35f 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -16,32 +16,31 @@ let host = ref None let port = ref None let user = ref None let password = ref None -let database = ref (Some "ocsipersist") +let database = ref "ocsipersist" let unix_domain_socket_dir = ref None +let hashtbl_size = ref 8 -let connect () = PGOCaml.connect +let make_hashtbl () = Hashtbl.create !hashtbl_size + +let connect () = + lwt dbhandle = PGOCaml.connect ?host:!host ?port:!port ?user:!user ?password:!password - ?database:!database + ?database:(Some !database) ?unix_domain_socket_dir:!unix_domain_socket_dir - () + () in + PGOCaml.set_private_data dbhandle @@ make_hashtbl (); + Lwt.return dbhandle let (>>) f g = f >>= fun _ -> g -let pool : (string, bool) Hashtbl.t PGOCaml.t Lwt_pool.t = +let pool : (string, unit) Hashtbl.t PGOCaml.t Lwt_pool.t = Lwt_pool.create 16 ~validate:PGOCaml.alive connect let use_pool f = Lwt_pool.use pool (fun db -> f db) -let exec db query params = - PGOCaml.prepare db ~query () >> - let params = params |> List.map @@ fun x -> Some (PGOCaml.string_of_bytea x) in - PGOCaml.execute db ~params () - -let (@.) f g = fun x -> f (g x) (* function composition *) - let key_value_of_row = function | [Some key; Some value] -> (PGOCaml.bytea_of_string key, PGOCaml.bytea_of_string value) | _ -> raise Ocsipersist_error @@ -54,6 +53,33 @@ let one = function let marshal value = Marshal.to_string value [] let unmarshal str = Marshal.from_string str 0 +let prepare db query = + let hashtbl = PGOCaml.private_data db in + (* Get a unique name for this query using an MD5 digest. *) + let name = Digest.to_hex (Digest.string query) in + (* Have we prepared this statement already? If not, do so. *) + let is_prepared = Hashtbl.mem hashtbl name in + lwt () = if is_prepared then Lwt.return () else begin + PGOCaml.prepare db ~name ~query () >> + Lwt.return @@ Hashtbl.add hashtbl name () + end in + Lwt.return name + +let exec db query params = + lwt name = prepare db query in + let params = params |> List.map @@ fun x -> Some (PGOCaml.string_of_bytea x) in + PGOCaml.execute db ~name ~params () + +let cursor db query params f = + lwt name = prepare db query in + let params = params |> List.map @@ fun x -> Some (PGOCaml.string_of_bytea x) in + PGOCaml.cursor db ~name ~params @@ + fun row -> let (key,value) = key_value_of_row row in f + (PGOCaml.bytea_of_string key) + (unmarshal @@ PGOCaml.bytea_of_string value) + +let (@.) f g = fun x -> f (g x) (* function composition *) + let create_table db table = let query = sprintf "CREATE TABLE IF NOT EXISTS %s \ (key TEXT, value BYTEA, PRIMARY KEY(key))" table @@ -64,6 +90,7 @@ let insert db table key value = ON CONFLICT ( key ) DO UPDATE SET value = $2 " table in exec db query [key; marshal value] >> Lwt.return () + type store = string type 'a t = { @@ -77,7 +104,7 @@ let open_store store = use_pool @@ fun db -> let make_persistent_lazy_lwt ~store ~name ~default = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " store in lwt result = exec db query [name] in - lwt _ = begin match result with + lwt () = begin match result with | [] -> lwt default = default () in insert db store name default @@ -129,11 +156,7 @@ let length table = use_pool @@ fun db -> let iter_step f table = use_pool @@ fun db -> let query = sprintf "SELECT * FROM %s " table in - PGOCaml.prepare db ~query () >> - PGOCaml.cursor db ~params:[] @@ - fun row -> let (key,value) = key_value_of_row row in f - (PGOCaml.bytea_of_string key) - (unmarshal @@ PGOCaml.bytea_of_string value) + cursor db query [] f let iter_table = iter_step @@ -162,8 +185,13 @@ let parse_global_config = function end | ("user", u) -> user := Some u | ("password", pw) -> password := Some pw - | ("database", db) -> database := Some db + | ("database", db) -> database := db | ("unix_domain_socket_dir", udsd) -> unix_domain_socket_dir := Some udsd + | ("hashtbl_size", hts) -> begin + try hashtbl_size := int_of_string hts + with Failure _ -> raise @@ Ocsigen_extensions.Error_in_config_file + "hashtbl_size is not an integer" + end | _ -> raise @@ Ocsigen_extensions.Error_in_config_file "Unexpected attribute for in Ocsipersist config" in ignore @@ List.map parse_attr attrs; () From 8064c1168057a4ba14cd7d9f6c957257b1db08b6 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 14:45:39 +0200 Subject: [PATCH 39/44] make_persistent does not do a SELECT query anymore --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index b10c1d35f..acf995013 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -101,24 +101,22 @@ type 'a t = { let open_store store = use_pool @@ fun db -> create_table db store >> Lwt.return store +let make_persistent ~store ~name ~default = use_pool @@ fun db -> + insert db store name default >> Lwt.return {store = store; name = name} + let make_persistent_lazy_lwt ~store ~name ~default = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " store in lwt result = exec db query [name] in - lwt () = begin match result with + match result with | [] -> lwt default = default () in - insert db store name default - | xs -> Lwt.return () - end in - Lwt.return {store = store; name = name} + make_persistent ~store ~name ~default + | xs -> Lwt.return {store = store; name = name} let make_persistent_lazy ~store ~name ~default = let default () = Lwt.wrap default in make_persistent_lazy_lwt ~store ~name ~default -let make_persistent ~store ~name ~default = - make_persistent_lazy ~store ~name ~default:(fun () -> default) - let get p = use_pool @@ fun db -> let query = sprintf "SELECT value FROM %s WHERE key = $1 " p.store in Lwt.map (unmarshal @. one) (exec db query [p.name]) From 93988748bb5725c72538e0a3743db4d50a898c2c Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 14:58:02 +0200 Subject: [PATCH 40/44] fix replace_if_exists --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index acf995013..c22eac6a8 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -88,6 +88,7 @@ let create_table db table = let insert db table key value = let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) ON CONFLICT ( key ) DO UPDATE SET value = $2 " table + (*TODO: compatibility with < 9.5*) in exec db query [key; marshal value] >> Lwt.return () @@ -139,10 +140,12 @@ let find table key = use_pool @@ fun db -> let add table key value = use_pool @@ fun db -> insert db table key value -let replace_if_exists table key value = - try_lwt - find table key >> add table key value - with Not_found -> Lwt.return () +let replace_if_exists table key value = use_pool @@ fun db -> + let query = sprintf "UPDATE %s SET value = $2 WHERE key = $1 RETURNING 0" table in + lwt result = exec db query [key; marshal value] in + match result with + | [] -> raise Not_found + | _ -> Lwt.return () let remove table key = use_pool @@ fun db -> let query = sprintf "DELETE FROM %s WHERE key = $1 " table in From 1b593ca3025d7dd8c46e7df760807f702a49ae08 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 15:06:45 +0200 Subject: [PATCH 41/44] add configuration parameter for connection pool size --- .../ocsipersist-pgsql/ocsipersist.ml | 22 ++++++++++--------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index c22eac6a8..92850a8d8 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -18,9 +18,9 @@ let user = ref None let password = ref None let database = ref "ocsipersist" let unix_domain_socket_dir = ref None -let hashtbl_size = ref 8 +let size_conn_pool = ref 16 -let make_hashtbl () = Hashtbl.create !hashtbl_size +let make_hashtbl () = Hashtbl.create 8 let connect () = lwt dbhandle = PGOCaml.connect @@ -36,10 +36,11 @@ let connect () = let (>>) f g = f >>= fun _ -> g -let pool : (string, unit) Hashtbl.t PGOCaml.t Lwt_pool.t = - Lwt_pool.create 16 ~validate:PGOCaml.alive connect +let conn_pool : (string, unit) Hashtbl.t PGOCaml.t Lwt_pool.t ref = + (* This connection pool will be overwritten by init_fun! *) + ref @@ Lwt_pool.create !size_conn_pool ~validate:PGOCaml.alive connect -let use_pool f = Lwt_pool.use pool (fun db -> f db) +let use_pool f = Lwt_pool.use !conn_pool @@ fun db -> f db let key_value_of_row = function | [Some key; Some value] -> (PGOCaml.bytea_of_string key, PGOCaml.bytea_of_string value) @@ -188,10 +189,10 @@ let parse_global_config = function | ("password", pw) -> password := Some pw | ("database", db) -> database := db | ("unix_domain_socket_dir", udsd) -> unix_domain_socket_dir := Some udsd - | ("hashtbl_size", hts) -> begin - try hashtbl_size := int_of_string hts + | ("size_conn_pool", scp) -> begin + try size_conn_pool := int_of_string scp with Failure _ -> raise @@ Ocsigen_extensions.Error_in_config_file - "hashtbl_size is not an integer" + "size_conn_pool is not an integer" end | _ -> raise @@ Ocsigen_extensions.Error_in_config_file "Unexpected attribute for in Ocsipersist config" @@ -200,7 +201,8 @@ let parse_global_config = function "Unexpected content inside Ocsipersist config" -let init_fun config = parse_global_config config - +let init_fun config = + parse_global_config config; + conn_pool := Lwt_pool.create !size_conn_pool ~validate:PGOCaml.alive connect let _ = Ocsigen_extensions.register_extension ~name:"ocsipersist" ~init_fun () From b0f08ea693f85d20e9e0d21be760254cf979f8eb Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 15:08:41 +0200 Subject: [PATCH 42/44] updated doc to latest changes --- doc/manual-wiki/libraries.wiki | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/manual-wiki/libraries.wiki b/doc/manual-wiki/libraries.wiki index f758671fc..c55b842c5 100644 --- a/doc/manual-wiki/libraries.wiki +++ b/doc/manual-wiki/libraries.wiki @@ -46,7 +46,7 @@ Note that the ocsipersist-database under the specified name (default: password="Guess what I need!" database="ocsipersist" unix_domain_socket_dir="./udsd" - hashtbl_size="16" + size_conn_pool="16" /> }}} From f33a39677f0f377470eb7cad547efc7e8310e8b2 Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 15:42:50 +0200 Subject: [PATCH 43/44] refixed make_persistent --- .../ocsipersist-pgsql/ocsipersist.ml | 27 ++++++++++--------- 1 file changed, 15 insertions(+), 12 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 92850a8d8..67fce3cb9 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -86,12 +86,6 @@ let create_table db table = (key TEXT, value BYTEA, PRIMARY KEY(key))" table in exec db query [] >> Lwt.return () -let insert db table key value = - let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) - ON CONFLICT ( key ) DO UPDATE SET value = $2 " table - (*TODO: compatibility with < 9.5*) - in exec db query [key; marshal value] >> Lwt.return () - type store = string @@ -103,17 +97,23 @@ type 'a t = { let open_store store = use_pool @@ fun db -> create_table db store >> Lwt.return store -let make_persistent ~store ~name ~default = use_pool @@ fun db -> - insert db store name default >> Lwt.return {store = store; name = name} +let make_persistent_worker ~store ~name ~default db = + let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) + ON CONFLICT ( key ) DO NOTHING" store in + (*TODO: compatibility with < 9.5*) + exec db query [name; marshal default] >> Lwt.return {store; name} + +let make_persistent ~store ~name ~default = + use_pool @@ fun db -> make_persistent_worker ~store ~name ~default db let make_persistent_lazy_lwt ~store ~name ~default = use_pool @@ fun db -> - let query = sprintf "SELECT value FROM %s WHERE key = $1 " store in + let query = sprintf "SELECT 1 FROM %s WHERE key = $1 " store in lwt result = exec db query [name] in match result with | [] -> lwt default = default () in - make_persistent ~store ~name ~default - | xs -> Lwt.return {store = store; name = name} + make_persistent_worker ~store ~name ~default db + | _ -> Lwt.return {store = store; name = name} let make_persistent_lazy ~store ~name ~default = let default () = Lwt.wrap default in @@ -139,7 +139,10 @@ let find table key = use_pool @@ fun db -> Lwt.map (unmarshal @. one) (exec db query [key]) let add table key value = use_pool @@ fun db -> - insert db table key value + let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) + ON CONFLICT ( key ) DO UPDATE SET value = $2 " table + (*TODO: compatibility with < 9.5*) + in exec db query [key; marshal value] >> Lwt.return () let replace_if_exists table key value = use_pool @@ fun db -> let query = sprintf "UPDATE %s SET value = $2 WHERE key = $1 RETURNING 0" table in From 18236698614c089a88d980f1d5cc531d08ad35bc Mon Sep 17 00:00:00 2001 From: Jan Rochel Date: Mon, 11 Jul 2016 15:49:44 +0200 Subject: [PATCH 44/44] doc --- src/extensions/ocsipersist-pgsql/ocsipersist.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/extensions/ocsipersist-pgsql/ocsipersist.ml b/src/extensions/ocsipersist-pgsql/ocsipersist.ml index 67fce3cb9..23156beee 100644 --- a/src/extensions/ocsipersist-pgsql/ocsipersist.ml +++ b/src/extensions/ocsipersist-pgsql/ocsipersist.ml @@ -100,7 +100,7 @@ let open_store store = use_pool @@ fun db -> let make_persistent_worker ~store ~name ~default db = let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) ON CONFLICT ( key ) DO NOTHING" store in - (*TODO: compatibility with < 9.5*) + (* NOTE: incompatible with < 9.5 *) exec db query [name; marshal default] >> Lwt.return {store; name} let make_persistent ~store ~name ~default = @@ -141,7 +141,7 @@ let find table key = use_pool @@ fun db -> let add table key value = use_pool @@ fun db -> let query = sprintf "INSERT INTO %s VALUES ( $1 , $2 ) ON CONFLICT ( key ) DO UPDATE SET value = $2 " table - (*TODO: compatibility with < 9.5*) + (* NOTE: incompatible with < 9.5 *) in exec db query [key; marshal value] >> Lwt.return () let replace_if_exists table key value = use_pool @@ fun db ->