diff --git a/lib/gwdb-legacy/database.ml b/lib/gwdb-legacy/database.ml index 77a0c13cd4..3c0a057aec 100644 --- a/lib/gwdb-legacy/database.ml +++ b/lib/gwdb-legacy/database.ml @@ -3,6 +3,44 @@ open Dbdisk open Def +module ANCIENT : sig + (* Get a value from a file created with Ancient. If the file does + not exist, call [create ()] to generate the value, store it in + the file, and use the file. If [mtime] is provided, it is the + most up-to-date modification time of the database: if the Ancient + file is older, it will be recreated. *) + val get : ?mtime:float -> create:(unit -> 'a) -> string -> 'a +end = struct + let get ?(mtime = 0.) ~create filename = + let exists = Sys.file_exists filename in + let uptodate = + exists + && + let st = Unix.lstat filename in + st.st_mtime > mtime + in + + if (not exists) || not uptodate then ( + let temp_dir = Filename.dirname filename in + let basename = Filename.basename filename in + + let t = create () in + let temp_file = Filename.temp_file ~temp_dir basename ".new" in + let fd = Unix.openfile temp_file [ O_RDWR; O_TRUNC; O_CREAT ] 0o644 in + let md = Ancient.attach fd 0n in + let _ancient = Ancient.share md 0 t in + Ancient.detach md; + if Sys.file_exists filename then Sys.remove filename; + Sys.rename temp_file filename); + + Gc.compact (); + + let fd = Unix.openfile filename [ O_RDONLY ] 0o644 in + let md = Ancient.attach fd 0n in + let ancient = Ancient.get md 0 in + Ancient.follow ancient +end + let load_value ?offset filename = let ic_inx = Secure.open_in_bin filename in (match offset with None -> () | Some offset -> seek_in ic_inx offset); diff --git a/lib/gwdb-legacy/dune b/lib/gwdb-legacy/dune index c2daf9d263..da12ae86fc 100644 --- a/lib/gwdb-legacy/dune +++ b/lib/gwdb-legacy/dune @@ -2,6 +2,6 @@ (name gwdb_legacy) (public_name geneweb.gwdb-legacy) (implements geneweb.gwdb_driver) - (libraries geneweb.def geneweb.util re unix) + (libraries geneweb.def geneweb.util re unix ancient) (modules_without_implementation dbdisk) (modules btree btree2 database dbdisk dutil gwdb_driver gwdb_gc iovalue outbase))