diff --git a/CHANGES.md b/CHANGES.md index 3a563886d..31649ccdf 100644 --- a/CHANGES.md +++ b/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) diff --git a/_oasis b/_oasis index 3d4262c23..ac6752c7a 100644 --- a/_oasis +++ b/_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 diff --git a/lib/META b/lib/META index f408668a8..7b508a16c 100644 --- a/lib/META +++ b/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" diff --git a/lib/pack.ml b/lib/pack.ml index a025ddd9b..5cbafd9f4 100644 --- a/lib/pack.ml +++ b/lib/pack.ml @@ -116,7 +116,7 @@ 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 @@ -124,7 +124,7 @@ module Raw = struct 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 diff --git a/lib/sync.ml b/lib/sync.ml index 9b06ade77..803899d3d 100644 --- a/lib/sync.ml +++ b/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 [] diff --git a/lib/unix/git_unix.ml b/lib/unix/git_unix.ml index ae1a174ee..3a9bc03a8 100644 --- a/lib/unix/git_unix.ml +++ b/lib/unix/git_unix.ml @@ -70,9 +70,16 @@ 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 @@ -80,7 +87,7 @@ module M = struct 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 = diff --git a/lib/value.ml b/lib/value.ml index 3ad6c46b6..887cdd267 100644 --- a/lib/value.ml +++ b/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" diff --git a/setup.ml b/setup.ml index 058f06cdd..09dfdc1be 100644 --- a/setup.ml +++ b/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