Merge pull request #1751 from Keryan-dev/preload-only

[gwd] Static caching for database

.gitignore

@@ -24,6 +24,7 @@ bin/setup/dune
 bin/update_nldb/dune
 lib/core/dune
 lib/dune
+lib/ancient/dune
 lib/gwdb/dune
 lib/util/dune
 plugins/welcome/dune

Makefile

@@ -34,6 +34,8 @@ endif
 	-e "s/%%%GWDB_PKG%%%/$(GWDB_PKG)/g" \
 	-e "s/%%%SYSLOG_PKG%%%/$(SYSLOG_PKG)/g" \
 	-e "s/%%%DUNE_DIRS_EXCLUDE%%%/$(DUNE_DIRS_EXCLUDE)/g" \
+	-e "s/%%%ANCIENT_LIB%%%/$(ANCIENT_LIB)/g" \
+	-e "s/%%%ANCIENT_FILE%%%/$(ANCIENT_FILE)/g" \
 	> $@ \
 	&& printf " Done.\n"
 
@@ -78,6 +80,7 @@ GENERATED_FILES_DEP = \
 	lib/gwdb/dune \
 	lib/core/dune \
 	lib/util/dune \
+	lib/ancient/dune \
 	benchmark/dune \
 	bin/connex/dune \
 	bin/cache_files/dune \

bin/gwd/gwd.ml

@@ -24,6 +24,7 @@ let printer_conf = { Config.empty with output_conf }
 
 let auth_file = ref ""
 let cache_langs = ref []
+let cache_databases = ref []
 let choose_browser_lang = ref false
 let conn_timeout = ref 120
 let daemon = ref false
@@ -2053,6 +2054,12 @@ let main () =
     ; ("-daemon", Arg.Set daemon, " Unix daemon mode.")
     ; ("-no-fork", Arg.Set Wserver.no_fork, " Prevent forking processes")
 #endif
+    ; ("-cache-in-memory", Arg.String (fun s ->
+        if Gw_ancient.is_available then
+          cache_databases := s::!cache_databases
+        else
+          failwith "-cache-in-memory option unavailable for this build."
+      ), "<DATABASE> Preload this database in memory")
     ]
   in
   let speclist = List.sort compare speclist in
@@ -2082,6 +2089,13 @@ let main () =
   List.iter register_plugin !plugins ;
   !GWPARAM.init () ;
   cache_lexicon () ;
+  List.iter
+    (fun dbn ->
+       Printf.eprintf "Caching %s... %!" dbn;
+       ignore (Gwdb.open_base ~keep_in_memory:true dbn);
+       Printf.eprintf "Done.\n%!"
+    )
+    !cache_databases;
   if !auth_file <> "" && !force_cgi then
     GwdLog.syslog `LOG_WARNING "-auth option is not compatible with CGI mode.\n \
       Use instead friend_passwd_file= and wizard_passwd_file= in .cgf file\n";

configure.ml

@@ -8,11 +8,14 @@ let rm = ref ""
 let ext = ref ""
 let os_type = ref ""
 let installed pkg = 0 = Sys.command ("ocamlfind query -qo -qe " ^ pkg)
+let nnp_compiler = 1 = Sys.command "$(ocamlc -config-var naked_pointers)"
 let errmsg = "usage: " ^ Sys.argv.(0) ^ " [options]"
 let api = ref false
 let sosa = ref `None
 let gwdb = ref `None
 let syslog = ref false
+let caching = ref false
+let set_caching () = caching := true
 let set_api () = api := true
 let set_syslog () = syslog := true
 
@@ -56,6 +59,9 @@ let speclist =
       Arg.Unit set_sosa_zarith,
       " Use Sosa module implementation based on `zarith` library" );
     ("--syslog", Arg.Unit set_syslog, " Log gwd errors using syslog");
+    ( "--gwd-caching",
+      Arg.Unit set_caching,
+      " Enable database preloading for gwd" );
   ]
   |> List.sort compare |> Arg.align
 
@@ -102,6 +108,23 @@ let () =
         (os_type, " -D UNIX", "", "/bin/rm -f", "strip")
     | _ -> ("Win", " -D WINDOWS", ".exe", "rm -f", "true")
   in
+  let ancient_lib, ancient_file =
+    let no_cache = ("", "gw_ancient.dum.ml") in
+    if nnp_compiler then
+      if installed "ancient" then ("ancient", "gw_ancient.wrapped.ml")
+      else (
+        if !caching then
+          Printf.eprintf
+            "Warning: ocaml-ancient not installed. Cannot enable database \
+             caching.\n";
+        no_cache)
+    else (
+      if !caching then
+        Printf.eprintf
+          "Warning: Compiler not set to no-naked-pointers. Cannot enable \
+           database caching.\n";
+      no_cache)
+  in
   let ch = open_out "Makefile.config" in
   let writeln s = output_string ch @@ s ^ "\n" in
   let var name value = writeln @@ name ^ "=" ^ value in
@@ -119,4 +142,6 @@ let () =
   var "SYSLOG_PKG" syslog_pkg;
   var "DUNE_DIRS_EXCLUDE" !dune_dirs_exclude;
   var "DUNE_PROFILE" dune_profile;
+  var "ANCIENT_LIB" ancient_lib;
+  var "ANCIENT_FILE" ancient_file;
   close_out ch

dune-project

@@ -44,4 +44,9 @@
     uunf
     uutf
     zarith
-  ))
+  )
+  (depopts
+    ocaml-option-nnp
+    ancient
+  )
+)

geneweb.opam

@@ -38,6 +38,7 @@ depends: [
   "zarith"
   "odoc" {with-doc}
 ]
+depopts: ["ocaml-option-nnp" "ancient"]
 dev-repo: "git+https://github.com/geneweb/geneweb.git"
 build: [
   [ "ocaml" "./configure.ml" "--release" ]

lib/ancient/dune.in

@@ -0,0 +1,8 @@
+(library
+ (public_name geneweb.ancient)
+ (name gw_ancient)
+ (libraries
+  (select gw_ancient.ml from
+    (%%%ANCIENT_LIB%%% -> %%%ANCIENT_FILE%%%)
+   ))
+)

lib/ancient/gw_ancient.dum.ml

@@ -0,0 +1,7 @@
+let is_available = false
+
+type _ ancient = unit
+
+let mark _ = assert false
+let follow _ = assert false
+let delete _ = assert false

lib/ancient/gw_ancient.mli

@@ -0,0 +1,9 @@
+val is_available : bool
+
+(* Trimmed ocaml-ancient library signature *)
+
+type 'a ancient
+
+val mark : 'a -> 'a ancient
+val follow : 'a ancient -> 'a
+val delete : 'a ancient -> unit

lib/ancient/gw_ancient.wrapped.ml

@@ -0,0 +1,3 @@
+let is_available = true
+
+include Ancient