Merge pull request #65 from samoht/master

Support HTTP redirects, fix the smart HTTP protocol

CHANGES.md

@@ -1,3 +1,7 @@
+## 1.4.10
+* Fix support for the smart HTTP protocol (report by @talex5,
+  mirage/irmin#138)
+
 ## 1.4.9
 * Remove the `OGITTMPDIR` and alway store temp files under
   `git/tmp` (mirage/irmin#132)

_oasis

@@ -1,6 +1,6 @@
 OASISFormat: 0.4
 Name:        git
-Version:     1.4.9
+Version:     1.4.10
 Synopsis:    A low-level interface to Git in pure OCaml
 Authors:     Thomas Gazagnaire
 License:     ISC

lib/META

@@ -1,6 +1,6 @@
 # OASIS_START
-# DO NOT EDIT (digest: 1665c737fe5fc633d8cf60fdf3138956)
-version = "1.4.9"
+# DO NOT EDIT (digest: 64d3ef20c9cfde0d3c79c09856fa52f2)
+version = "1.4.10"
 description = "A low-level interface to Git in pure OCaml"
 requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex"
 archive(byte) = "git.cma"
@@ -9,7 +9,7 @@ archive(native) = "git.cmxa"
 archive(native, plugin) = "git.cmxs"
 exists_if = "git.cma"
 package "unix" (
- version = "1.4.9"
+ version = "1.4.10"
  description = "A low-level interface to Git in pure OCaml"
  requires = "git cohttp.lwt lwt.unix conduit.lwt-unix uri.services"
  archive(byte) = "git-unix.cma"
@@ -20,7 +20,7 @@ package "unix" (
 )
 
 package "top" (
- version = "1.4.9"
+ version = "1.4.10"
  description = "Toplevel printers for Git values"
  requires = "git"
  archive(byte) = "git_top.cma"
@@ -31,7 +31,7 @@ package "top" (
 )
 
 package "mirage" (
- version = "1.4.9"
+ version = "1.4.10"
  description = "A low-level interface to Git in pure OCaml"
  requires = "git mirage-types.lwt io-page"
  archive(byte) = "git-mirage.cma"

lib/pack.ml

@@ -116,15 +116,15 @@ module Raw = struct
     let size = List.length values in
     let i = ref 0 in
     let sha1 ~offsets ~pos p =
-      Printf.printf "\rResolving deltas: %3d%% (%d/%d)%!" (!i*100/size) (!i+1) size;
+      Log.info "Resolving deltas: %3d%% (%d/%d)" (!i*100/size) (!i+1) size;
       incr i;
       let buf = Misc.with_buffer (fun buf ->
           Packed_value.add_inflated_value_sync ~read ~offsets ~pos buf p
         ) in
       write buf
     in
     let keys = index_of_values_sync ~sha1 ~pack_checksum values in
-    Printf.printf "\rResolving deltas: 100%% (%d/%d), done.\n%!" !i !i;
+    Log.info "Resolving deltas: 100%% (%d/%d), done." !i !i;
     keys
 
   (* Since Git 1.8.5 the naming is hardly reproductible, so pick a

lib/sync.ml

@@ -153,7 +153,9 @@ module Make (IO: IO) (Store: Store.S) = struct
         let size =
           let str = "0x" ^ size in
           try int_of_string str - 4
-          with _ -> error "%s is not a valid integer" str in
+          with Failure _ ->
+            error "PacketLine.input: %S is not a valid integer" str
+        in
         IO.read_exactly ic size >>= fun payload ->
         Log.debug "RECEIVED: %S (%d)" payload size;
         return (Some payload)
@@ -422,7 +424,7 @@ module Make (IO: IO) (Store: Store.S) = struct
               let ref = Reference.of_raw ref in
               let references = add sha1 ref in
               aux { acc with references }
-          | None -> error "%s is not a valid answer" line
+          | None -> error "Listing.input: %S is not a valid answer" line
       in
       skip_smart_http () >>= fun () ->
       aux empty
@@ -524,7 +526,9 @@ module Make (IO: IO) (Store: Store.S) = struct
             | "deepen"    ->
               let d =
                 try int_of_string s
-                with _ -> error "%s is not a valid integer" s in
+                with Failure _ ->
+                  error "Upload.input: %S is not a valid integer" s
+              in
               aux (Deepen d :: acc)
             | "want" ->
               let aux id c = aux (Want (SHA.of_hex id, c) :: acc) in
@@ -534,7 +538,7 @@ module Make (IO: IO) (Store: Store.S) = struct
                   | Want (_,c)::_ -> aux s c
                   | _             -> error "want without capacity"
               end
-            | s -> error "%s is not a valid upload request." s
+            | s -> error "Upload.input: %S is not a valid upload request." s
       in
       aux []
 

lib/unix/git_unix.ml

@@ -70,17 +70,24 @@ module M = struct
            | Some s -> write oc s
          end >>= fun () ->
          fn (ic, oc))
-      (fun ()  -> Lwt_io.close ic)
+      (fun ()  ->
+         Lwt.catch
+           (fun () -> Lwt_io.close ic)
+           (function
+             | Unix.Unix_error _ -> Lwt.return_unit
+             | e -> fail e))
 
-  let http_call ?headers meth uri fn =
+  exception Redirect of Uri.t
+
+  let rec http_call ?headers ?(redirects=0) meth uri fn =
     let headers = match headers with None -> Cohttp.Header.init () | Some h -> h in
     let callback (ic, oc) =
       let req = match meth with
         | `GET ->
           Cohttp.Request.make_for_client ~headers ~chunked:false
             (meth :> Cohttp.Code.meth) uri
         | `POST ->
-          Cohttp_lwt_unix.Request.make_for_client ~headers ~chunked:true
+          Cohttp.Request.make_for_client ~headers ~chunked:true
             (meth :> Cohttp.Code.meth) uri
       in
       let http_oc =
@@ -105,26 +112,28 @@ module M = struct
         let reader = ref None in
         let old_chunk = ref None in
         let read reader bytes off len =
-          let write chunk =
+          let read_in_chunk chunk =            (* Use [chunk] as read buffer. *)
             let blit len =
               Lwt_bytes.blit_from_bytes chunk 0 bytes off len;
-              Log.debug "refill: actual-len=%d" len;
               Lwt.return len
             in
             let n = String.length chunk in
-            if n <= len then blit n
-            else
-              let tl = String.sub chunk len (n - len - 1) in
+            if n <= len then (
+              old_chunk := None;
+              blit n;
+            ) else (
+              let tl = String.sub chunk len (n - len) in
               old_chunk := Some tl;
               blit len
+            )
           in
           match !old_chunk with
-          | Some c -> write c
+          | Some c -> read_in_chunk c
           | None ->
             Cohttp_lwt_unix.Response.read_body_chunk reader >>= function
             | Cohttp.Transfer.Done -> Lwt.return 0
-            | Cohttp.Transfer.Chunk chunk -> write chunk
-            | Cohttp.Transfer.Final_chunk chunk -> write chunk
+            | Cohttp.Transfer.Chunk chunk -> read_in_chunk chunk
+            | Cohttp.Transfer.Final_chunk chunk -> read_in_chunk chunk
         in
         Lwt_io.make ~mode:Lwt_io.input ~close:(fun () -> Lwt_io.close ic)
           (fun bytes off len ->
@@ -134,20 +143,47 @@ module M = struct
                  flush_http_oc () >>= fun () ->
                  Cohttp_lwt_unix.Response.read ic >>= function
                  | `Ok r ->
-                   let r = Cohttp_lwt_unix.Response.make_body_reader r ic in
-                   reader := Some r;
-                   Lwt.return_unit
+                   let status = Cohttp_lwt_unix.Response.status r in
+                   let status_code = Cohttp.Code.code_of_status status in
+                   let status = Cohttp.Code.string_of_status status in
+                   if Cohttp.Code.is_redirection status_code then (
+                     let uri =
+                       try
+                         Cohttp_lwt_unix.Response.headers r
+                         |> Cohttp.Header.to_list
+                         |> List.assoc "location"
+                         |> Uri.of_string
+                       with Not_found ->
+                         failwith status
+                     in
+                     fail (Redirect uri)
+                   ) else if Cohttp.Code.is_success status_code then (
+                     let r = Cohttp_lwt_unix.Response.make_body_reader r ic in
+                     reader := Some r;
+                     Lwt.return_unit
+                   ) else (
+                     Log.error "with_http: %s" status;
+                     failwith status
+                   )
                  | `Eof       -> Lwt.return_unit
                  | `Invalid i -> Lwt.fail (Failure i)
                end >>= fun () ->
                begin match !reader with
                  | Some reader -> read reader bytes off len
-                 | None        -> return 0
+                 | None        -> Lwt.return 0
                end
              | Some reader -> read reader bytes off len)
       in
       Cohttp_lwt_unix.Request.write_header req oc >>= fun () ->
-      fn (http_ic, http_oc)
+      Lwt.catch
+        (fun () -> fn (http_ic, http_oc))
+        (function
+          | Redirect uri ->
+            Lwt_io.close http_ic >>= fun () ->
+            let redirects = redirects + 1 in
+            if redirects > 10 then fail (Failure "Too many redirects")
+            else http_call ~headers ~redirects meth uri fn
+          | e -> fail e)
     in
     with_conduit uri callback
 
@@ -235,10 +271,14 @@ module D = struct
       )
 
   let directories dir =
-    list_files (fun f -> try Sys.is_directory f with _ -> false) dir
+    list_files (fun f ->
+        try Sys.is_directory f with Sys_error _ -> false
+      ) dir
 
   let files dir =
-    list_files (fun f -> try not (Sys.is_directory f) with _ -> false) dir
+    list_files (fun f ->
+        try not (Sys.is_directory f) with Sys_error _ -> false
+      ) dir
 
   let rec_files dir =
     let rec aux accu dir =

lib/value.ml

@@ -92,7 +92,10 @@ let input_inflated buf =
     | None   -> Mstruct.parse_error_buf buf "value: size"
     | Some s ->
       try int_of_string s
-      with _ -> Mstruct.parse_error_buf buf "%S is not a valid integer." s in
+      with Failure _ ->
+        Mstruct.parse_error_buf buf
+          "Value.input_inflated: %S is not a valid integer." s
+  in
   if size <> Mstruct.length buf then
     Mstruct.parse_error_buf buf
       "[expected-size: %d; actual-size: %d]\n"

setup.ml

@@ -1,7 +1,7 @@
 (* setup.ml generated for the first time by OASIS v0.4.1 *)
 
 (* OASIS_START *)
-(* DO NOT EDIT (digest: fe69a89a80a38719c76e24deae5f08f9) *)
+(* DO NOT EDIT (digest: 8fed711476b2bc37bb0a7addf1ca2c88) *)
 (*
    Regenerated by OASIS v0.4.5
    Visit http://oasis.forge.ocamlcore.org for more information and
@@ -6861,7 +6861,7 @@ let setup_t =
           alpha_features = [];
           beta_features = [];
           name = "git";
-          version = "1.4.9";
+          version = "1.4.10";
           license =
             OASISLicense.DEP5License
               (OASISLicense.DEP5Unit
@@ -7251,7 +7251,7 @@ let setup_t =
        };
      oasis_fn = Some "_oasis";
      oasis_version = "0.4.5";
-     oasis_digest = Some "4u\015:¸ÜUvI\152Ë3r¦yè";
+     oasis_digest = Some "Á\137\029\132ý}©VV)²%¹YÐ\021";
      oasis_exec = None;
      oasis_setup_args = [];
      setup_update = false