While there is not that much in it, it groups together the small scattered-around bits handling the cache directory. --- builder/Makefile.am | 3 +++ builder/builder.ml | 48 ++++++++++++++----------------------- builder/cache.ml | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++ builder/cache.mli | 45 ++++++++++++++++++++++++++++++++++ builder/downloader.ml | 12 ++++------ builder/downloader.mli | 7 +----- po/POTFILES-ml | 1 + 7 files changed, 137 insertions(+), 44 deletions(-) create mode 100644 builder/cache.ml create mode 100644 builder/cache.mli diff --git a/builder/Makefile.am b/builder/Makefile.am index 7d399d4..21710f1 100644 --- a/builder/Makefile.am +++ b/builder/Makefile.am @@ -46,6 +46,8 @@ CLEANFILES = *~ *.cmi *.cmo *.cmx *.cmxa *.o virt-builder SOURCES = \ architecture.ml \ builder.ml \ + cache.mli \ + cache.ml \ cmdline.ml \ downloader.mli \ downloader.ml \ @@ -120,6 +122,7 @@ deps = \ paths.cmx \ languages.cmx \ get_kernel.cmx \ + cache.cmx \ downloader.cmx \ sigchecker.cmx \ index_parser.cmx \ diff --git a/builder/builder.ml b/builder/builder.ml index 35f5780..acb6129 100644 --- a/builder/builder.ml +++ b/builder/builder.ml @@ -69,8 +69,7 @@ let main () = (match cache with | Some cachedir -> msg "Deleting: %s" cachedir; - let cmd = sprintf "rm -rf %s" (quote cachedir) in - ignore (Sys.command cmd); + Cache.clean_cachedir cachedir; exit 0 | None -> eprintf (f_"%s: error: could not find cache directory. Is $HOME set?\n") @@ -109,27 +108,17 @@ let main () = exit 1 ); - (* Create the cache directory. *) + (* Create the cache. *) let cache = match cache with | None -> None | Some dir -> - (* Annoyingly Sys.is_directory throws an exception on failure - * (RHBZ#1022431). - *) - if (try Sys.is_directory dir with Sys_error _ -> false) then - Some dir - else ( - (* Try to make the directory. If that fails, warn and continue - * without any cache. - *) - try mkdir dir 0o755; Some dir - with exn -> - eprintf (f_"%s: warning: cache %s: %s\n") prog dir - (Printexc.to_string exn); - eprintf (f_"%s: disabling the cache\n%!") prog; - None - ) + try Some (Cache.create ~debug ~directory:dir) + with exn -> + eprintf (f_"%s: warning: cache %s: %s\n") prog dir + (Printexc.to_string exn); + eprintf (f_"%s: disabling the cache\n%!") prog; + None in (* Download the sources. *) @@ -167,17 +156,16 @@ let main () = | `Print_cache -> (* --print-cache *) (match cache with - | Some cachedir -> - printf (f_"cache directory: %s\n") cachedir; - List.iter ( - fun (name, { Index_parser.revision = revision; arch = arch; hidden = hidden }) -> - if not hidden then ( - let filename = Downloader.cache_of_name cachedir name arch revision in - let cached = Sys.file_exists filename in - printf "%-24s %-10s %s\n" name arch - (if cached then s_"cached" else (*s_*)"no") - ) - ) index + | Some cache -> + let l = List.filter ( + fun (_, { Index_parser.hidden = hidden }) -> + hidden <> true + ) index in + let l = List.map ( + fun (name, { Index_parser.revision = revision; arch = arch }) -> + (name, arch, revision) + ) l in + Cache.print_item_status cache ~header:true l | None -> printf (f_"no cache directory\n") ); exit 0 diff --git a/builder/cache.ml b/builder/cache.ml new file mode 100644 index 0000000..581b2cf --- /dev/null +++ b/builder/cache.ml @@ -0,0 +1,65 @@ +(* virt-builder + * Copyright (C) 2013-2014 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +open Common_gettext.Gettext +open Common_utils + +open Unix +open Printf + +let quote = Filename.quote + +let clean_cachedir dir = + let cmd = sprintf "rm -rf %s" (quote dir) in + ignore (Sys.command cmd); + +type t = { + debug : bool; + directory : string; +} + +let create ~debug ~directory = + (* Annoyingly Sys.is_directory throws an exception on failure + * (RHBZ#1022431). + *) + let is_dir = try Sys.is_directory directory with Sys_error _ -> false in + if is_dir = false then ( + mkdir directory 0o755 + ); + { + debug = debug; + directory = directory; + } + +let cache_of_name t name arch revision = + t.directory // sprintf "%s.%s.%d" name arch revision + +let is_cached t name arch revision = + let filename = cache_of_name t name arch revision in + Sys.file_exists filename + +let print_item_status t ~header l = + if header then ( + printf (f_"cache directory: %s\n") t.directory + ); + List.iter ( + fun (name, arch, revision) -> + let cached = is_cached t name arch revision in + printf "%-24s %-10s %s\n" name arch + (if cached then s_"cached" else (*s_*)"no") + ) l diff --git a/builder/cache.mli b/builder/cache.mli new file mode 100644 index 0000000..220ebcb --- /dev/null +++ b/builder/cache.mli @@ -0,0 +1,45 @@ +(* virt-builder + * Copyright (C) 2013-2014 Red Hat Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 of the License, or + * (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License along + * with this program; if not, write to the Free Software Foundation, Inc., + * 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + *) + +(** This module represents a local cache. *) + +val clean_cachedir : string -> unit +(** [clean_cachedir dir] clean the specified cache directory. *) + +type t +(** The abstract data type. *) + +val create : debug:bool -> directory:string -> t +(** Create the abstract type. *) + +val cache_of_name : t -> string -> string -> int -> string +(** [cache_of_name t name arch revision] return the filename + of the cached file. (Note: It doesn't check if the filename + exists, this is just a simple string transformation). *) + +val is_cached : t -> string -> string -> int -> bool +(** [is_cached t name arch revision] return whether the file with + specified name, architecture and revision is cached. *) + +val print_item_status : t -> header:bool -> (string * string * int) list -> unit +(** [print_item_status t header items] print the status in the cache + of the specified items (which are tuples of name, architecture, + and revision). + + If [~header:true] then display a header with the path of the + cache. *) diff --git a/builder/downloader.ml b/builder/downloader.ml index f8cd7ab..9fed774 100644 --- a/builder/downloader.ml +++ b/builder/downloader.ml @@ -23,10 +23,6 @@ open Unix open Printf let quote = Filename.quote -let (//) = Filename.concat - -let cache_of_name cachedir name arch revision = - cachedir // sprintf "%s.%s.%d" name arch revision type uri = string type filename = string @@ -34,7 +30,7 @@ type filename = string type t = { debug : bool; curl : string; - cache : string option; (* cache directory for templates *) + cache : Cache.t option; (* cache for templates *) } type proxy_mode = @@ -62,8 +58,8 @@ let rec download ~prog t ?template ?progress_bar ?(proxy = SystemProxy) uri = (* Not using the cache at all? *) download t ~prog ?progress_bar ~proxy uri - | Some cachedir -> - let filename = cache_of_name cachedir name arch revision in + | Some cache -> + let filename = Cache.cache_of_name cache name arch revision in (* Is the requested template name + revision in the cache already? * If not, download it. @@ -81,7 +77,7 @@ and download_to ~prog t ?(progress_bar = false) ~proxy uri filename = exit 1 in (* Note because there may be parallel virt-builder instances running - * and also to avoid partial downloads in the cachedir if the network + * and also to avoid partial downloads in the cache if the network * fails, we download to a random name in the cache and then * atomically rename it to the final filename. *) diff --git a/builder/downloader.mli b/builder/downloader.mli index 4d24a34..a10cdca 100644 --- a/builder/downloader.mli +++ b/builder/downloader.mli @@ -18,11 +18,6 @@ (** This module is a wrapper around curl, plus local caching. *) -val cache_of_name : string -> string -> string -> int -> string -(** [cache_of_name cachedir name arch revision] returns the filename - of the cached file. (Note: It doesn't check if the filename - exists, this is just a simple string transformation). *) - type uri = string type filename = string @@ -37,7 +32,7 @@ type proxy_mode = *) | ForcedProxy of string (* The proxy is forced to the specified URL. *) -val create : debug:bool -> curl:string -> cache:string option -> t +val create : debug:bool -> curl:string -> cache:Cache.t option -> t (** Create the abstract type. *) val download : prog:string -> t -> ?template:(string*string*int) -> ?progress_bar:bool -> ?proxy:proxy_mode -> uri -> (filename * bool) diff --git a/po/POTFILES-ml b/po/POTFILES-ml index 4dce0e5..8993136 100644 --- a/po/POTFILES-ml +++ b/po/POTFILES-ml @@ -1,5 +1,6 @@ builder/architecture.ml builder/builder.ml +builder/cache.ml builder/cmdline.ml builder/downloader.ml builder/get_kernel.ml -- 1.9.0