Commits

Anonymous committed a6764fc Draft

just before adding caching

  • Participants
  • Parent commits 5fe1a00

Comments (0)

Files changed (3)

 
 let dbg fmt = Printf.ksprintf (Printf.eprintf "DBG: %s\n%!") fmt
 
+let split_by_last pred str =
+  let len = String.length str in
+  let rec loop i =
+    if i = 0
+    then ("", str)
+    else
+      let i = i - 1 in
+      if pred str.[i]
+      then (String.sub str 0 i, String.sub str (i+1) (len-i-1))
+      else loop i
+  in
+  loop len
+
+let has_substring str sub =
+  let strlen = String.length str
+  and sublen = String.length sub in
+  if sublen > strlen
+  then false
+  else
+    let ilim = strlen - sublen + 1 in
+    let rec check ?(i=0) ofs =
+      if i = sublen
+      then true
+      else
+        if str.[ofs+i] = sub.[i]
+        then check ~i:(i+1) ofs
+        else false
+    in
+    let rec loop i =
+      if i = ilim
+      then false
+      else
+        if check i
+        then true
+        else loop (i+1)
+    in
+      loop 0
+
 
 module Reb_sys
  =
         match input_line_opt ch with
         | None -> List.rev acc
         | Some l ->
-let () = Printf.eprintf "LOP: %s\n%!" l in
- loop (l :: acc)
+            (* let () = Printf.eprintf "LOP: %s\n%!" l in *)
+            loop (l :: acc)
       in
         let r = loop [] in
         match Unix.close_process_in ch with
         then mkdir dir 0o777
         else ()
 
+
+    let assure_empty_dir d =
+      ( rm_rf d
+      ; assert
+         (try
+            (ignore (stat d); false)
+          with
+          | Unix_error (ENOENT, "stat", _) -> true
+         )
+      ; assure_dir d
+      )
+
+
     let has_command argv =
       127 <> run ~show:false argv
 

src/post_template.ml

       !pkgdescs
 
 
+  module Cache
+   =
+    struct
+
+      let cachedbg fmt = Printf.ksprintf
+        (Printf.eprintf "DBG/cache: %s\n%!") fmt
+
+      let cache_prefix = lazy
+        (try (Sys.getenv "HOME") </> ".cache/rebildol"
+         with | Not_found -> failwith "no $HOME environment variable"
+        )
+
+      let is_dir d = Sys.file_exists d && Sys.is_directory d
+
+      let get_cache_dir kind =
+        lazy
+          (try
+             let prefix = !!cache_prefix in
+             let dir = prefix </> kind in
+             if is_dir prefix && is_dir dir
+             then
+               let () = cachedbg "found dir %S, using to cache %s"
+                 dir kind
+               in
+               Some dir
+             else
+               let () = cachedbg "can't find dir %S, won't cache %s"
+                 dir kind
+               in
+               None
+           with
+           | e -> ( cachedbg "error looking for cache for %s: %s \
+                              (so, no caching)"
+                      kind (Printexc.to_string e)
+                  ; None
+                  )
+          )
+
+      let cache_dir_files = get_cache_dir "files"
+
+      let get_sources pd ~dest =
+        let {s_kind; s_base_name = _; s_download; s_extract} = pd.p_source in
+        match s_kind with
+        | `No -> failwith "no sources for package %S" pd.p_pkg_name
+        | (`File | `Dir) as s_kind ->
+            let _into_cache =
+              false
+            in
+            (* let () = assert_dir dest in *)
+            let (is_local, local_name) =
+              match s_download with
+              | `Local path ->
+                  let () = cachedbg "package %S is local, path %S"
+                    pd.p_pkg_name path
+                  in
+                  (true, path)
+              | `Remote dlfunc ->
+                  let () = cachedbg "package %S is remote, downloading"
+                    pd.p_pkg_name
+                  in
+                  let path = dlfunc ~dl_dest:dest in
+                  let () = cachedbg "package %S downloaded to %S" path in
+                  (false, path)
+            in
+            let () = cachedbg "extracting %S to %S" local_name dest
+            in
+            let r = s_extract ~path:local_name ~dest in
+            let () =
+              if not is_local
+              then
+                match s_kind with
+                | `File ->
+                    let () = cachedbg "package %S was remote, cleaning local \
+                                       downloaded file %S"
+                      pd.p_pkg_name local_name
+                    in
+                    Sys.remove local_name
+                | `Dir ->
+                    if r = local_name
+                    then
+                      let () = cachedbg "package %S was remote, but extracted \
+                                         to required dir %S, not cleaning"
+                                 pd.p_pkg_name r
+                      in
+                      ()
+                    else
+                      let () = cachedbg "package %S was remote, extracted to \
+                                         temporary dir %S, so cleaning it"
+                                 pd.p_pkg_name local_name
+                      in
+                      Reb_sys.rm_rf local_name
+            in
+              r
+
+    end
+
+
   module Build_state = struct
 
     type pkg_build_state =
     | No ->
         let src_dir = buildconf_work_src </> pd.p_pkg_work_dir in
         ( assure_dir buildconf_work_src
-        ; Reb_sys.rm_rf src_dir
-        ; assert
-            (try
-               (ignore (stat src_dir); false)
-             with
-             | Unix_error (ENOENT, "stat", _) -> true
-            )
-        ; assure_dir src_dir
-        ; let res =
-            match pd.p_source with
-            | Src f ->
-                f ~dest:src_dir
-          in
+        ; assure_empty_dir src_dir
+        ; let res = Cache.get_sources pd ~dest:src_dir in
           let () = bs_set_state pd (Sources res) in
           res
         )

src/pre_template.ml

   | Reqs_dynamic of (unit -> pkg list)
 type installation_instructions = (unit -> unit)
 type uninstallation_instructions = (unit -> unit)
-type source = Src of
-  ( dest:string ->
-    string (* where the sources really are (may be subdir of [dest]) *)
-  )
+type source =
+  { s_kind : [`File | `Dir | `No]
+  ; s_base_name : string
+  ; s_download :
+      [ `Local of string
+      | `Remote of (dl_dest:string (* directory *) -> string (* exact path *))
+      ]
+  ; s_extract : ( path:string (* exact path *) ->
+                  dest:string (* somewhere in work dir *) ->
+                  string (* extracted to *)
+                )
+  }
 
 
 module Provides
  :
   sig
     val none : source
-    val hg : string -> source
+    val hg : ?rev:string -> string -> source
     val local_tar_gz : string -> source
     val local_tar_bz2 : string -> source
     val local_dir : string -> source
-    val remote_tar_gz : string -> source
-    val remote_tar_bz2 : string -> source
+    val remote_tar_gz : ?md5:string -> string -> source
+    val remote_tar_bz2 : ?md5:string -> string -> source
   end
  =
   struct
 
     (* source values are applied when ~dest directory exists and it is empty *)
 
-    let none = Src (fun ~dest ->
-      ( ignore dest
-      ; failwith "Source.none: no source specified"
-      )
-    )
 
-    let hg repo =
-      Src
-        (fun ~dest ->
-           let argv = [| "hg" ; "clone" ; repo ; dest |] in
+    let none =
+      { s_kind = `No
+      ; s_base_name = "NONE"
+      ; s_download = `Local "NONE"
+      ; s_extract =
+          (fun ~path ~dest ->
+             ( ignore path
+             ; ignore dest
+             ; failwith "Source.none: extract: no source specified"
+             )
+          )
+      }
+
+
+    let is_local n = not (has_substring n "://")
+
+    let last_component_of_uri u =
+      let (_pre, post) = split_by_last ( (=) '/' ) u in
+      post
+
+    let dl_local path =
+            (fun ~dl_dest ->
+               ( ignore dl_dest
+               ; path
+               )
+            )
+
+    let hg ?(rev="tip") repo =
+      let clone ~workcopy ~src ~dest =
+           let argv = Array.of_list
+             ( [ "hg" ; "clone" ; "-r" ; rev ]
+             @ (if workcopy
+                then []
+                else [ "--noupdate" ]
+               )
+             @ [ src ; dest ]
+             )
+           in
            if 0 = Reb_sys.run ~show:true argv
            then
              let () = dbg "hg ident after cloning: %s"
                dest
            else failwith "can't clone mercurial repository with command %s"
                   (Reb_sys.dump_argv argv)
-        )
+      in
+      { s_kind = `Dir
+      ; s_base_name = last_component_of_uri repo
+      ; s_download =
+          if is_local repo
+          then
+            `Local repo
+          else
+            `Remote
+            (fun ~dl_dest ->
+               let () = dbg "Source.hg: download: cloning %S (rev %S) \
+                             to %S without workcopy"
+                 repo rev dl_dest
+               in
+               clone ~src:repo ~dest:dl_dest ~workcopy:false
+            )
+      ; s_extract =
+          (fun ~path ~dest ->
+             if path = dest
+             then
+               Reb_sys.with_chdir dest
+                 (fun () ->
+                    ( dbg "Source.hg: extract: updating to revision %S \
+                           inplace (pwd = %S)"
+                          rev (Sys.getcwd ())
+                    ; Reb_sys.run_ok ~show:true [| "hg" ; "update" |]
+                    ; dest
+                    )
+                 )
+             else
+               ( dbg "Source.hg: extract: fair cloning %S (rev %S) to %S"
+                   path rev dest
+               ; clone ~src:path ~dest ~workcopy:true
+               )
+          )
+      }
 
     let get_one_dir dest =
       match Sys.readdir dest with
                          but expected only one directory"
                         (Array.length arr)
 
-    let local_tar_archive ~keys ~funcname infn =
+    let local_tar_archive ~keys ~funcname ~path =
         (fun ~dest ->
+           let infn = path in
            try
              if Sys.readdir dest <> [| |]
              then failwith "destination directory is not empty"
                funcname infn dest
         )
 
-    let do_local_tar_gz ~funcname infn = local_tar_archive
+    let do_local_tar_gz ~funcname = local_tar_archive
       ~keys:"-xzf"
       ~funcname
-      infn
 
     let local_tar_gz infn =
-      Src (do_local_tar_gz ~funcname:"Source.local_tar_gz" infn)
+      { s_kind = `File
+      ; s_base_name = last_component_of_uri infn
+      ; s_download = `Local infn
+      ; s_extract =
+          do_local_tar_gz ~funcname:"Source.local_tar_gz"
+      }
 
-    let do_local_tar_bz2 ~funcname infn = local_tar_archive
+    let do_local_tar_bz2 ~funcname = local_tar_archive
       ~keys:"-xjf"
       ~funcname
-      infn
 
-    let local_tar_bz2 infn = Src
-      (do_local_tar_bz2 ~funcname:"Source.local_tar_bz2" infn)
+    let local_tar_bz2 infn =
+      { s_kind = `File
+      ; s_base_name = last_component_of_uri infn
+      ; s_download = `Local infn
+      ; s_extract =
+          do_local_tar_bz2 ~funcname:"Source.local_tar_bz2"
+      }
 
     let local_dir dir =
-      Src
-        (fun ~dest ->
-           match Reb_sys.run ~show:true [| "cp"; "-R"; dir; dest |] with
-           | 0 -> get_one_dir dest
-           | _ -> failwith "Source.local_dir: can't copy directory %S to %S"
-                    dir dest
-        )
+      { s_kind = `Dir
+      ; s_base_name = last_component_of_uri dir
+      ; s_download = `Local dir
+      ; s_extract =
+          (fun ~path ~dest ->
+             match Reb_sys.run ~show:true [| "cp"; "-R"; path; dest |] with
+             | 0 -> get_one_dir dest
+             | _ -> failwith
+                "Source.local_dir: can't copy directory %S to %S"
+                path dest
+          )
+      }
 
     let downloader = lazy
       (if Reb_sys.has_command [| "wget" ; "--version" |]
          failwith "can't find wget or curl to download file"
       )
 
-    let download ~uri ~funcname ~outfn =
-      try (Lazy.force downloader) ~uri ~outfn
+    type md5hex = string
+    type hash = md5hex
+
+    let download ?(hash : hash option) ~uri ~funcname ~outfn =
+      try
+        let () = ignore hash in
+        (Lazy.force downloader) ~uri ~outfn
       with
       | e -> failchain e
           "%s: error downloading %S to %S"
           funcname uri outfn
 
-    let remote_archive ~unpack ~uri ~funcname =
-      Src
-        (fun ~dest ->
-           Reb_sys.with_temp_file
-             ~leave_on_fail:true
-             "reb_downloaded_archive" ""
-             (fun outfn ->
-                ( download ~uri ~funcname ~outfn
-                ; unpack ~funcname outfn ~dest
-                )
+    let remote_archive ?hash ~unpack ~uri ~funcname =
+      let base_name = last_component_of_uri uri in
+      { s_kind = `File
+      ; s_base_name = base_name
+      ; s_download = `Remote
+          (fun ~dl_dest ->
+             let outfn = dl_dest </> base_name in
+             ( download ?hash ~uri ~funcname ~outfn
+             ; outfn
              )
-        )
+          )
+      ; s_extract =
+          (fun ~path ~dest ->
+             unpack ~funcname ~path ~dest
+          )
+      }
 
-    let remote_tar_gz uri =
-      remote_archive
+    let remote_tar_gz ?md5 uri =
+      remote_archive ?hash:md5
          ~unpack:do_local_tar_gz
          ~funcname:"Source.remote_tar_gz"
          ~uri
 
-    let remote_tar_bz2 uri =
-      remote_archive
+    let remote_tar_bz2 ?md5 uri =
+      remote_archive ?hash:md5
         ~unpack:do_local_tar_bz2
         ~funcname:"Source.remote_tar_bz2"
         ~uri