Commits

Dmitry Grebeniuk  committed 01d464d Draft

+ checking digests (MD5 for now) of downloaded files

  • Participants
  • Parent commits 0a1bf04

Comments (0)

Files changed (3)

File src/common.ml

 
 let dbg fmt = Printf.ksprintf (Printf.eprintf "DBG: %s\n%!") fmt
 
+let ( !! ) = Lazy.force
+
 let split_by_last pred str =
   let len = String.length str in
   let rec loop i =

File src/post_template.ml

 
 let depdbg fmt = Printf.ifprintf () fmt
 
-let ( !! ) = Lazy.force
-
 module Do_rebuild
   (Cfg :
      sig
       let cache_dir_repos = get_cache_dir "repos"
 
 
+      let check_md5 ~fname ~md5hex =
+        let f = String.lowercase (Digest.to_hex (Digest.file fname))
+        and m = String.lowercase md5hex in
+        if f = m
+        then None
+        else
+          Some (sprintf
+            "mismatch of MD5 digest for file %S: expected %S, got %S"
+              fname m f
+          )
+
+
+      let check_digest ~fname ~rf_digest =
+        let () = ignore (rf_digest : digest option) in
+        match rf_digest with
+        | None -> None
+        | Some (digest : digest) ->
+            match digest with
+            | (md5hex : md5hex) ->
+                check_md5 ~fname ~md5hex
+
+
       (* todo: assuming there's [cached_name] pointing to file/repo,
          check file's checksum, revision's presence for repo.
          returns (bool, cached_name), bool is true if ok.
 
       let check_cache ~rkind ~cachedir =
           match rkind with
-          | `File { rf_base_name } ->
+          | `File { rf_base_name ; rf_digest } ->
               let cached_fname = cachedir </> rf_base_name in
               ( (   Sys.file_exists cached_fname
                  && not (Sys.is_directory cached_fname)
-                 (* && checksum is ok *)
+                 && (match check_digest ~fname:cached_fname ~rf_digest with
+                     | None -> true
+                     | Some err ->
+                         let () = cachedbg "error checking cache of %S: %s"
+                           cached_fname err
+                         in
+                           false
+                    )
                 )
               , cached_fname
               )
                   let path = dlfunc ~dl_dest in
                   let () = cachedbg "package %S downloaded to %S"
                     pkg_name path in
+                  let () =
+                    match s_download with
+                    | `Local _ | `Remote ((`Repo _), _) -> ()
+                    | `Remote (`File { rf_digest ; _ }, _) ->
+                        match check_digest ~fname:path ~rf_digest with
+                        | None -> ()
+                        | Some err -> failwith
+                            "error getting sources without cache: %s"
+                              err
+                  in
                   path
             in
             let () = cachedbg "extracting %S to %S" local_path dest
               | `Remote (rkind, _) ->
                   begin
                   match rkind with
-                  | `File { rf_base_name = _ } ->
+                  | `File { rf_base_name = _ ; rf_digest = _ } ->
                       let () = cachedbg "package %S was remote file, \
                                          cleaning local \
                                          downloaded file %S"

File src/pre_template.ml

   | Reqs_dynamic of (unit -> pkg list)
 type action = (unit -> unit)
 type downloadfunc = (dl_dest:string (* directory *) -> string (* exact path *))
+type md5hex = string
+type digest = md5hex
 type remote_file_info =
   { rf_base_name : string
+  ; rf_digest : digest option
   }
 type remote_repo_info =
   { rr_pull : unit -> bool
          failwith "can't find wget or curl to download file"
       )
 
-    type md5hex = string
-    type hash = md5hex
-
-    let download ?(hash : hash option) ~uri ~funcname ~outfn =
+    let download ~uri ~funcname ~outfn =
       try
-        let () = ignore hash in
-        (Lazy.force downloader) ~uri ~outfn
+        !!downloader ~uri ~outfn
       with
       | e -> failchain e
           "%s: error downloading %S to %S"
           funcname uri outfn
 
-    let remote_archive ?hash ~unpack ~uri ~funcname =
+    let remote_archive ?digest ~unpack ~uri ~funcname =
       let base_name = last_component_of_uri uri in
-      { s_download = `Remote (`File { rf_base_name = base_name },
+      { s_download = `Remote (`File
+          { rf_base_name = base_name ; rf_digest = digest },
           (fun ~dl_dest ->
              let outfn = dl_dest </> base_name in
-             ( download ?hash ~uri ~funcname ~outfn
+             ( download ~uri ~funcname ~outfn
              ; outfn
              )
           ))
       }
 
     let remote_tar_gz ?md5 uri =
-      remote_archive ?hash:md5
+      remote_archive ?digest:md5
          ~unpack:do_local_tar_gz
          ~funcname:"Source.remote_tar_gz"
          ~uri
 
     let remote_tar_bz2 ?md5 uri =
-      remote_archive ?hash:md5
+      remote_archive ?digest:md5
         ~unpack:do_local_tar_bz2
         ~funcname:"Source.remote_tar_bz2"
         ~uri