Merge pull request #93 from samoht/master

Fix the fd leak and few other bugfixes and cleanups
mirage · Jul 3, 2015 · 9ecf2e4 · 9ecf2e4
2 parents 2280995 + 21930cc
commit 9ecf2e4
Show file tree

Hide file tree

Showing 20 changed files with 496 additions and 385 deletions.
diff --git a/.merlin b/.merlin
@@ -1,4 +1,4 @@
 PKG cstruct dolog ocamlgraph re zip uri lwt mstruct cmdliner mirage-types
-PKG nocrypto hex cohttp.lwt mirage-flow tcpip mirage-http
+PKG nocrypto hex cohttp.lwt mirage-flow tcpip mirage-http alcotest
 B _build/**
 S lib/
diff --git a/CHANGES.md b/CHANGES.md
@@ -1,6 +1,13 @@
-### 1.5.2
+### 1.5.2 (2015-07-04)
 
 * Fix handling of empty paths (#89)
+* Fix the serialization of dates in commit objects
+* Expose `Git.Packed_value.PIC.pretty`
+* Improve the efficiency of `Git_unix.FS.remove`
+* Support shallow packs (#81)
+* Fix an mmap leak introduced in `1.5.*` (#90)
+* Remove the dependency to OUnit for the tests
+* Improve the pretty printers and the output of `ogit`
 
 ### 1.5.1 (2015-06-18)
 

diff --git a/bin/ogit.ml b/bin/ogit.ml
@@ -14,7 +14,7 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
-open Lwt
+open Lwt.Infix
 open Cmdliner
 open Printf
 open Git
@@ -172,8 +172,8 @@ let cat = {
         Lwt_io.with_file ~mode:Lwt_io.input file (fun x -> Lwt_io.read x)
         >>= fun buf ->
         let v = Value.input (Mstruct.of_string buf) in
-        Printf.printf "%s%!" (Value.pretty v);
-        return_unit
+        Printf.printf "%s%!\n" (Value.pretty v);
+        Lwt.return_unit
       end in
     Term.(mk cat_file $ file)
 }
@@ -211,16 +211,10 @@ let cat_file = {
                    let c = Tag.pretty tag in
                    "tag", c, String.length c
                in
-               if ty_flag then
-                 Printf.printf "%s%!" t;
-
-               if sz_flag then
-                 Printf.printf "%d%!" s;
-
-               if not ty_flag && not sz_flag then
-                 Printf.printf "%s%!" c;
-
-               return_unit
+               if ty_flag then Printf.printf "%s%!\n" t;
+               if sz_flag then Printf.printf "%d%!\n" s;
+               if not ty_flag && not sz_flag then Printf.printf "%s%!\n" c;
+               Lwt.return_unit
              end
           )
           (function
@@ -252,7 +246,7 @@ let ls_remote = {
             (SHA.Commit.to_hex sha1)
             (Reference.to_raw ref) in
         Reference.Map.iter print references;
-        return_unit
+        Lwt.return_unit
       end in
     Term.(mk ls $ backend $ remote)
 }
@@ -277,7 +271,7 @@ let ls_files = {
           List.iter
             (fun e -> Printf.printf "%s\n" e.Index.name)
             cache.Index.entries;
-        return_unit
+        Lwt.return_unit
       end in
     Term.(mk ls $ backend $ debug)
 }
@@ -314,7 +308,7 @@ let ls_tree = {
             match v with
             | Value.Blob _ -> begin
                 printf "blob %s %s\n" (SHA.to_hex sha1) path;
-                return_unit
+                Lwt.return_unit
               end
             | Value.Tree tree -> begin
                 Lwt_list.iter_s
@@ -334,12 +328,12 @@ let ls_tree = {
                      if is_dir && recurse then
                        walk recurse show_tree only_tree path' e.Tree.node
                      else
-                       return_unit
+                       Lwt.return_unit
                   ) tree
               end
             | Value.Tag _ -> begin
                 printf "tag %s %s\n" (SHA.to_hex sha1) path;
-                return_unit
+                Lwt.return_unit
               end
             | Value.Commit commit -> begin
                 (* printf "commit %s %s\n" (SHA.to_hex sha1) path; *)
@@ -383,11 +377,11 @@ let read_tree = {
           if List.exists (fun r -> Reference.to_raw r = ref) refs then
             S.read_reference_exn t (Reference.of_raw ref)
           else
-            return (SHA.Commit.of_hex commit_str)
+            Lwt.return (SHA.Commit.of_hex commit_str)
         end >>= fun commit ->
         S.write_index t commit >>= fun () ->
         printf "The index file has been update to %s\n%!" commit_str;
-        return_unit
+        Lwt.return_unit
       end in
     Term.(mk read $ backend $ commit)
 }
@@ -428,13 +422,13 @@ let clone = {
         printf "Cloning into '%s' ...\n%!" (Filename.basename (S.root t));
         Sync.clone t ?deepen ~unpack remote >>= fun r ->
         if not bare then match r.Result.head with
-          | None      -> return_unit
+          | None      -> Lwt.return_unit
           | Some head ->
             S.write_index t head >>= fun () ->
             printf "HEAD is now at %s\n" (SHA.Commit.to_hex head);
-            return_unit
+            Lwt.return_unit
         else
-          return_unit
+          Lwt.return_unit
       end in
     Term.(mk clone $ backend $ depth $ bare $ unpack $ remote $ directory)
 }
@@ -450,7 +444,7 @@ let fetch = {
       run begin
         S.create ()                 >>= fun t ->
         Sync.fetch t ~unpack remote >>= fun _ ->
-        return_unit
+        Lwt.return_unit
       end in
     Term.(mk fetch $ backend $ unpack $ remote)
 }
@@ -466,7 +460,7 @@ let pull = {
       run begin
         S.create ()               >>= fun t ->
         Sy.fetch t ~unpack remote >>= function
-        | { Sync.Result.head = None; _ }   -> return_unit
+        | { Sync.Result.head = None; _ }   -> Lwt.return_unit
         | { Sync.Result.head = Some h; _ } ->
           S.write_index t h >>= fun () ->
           S.read_head t >>= function
@@ -497,7 +491,7 @@ let push = {
           | Some _ -> branch in
         Sync.push t ~branch remote >>= fun s ->
         printf "%s\n" (Result.pretty_push s);
-        return_unit
+        Lwt.return_unit
       end in
     Term.(mk push $ backend $ remote $ branch)
 }

diff --git a/lib/FS.ml b/lib/FS.ml
@@ -14,10 +14,13 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *)
 
+open Lwt.Infix
 open Misc.OP
 open Printf
 
-let (>>=) = Lwt.bind
+let err_not_found n k =
+  let str = Printf.sprintf "Git.FS.%s: %s not found" n k in
+  Lwt.fail (Invalid_argument str)
 
 module LogMake = Log.Make
 
@@ -279,7 +282,7 @@ module Make (IO: IO) = struct
         let file = index t sha1 in
         IO.file_exists file >>= function
         | true ->
-          IO.read_file file >>= fun buf ->
+          File_cache.read file >>= fun buf ->
           let index = Pack_index.create (Cstruct.to_bigarray buf) in
           LRU.add index_c_lru sha1 index;
           Lwt.return index
@@ -341,42 +344,41 @@ module Make (IO: IO) = struct
       if sz < pack_size_thresh then
         Hashtbl.add pack_ba_cache sha ba
 
-    let read_in_pack t pack_sha1 sha1 =
+    let read_in_pack ~read t pack_sha1 sha1 =
       Log.debug "read_in_pack %s:%s"
         (SHA.to_hex pack_sha1) (SHA.to_hex sha1);
       read_index_c t pack_sha1 >>= fun index ->
-      if Pack_index.mem index sha1 then begin
-        try
-          let ba = Hashtbl.find pack_ba_cache pack_sha1 in
-          Log.debug "read_in_pack ba cache hit!";
-          let v_opt = Pack.Raw.read (Mstruct.of_bigarray ba) index sha1 in
-          Lwt.return v_opt
-        with
-          Not_found -> begin
-            let file = file t pack_sha1 in
-            IO.file_exists file >>= function
-            | true ->
-              IO.read_file file >>= fun buf ->
-              cache_pack pack_sha1 buf;
-              let v_opt = Pack.Raw.read (Mstruct.of_cstruct buf) index sha1 in
-              Lwt.return v_opt
-            | false ->
-              Log.error
-                "No file associated with the pack object %s.\n" (SHA.to_hex pack_sha1);
-              Lwt.fail (Failure "read_in_pack")
-          end
-      end
+      if Pack_index.mem index sha1 then
+        Lwt.catch
+          (fun () ->
+             let ba = Hashtbl.find pack_ba_cache pack_sha1 in
+             Log.debug "read_in_pack ba cache hit!";
+             Pack.Raw.read ~read (Mstruct.of_bigarray ba) index sha1)
+          (function
+            | Not_found -> begin
+                let file = file t pack_sha1 in
+                IO.file_exists file >>= function
+                | true ->
+                  File_cache.read file >>= fun buf ->
+                  cache_pack pack_sha1 buf;
+                  Pack.Raw.read ~read (Mstruct.of_cstruct buf) index sha1
+                | false ->
+                  Log.error
+                    "No file associated with the pack object %s.\n" (SHA.to_hex pack_sha1);
+                  Lwt.fail (Failure "read_in_pack")
+              end
+            | e -> Lwt.fail e)
       else begin
         Log.debug "read_in_pack: not found";
         Lwt.return_none
       end
 
-    let read t sha1 =
+    let read ~read t sha1 =
       list t >>= fun packs ->
       Lwt_list.fold_left_s (fun acc pack ->
           match acc with
           | Some v -> Lwt.return (Some v)
-          | None   -> read_in_pack t pack sha1
+          | None   -> read_in_pack ~read t pack sha1
         ) None packs
 
     let mem t sha1 =
@@ -397,22 +399,20 @@ module Make (IO: IO) = struct
     let keys = SHA.Set.to_list keys in
     Lwt.return keys
 
-  let read t sha1 =
+  let rec read t sha1 =
     Log.debug "read %s" (SHA.to_hex sha1);
     match Value.Cache.find sha1 with
     | Some v -> Lwt.return (Some v)
     | None   ->
       Log.debug "read: cache miss!";
       Loose.read t sha1 >>= function
       | Some v -> Value.Cache.add sha1 v; Lwt.return (Some v)
-      | None   -> Packed.read t sha1
+      | None   -> Packed.read ~read:(read t) t sha1
 
   let read_exn t sha1 =
     read t sha1 >>= function
     | Some v -> Lwt.return v
-    | None   ->
-      Log.debug "read_exn: Cannot read %s" (SHA.to_hex sha1);
-      Lwt.fail Not_found
+    | None   -> err_not_found "read_exn" (SHA.pretty sha1)
 
   let mem t sha1 =
     match Value.Cache.find sha1 with
@@ -465,6 +465,8 @@ module Make (IO: IO) = struct
     let file = file_of_ref t ref in
     IO.file_exists file >>= function
     | true ->
+      (* We use `IO.read_file` here as the contents of the file might
+         change. *)
       IO.read_file file >>= fun hex ->
       let hex = String.trim (Cstruct.to_string hex) in
       Lwt.return (Some (SHA.Commit.of_hex hex))
@@ -473,6 +475,8 @@ module Make (IO: IO) = struct
       IO.file_exists packed_refs >>= function
       | false -> Lwt.return_none
       | true  ->
+        (* We use `IO.read_file` here as the contents of the file
+           might change. *)
         IO.read_file packed_refs >>= fun buf ->
         let refs = Packed_refs.input (Mstruct.of_cstruct buf) in
         let sha1 = Packed_refs.find refs ref in
@@ -482,6 +486,8 @@ module Make (IO: IO) = struct
     let file = file_of_ref t Reference.head in
     IO.file_exists file >>= function
     | true ->
+      (* We use `IO.read_file` here as the contents of the file might
+         change. *)
       IO.read_file file >>= fun str ->
       let str = Cstruct.to_string str in
       let contents = match Misc.string_split ~on:' ' str with
@@ -497,9 +503,7 @@ module Make (IO: IO) = struct
   let read_reference_exn t ref =
     read_reference t ref >>= function
     | Some s -> Lwt.return s
-    | None   ->
-      Log.debug "read_reference_exn: Cannot read %s" (Reference.pretty ref);
-      Lwt.fail Not_found
+    | None   -> err_not_found "read_reference_exn" (Reference.pretty ref)
 
   let write t value =
     Loose.write t value >>= fun sha1 ->
@@ -608,12 +612,12 @@ module Make (IO: IO) = struct
       let contents = Cstruct.of_string blob in
       let rec write n =
         let one () =
-          Log.debug "one %s" file;
+          Log.debug "one %S" file;
           IO.write_file file ~temp_dir contents
         in
         if n <= 1 then one () else
           Lwt.catch one (fun e ->
-              Log.debug "write (%d/10): Got %s, retrying."
+              Log.debug "write (%d/10): Got %S, retrying."
                 (11-n) (Printexc.to_string e);
               IO.remove file >>= fun () ->
               write (n-1))
@@ -631,6 +635,8 @@ module Make (IO: IO) = struct
     IO.file_exists file >>= function
     | false -> Lwt.return Index.empty
     | true  ->
+      (* We use `IO.read_file` here as the contents of the file might
+         change. *)
       IO.read_file file >>= fun buf ->
       let buf = Mstruct.of_cstruct buf in
       Lwt.return (Index.input buf)