Split system vs. user cache.

dune-project

@@ -159,7 +159,7 @@
     (sedlex (>= 3.2))
     (menhir (>= 20180703))
   )
-  (sites (share libs) (share bin) (lib_root lib_root))
+  (sites (share libs) (share bin) (share cache) (lib_root lib_root))
   (synopsis "Liquidsoap language library"))
 
 (package

src/config/liquidsoap_paths.default.ml

@@ -23,5 +23,10 @@ let bin_dir () = get_site Sites.bin
 let bin_dir_descr = "(set by dune-site)"
 let camomile_dir () = Filename.dirname CamomileLib.Config.Default.datadir
 let camomile_dir_descr = "(set by dune-site)"
-let cache_override = None
-let cache_override_descr = "$HOME/.cache/liquidsoap"
+let user_cache_override () = None
+let user_cache_override_descr = "$HOME/.cache/liquidsoap"
+
+let system_cache_override () =
+  match Sites.cache with [] -> None | d :: _ -> Some d
+
+let system_cache_override_descr = "(set by dune-site)"

src/config/liquidsoap_paths.posix.ml

@@ -11,5 +11,7 @@ let bin_dir () = "/usr/share/liquidsoap/bin"
 let bin_dir_descr = bin_dir ()
 let camomile_dir () = "/usr/share/liquidsoap/camomile"
 let camomile_dir_descr = camomile_dir ()
-let cache_override = Some "/var/cache/liquidsoap"
-let cache_override_descr = "/var/cache/liquidsoap"
+let user_cache_override () = None
+let user_cache_override_descr = "$HOME/.cache/liquidsoap"
+let system_cache_override () = Some "/var/cache/liquidsoap"
+let system_cache_override_descr = "/var/cache/liquidsoap"

src/config/liquidsoap_paths.standalone.ml

@@ -12,5 +12,15 @@ let bin_dir () = path "bin"
 let bin_dir_descr = "./bin"
 let camomile_dir () = path "camomile"
 let camomile_dir_descr = "./camomile"
-let cache_override = None
-let cache_override_descr = "./cache"
+
+let user_cache_override () =
+  let dir = Filename.dirname Sys.executable_name in
+  let cwd = Sys.getcwd () in
+  Sys.chdir dir;
+  let dir = Sys.getcwd () in
+  Sys.chdir cwd;
+  Some (Filename.concat dir ".cache")
+
+let user_cache_override_descr = "./cache"
+let system_cache_override () = Some "./cache"
+let system_cache_override_descr = "./cache"

src/core/configure.ml

@@ -5,7 +5,12 @@ include Liquidsoap_paths
 let git_snapshot = git_sha <> None
 let requests_max_id = 50
 let requests_table_size = 50
-let () = Liquidsoap_lang.Cache.dir_override := Liquidsoap_paths.cache_override
+
+let () =
+  Liquidsoap_lang.Cache.user_dir_override :=
+    Liquidsoap_paths.user_cache_override;
+  Liquidsoap_lang.Cache.system_dir_override :=
+    Liquidsoap_paths.system_cache_override
 
 (** General configuration *)
 let conf = Dtools.Conf.void "Liquidsoap configuration"

src/core/hooks_implementations.ml

@@ -149,12 +149,12 @@ module Term_cache = Liquidsoap_lang.Term_cache
 
 let cache_log = Log.make ["cache"]
 
-let cache_maintenance () =
+let cache_maintenance dirtype =
   let max_timestamp =
     Unix.time () -. (float conf_cache_max_days#get *. 86400.)
   in
   try
-    match Cache.dir () with
+    match Cache.dir dirtype with
       | Some dir when Sys.file_exists dir && Sys.is_directory dir ->
           let files =
             Array.fold_left

src/config/liquidsoap_paths.mli → src/core/liquidsoap_paths.mli

@@ -11,5 +11,7 @@ val bin_dir : unit -> string
 val bin_dir_descr : string
 val camomile_dir : unit -> string
 val camomile_dir_descr : string
-val cache_override : string option
-val cache_override_override : string
+val user_cache_override : unit -> string option
+val user_cache_override_descr : string
+val system_cache_override : unit -> string option
+val system_cache_override_descr : string

src/lang/builtins_lang.ml

@@ -136,15 +136,55 @@ let liquidsoap = Modules.liquidsoap
 
 let liquidsoap_cache =
   Lang.add_builtin ~category:`Configuration ~descr:"Liquidsoap cache directory."
-    ~base:liquidsoap "cache" [] (Lang.nullable_t Lang.string_t) (fun _ ->
-      match Cache.dir () with None -> Lang.null | Some dir -> Lang.string dir)
+    ~base:liquidsoap "cache"
+    [
+      ( "mode",
+        Lang.string_t,
+        None,
+        Some "Cache mode, one of: \"user\" or \"system\"" );
+    ]
+    (Lang.nullable_t Lang.string_t)
+    (fun p ->
+      let mode = List.assoc "mode" p in
+      let dirtype =
+        match Lang.to_string mode with
+          | "system" -> `System
+          | "user" -> `User
+          | _ ->
+              raise
+                (Error.Invalid_value
+                   ( mode,
+                     "Invalid mode. Should be one of: \"user\" or \"system\"" ))
+      in
+      match Cache.dir dirtype with
+        | None -> Lang.null
+        | Some dir -> Lang.string dir)
 
 let _ =
   Lang.add_builtin ~category:`Configuration
     ~descr:"Execute cache maintenance routine." ~base:liquidsoap_cache
-    "maintenance" [] Lang.unit_t (fun _ ->
+    "maintenance"
+    [
+      ( "mode",
+        Lang.string_t,
+        None,
+        Some "Cache mode, one of: \"user\" or \"system\"" );
+    ]
+    Lang.unit_t
+    (fun p ->
+      let mode = List.assoc "mode" p in
+      let dirtype =
+        match Lang.to_string mode with
+          | "system" -> `System
+          | "user" -> `User
+          | _ ->
+              raise
+                (Error.Invalid_value
+                   ( mode,
+                     "Invalid mode. Should be one of: \"user\" or \"system\"" ))
+      in
       let fn = !Hooks.cache_maintenance in
-      fn ();
+      fn dirtype;
       Lang.unit)
 
 let liquidsoap_version =

src/lang/cache.ml

@@ -4,39 +4,45 @@ let enabled () =
     venv = "1" || venv = "true"
   with Not_found -> true
 
-let dir_override = ref None
+let system_dir_override = ref (fun () -> None)
+let user_dir_override = ref (fun () -> None)
 
-let default_dir =
-  ref (fun () ->
-      try
-        match (!dir_override, Sys.os_type) with
-          | Some d, _ -> Some d
-          | _, "Win32" ->
-              let dir = Filename.dirname Sys.executable_name in
-              let cwd = Sys.getcwd () in
-              Sys.chdir dir;
-              let dir = Sys.getcwd () in
-              Sys.chdir cwd;
-              Some (Filename.concat dir ".cache")
-          | _ ->
-              Some
-                (Filename.concat
-                   (Filename.concat (Unix.getenv "HOME") ".cache")
-                   "liquidsoap")
-      with Not_found -> None)
+let default_user_dir () =
+  try Some (Unix.getenv "LIQ_CACHE_USER_DIR")
+  with Not_found -> (
+    let fn = !user_dir_override in
+    match fn () with
+      | Some d -> Some d
+      | _ ->
+          Some
+            (Filename.concat
+               (Filename.concat (Unix.getenv "HOME") ".cache")
+               "liquidsoap"))
+
+let default_system_dir () =
+  try Some (Unix.getenv "LIQ_CACHE_SYSTEM_DIR")
+  with Not_found -> (
+    let fn = !system_dir_override in
+    match (fn (), Sites.Sites.cache) with
+      | Some d, _ | _, d :: _ -> Some d
+      | _ -> None)
 
 let rec recmkdir dir =
   if not (Sys.file_exists dir) then (
     recmkdir (Filename.dirname dir);
     Sys.mkdir dir 0o755)
 
-let dir () =
+type dirtype = [ `System | `User ]
+
+let dir dirtype =
   if enabled () then (
     match
-      try Some (Unix.getenv "LIQ_CACHE_DIR")
-      with Not_found ->
-        let fn = !default_dir in
-        fn ()
+      let fn =
+        match dirtype with
+          | `User -> default_user_dir
+          | `System -> default_system_dir
+      in
+      fn ()
     with
       | None ->
           Startup.message
@@ -48,9 +54,9 @@ let dir () =
     Startup.message "Cache disabled!";
     None)
 
-let retrieve ?name filename =
+let retrieve ?name ~dirtype filename =
   try
-    match dir () with
+    match dir dirtype with
       | None -> None
       | Some dir ->
           let filename = Filename.concat dir filename in
@@ -82,9 +88,9 @@ let retrieve ?name filename =
         else Startup.message "Error while loading cache: %s" exn;
         None
 
-let store filename value =
+let store ~dirtype filename value =
   try
-    match dir () with
+    match dir dirtype with
       | None -> ()
       | Some dir ->
           recmkdir dir;
@@ -102,7 +108,7 @@ let store filename value =
               Marshal.to_channel oc value [Marshal.Closures];
               Sys.rename tmp_file filename);
           let fn = !Hooks.cache_maintenance in
-          fn ()
+          fn dirtype
   with exn ->
     Startup.message "Error while saving cache: %s" (Printexc.to_string exn)
 
@@ -116,10 +122,10 @@ module Table = struct
     mutable changed : bool;
   }
 
-  let load ?name fname =
+  let load ?name ~dirtype fname =
     {
       fname;
-      table = Option.value ~default:Map.empty (retrieve ?name fname);
+      table = Option.value ~default:Map.empty (retrieve ?name ~dirtype fname);
       changed = false;
     }
 
@@ -133,5 +139,5 @@ module Table = struct
           t.changed <- true;
           v
 
-  let store t = if t.changed then store t.fname t.table
+  let store ~dirtype t = if t.changed then store ~dirtype t.fname t.table
 end

src/lang/cache.mli

@@ -1,13 +1,16 @@
+type dirtype = [ `System | `User ]
+
 val enabled : unit -> bool
-val dir_override : string option ref
-val dir : unit -> string option
-val retrieve : ?name:string -> string -> 'a option
-val store : string -> 'a -> unit
+val user_dir_override : (unit -> string option) ref
+val system_dir_override : (unit -> string option) ref
+val dir : dirtype -> string option
+val retrieve : ?name:string -> dirtype:dirtype -> string -> 'a option
+val store : dirtype:dirtype -> string -> 'a -> unit
 
 module Table : sig
   type 'a t
 
-  val load : ?name:string -> string -> 'a t
+  val load : ?name:string -> dirtype:dirtype -> string -> 'a t
   val get : 'a t -> string -> (unit -> 'a) -> 'a
-  val store : 'a t -> unit
+  val store : dirtype:dirtype -> 'a t -> unit
 end

src/lang/hooks.ml

@@ -13,7 +13,10 @@ let make_encoder =
 let has_encoder = ref (fun _ -> false)
 let liq_libs_dir = ref (fun () -> raise Not_found)
 let log_path = ref None
-let cache_maintenance = ref (fun () -> ())
+
+type dirtype = [ `User | `System ]
+
+let cache_maintenance = ref (fun _ -> ())
 
 type log =
   < f : 'a. int -> ('a, unit, string, unit) format4 -> 'a

src/lang/hooks.mli

@@ -12,7 +12,10 @@ val make_log : (string list -> log) ref
 val log : string list -> log
 val liq_libs_dir : (unit -> string) ref
 val log_path : string option ref
-val cache_maintenance : (unit -> unit) ref
+
+type dirtype = [ `User | `System ]
+
+val cache_maintenance : (dirtype -> unit) ref
 
 (* Media-specific dependencies. *)
 

src/lang/runtime.ml

@@ -223,9 +223,12 @@ let report :
       throw exn;
       default ())
 
-let type_term ?name ?stdlib ?term ?ty ~cache ~trim ~lib parsed_term =
+let type_term ?name ?stdlib ?term ?ty ?cache_dirtype ~cache ~trim ~lib
+    parsed_term =
   let cached_term =
-    if cache then Term_cache.retrieve ?name ~trim parsed_term else None
+    if cache then
+      Term_cache.retrieve ?name ?dirtype:cache_dirtype ~trim parsed_term
+    else None
   in
   match cached_term with
     | Some term -> term
@@ -275,7 +278,8 @@ let type_term ?name ?stdlib ?term ?ty ~cache ~trim ~lib parsed_term =
         let full_term =
           if trim then Term_trim.trim_term full_term else full_term
         in
-        if cache then Term_cache.cache ~trim ~parsed_term full_term;
+        if cache then
+          Term_cache.cache ?dirtype:cache_dirtype ~trim ~parsed_term full_term;
         full_term
 
 let eval_term ?name ~toplevel ast =

src/lang/runtime.mli

@@ -33,6 +33,7 @@ val type_term :
   ?stdlib:append_stdlib ->
   ?term:Term.t ->
   ?ty:Type.t ->
+  ?cache_dirtype:Cache.dirtype ->
   cache:bool ->
   trim:bool ->
   lib:bool ->

src/lang/term/term_cache.ml

@@ -19,7 +19,7 @@ let cache_filename ?name ~trim parsed_term =
   in
   Printf.sprintf "%s.liq-cache" hash
 
-let retrieve ?name ~trim parsed_term : Term.t option =
+let retrieve ?name ?(dirtype = `User) ~trim parsed_term : Term.t option =
   if Cache.enabled () then (
     let report fn =
       match name with
@@ -28,8 +28,8 @@ let retrieve ?name ~trim parsed_term : Term.t option =
             Startup.time (Printf.sprintf "%s cache retrieval" name) fn
     in
     report (fun () ->
-        Cache.retrieve ?name (cache_filename ?name ~trim parsed_term)))
+        Cache.retrieve ?name ~dirtype (cache_filename ?name ~trim parsed_term)))
   else None
 
-let cache ~trim ~parsed_term term =
-  Cache.store (cache_filename ~trim parsed_term) term
+let cache ?(dirtype = `User) ~trim ~parsed_term term =
+  Cache.store ~dirtype (cache_filename ~trim parsed_term) term

src/lang/term/term_cache.mli

@@ -1,2 +1,13 @@
-val retrieve : ?name:string -> trim:bool -> Parsed_term.t -> Term.t option
-val cache : trim:bool -> parsed_term:Parsed_term.t -> Term.t -> unit
+val retrieve :
+  ?name:string ->
+  ?dirtype:Cache.dirtype ->
+  trim:bool ->
+  Parsed_term.t ->
+  Term.t option
+
+val cache :
+  ?dirtype:Cache.dirtype ->
+  trim:bool ->
+  parsed_term:Parsed_term.t ->
+  Term.t ->
+  unit

src/lang/term/term_stdlib.ml

@@ -69,8 +69,8 @@ let prepare ?libs ~cache ~error_on_no_stdlib ~deprecated parsed_term =
   let append () =
     let stdlib = append_ref stdlib in
     let stdlib =
-      Runtime.type_term ~name:"stdlib" ~cache ~trim:false ~lib:true ~term:stdlib
-        parsed_stdlib
+      Runtime.type_term ~cache_dirtype:`System ~name:"stdlib" ~cache ~trim:false
+        ~lib:true ~term:stdlib parsed_stdlib
     in
     let { Runtime_term.var_name; var_id; env } = extract_ref stdlib in
     Atomic.set Type_base.var_name_atom var_name;