From be702c04eb57df587abfa4f56cc8d45e31529d2d Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 9 Jan 2015 00:46:05 +0000 Subject: [PATCH 1/9] Update CHANGES --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 46f94457d..73a19545a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,7 @@ ## 1.4.4 +* Best-effort creation of files when expanding the index into the filesystem: + Skip the invalid filenames and continue. Users are expected to sanitize + their filenames if they want to use a non-bare repository (#11) * Overwrite changed file when expanding the index into the filesystem (#4) * Do not recompute the hash of blob files when expanding the index into the filesystem. This help fixing a speed issue with non-bare repo with lots of From 405732978f6545ae637a2ec2db440adf583c0734 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 9 Jan 2015 01:14:56 +0000 Subject: [PATCH 2/9] Protect Unix.mkdir of invalid filenames --- lib/unix/git_unix.ml | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/lib/unix/git_unix.ml b/lib/unix/git_unix.ml index 1b66fd001..aacc7839a 100644 --- a/lib/unix/git_unix.ml +++ b/lib/unix/git_unix.ml @@ -98,13 +98,20 @@ end module D = struct + let protect_exn = function + | Unix.Unix_error _ as e -> Lwt.fail (Failure (Printexc.to_string e)) + | e -> Lwt.fail e + + let protect f x = + Lwt.catch (fun () -> f x) protect_exn + let mkdir dirname = let rec aux dir = if Sys.file_exists dir then return_unit else ( aux (Filename.dirname dir) >>= fun () -> Log.debug "mkdir %s" dir; - Lwt_unix.mkdir dir 0o755 + protect (Lwt_unix.mkdir dir) 0o755; ) in Lwt_pool.use mkdir_pool (fun () -> aux dirname) @@ -151,8 +158,9 @@ module D = struct Log.info "Writing %s (/tmp/%s)" file (Filename.basename tmp); Lwt_unix.(openfile tmp [O_WRONLY; O_NONBLOCK; O_CREAT; O_TRUNC] 0o644) >>= fun fd -> Lwt.finalize - (fun () -> fn fd >>= fun () -> Lwt_unix.rename tmp file) - (fun _ -> Lwt_unix.close fd)) + (fun () -> protect fn fd >>= fun () -> Lwt_unix.rename tmp file) + (fun _ -> Lwt_unix.close fd) + ) let write_file file b = with_write_file file (fun fd -> write_cstruct fd b) From 47ab366171d05de0ef3ae51c5bd7af6d3162dd9b Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 9 Jan 2015 01:17:36 +0000 Subject: [PATCH 3/9] Fix Sync.fetch to not update HEAD also, update references only if asked to (default is false) --- lib/sync.ml | 35 ++++++++++++++++++++++------------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/lib/sync.ml b/lib/sync.ml index 13f184a52..e07c49279 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -766,6 +766,7 @@ module Make (IO: IO) (Store: Store.S) = struct f_deepen : int option; f_unpack : bool; f_capabilites: Capabilities.t; + f_update_tags: bool; } type op = @@ -838,20 +839,27 @@ module Make (IO: IO) (Store: Store.S) = struct | Ls -> return { Result.head; references; sha1s = [] } | Fetch _ | Clone _ -> - begin - try - let sha1 = Reference.Map.find Reference.head references in - let contents = Reference.head_contents references sha1 in - Store.write_head t contents - with Not_found -> - return_unit + begin match op with + | Ls | Fetch { f_update_tags = false; _ } -> return_unit + | Clone _ | Fetch _ -> + try + let write_ref (ref, sha1) = + if Reference.is_valid ref then + Store.write_reference t ref sha1 + else return_unit in + let references = + Reference.Map.remove Reference.head references + in + Lwt_list.iter_p write_ref (Reference.Map.to_alist references) + >>= fun () -> + let sha1 = Reference.Map.find Reference.head references in + let contents = Reference.head_contents references sha1 in + match op with + | Clone _ -> Store.write_head t contents + | _ -> return_unit + with Not_found -> + return_unit end >>= fun () -> - let write_ref (ref, sha1) = - if Reference.is_valid ref then Store.write_reference t ref sha1 - else return_unit in - let references = Reference.Map.remove Reference.head references in - Lwt_list.iter_p write_ref (Reference.Map.to_alist references) - >>= fun () -> match head with | None -> @@ -940,6 +948,7 @@ module Make (IO: IO) (Store: Store.S) = struct f_deepen = deepen; f_unpack = unpack; f_capabilites = capabilities; + f_update_tags = false; } in fetch_pack t gri (Fetch op) From 2caf49a8624f7367e058ca3c09fae8ee7e4e1d0e Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 9 Jan 2015 11:25:15 +0000 Subject: [PATCH 4/9] Code clean-ups to support smart HTTP --- lib/sync.ml | 169 ++++++++++++++++++++++++------------------- lib/sync.mli | 8 ++ lib/unix/git_unix.ml | 19 ++--- 3 files changed, 114 insertions(+), 82 deletions(-) diff --git a/lib/sync.ml b/lib/sync.ml index e07c49279..f3e227cb5 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -19,6 +19,26 @@ open Printf module Log = Log.Make(struct let section = "remote" end) +type protocol = [ `SSH | `Git | `Smart_HTTP ] + +let protocol uri = match Uri.scheme uri with + | Some "git" -> `Ok `Git + | Some "git+ssh" -> `Ok `SSH + | Some "http" + | Some "https" -> `Ok `Smart_HTTP + | Some x -> `Not_supported x + | None -> `Unknown + +let protocol_exn uri = match protocol uri with + | `Ok x -> x + | `Unknown -> failwith (sprintf "Unknown Git protocol") + | `Not_supported x -> failwith (sprintf "%s is not a supported Git protocol" x) + +let pretty_protocol = function + | `Git -> "git" + | `SSH -> "ssh" + | `Smart_HTTP -> "smart-http" + module Result = struct type fetch = { @@ -332,36 +352,36 @@ module Make (IO: IO) (Store: Store.S) = struct ) t.references; Buffer.contents buf - let input ic = - Log.debug "Listing.input"; + let input ic protocol = + Log.debug "Listing.input (protocol=%s)" (pretty_protocol protocol); let rec aux acc = PacketLine.input ic >>= function | None -> return acc | Some line -> match Misc.string_lsplit2 line ~on:Misc.sp with + | Some ("#", _) -> + if protocol <> `Smart_HTTP then error "ERROR: %s" line else aux acc | Some ("ERR", err) -> error "ERROR: %s" err | Some (sha1, ref) -> + let add sha1 ref = + SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref + acc.references + in if is_empty acc then ( (* Read the capabilities on the first line *) match Misc.string_lsplit2 ref ~on:Misc.nul with | Some (ref, caps) -> let ref = Reference.of_raw ref in - let references = - SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references - in + let references = add sha1 ref in let capabilities = Capabilities.of_string caps in aux { references; capabilities; } | None -> let ref = Reference.of_raw ref in - let references = - SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references - in + let references = add sha1 ref in aux { references; capabilities = []; } ) else let ref = Reference.of_raw ref in - let references = - SHA.Commit.Map.add_multi (SHA.Commit.of_hex sha1) ref acc.references - in + let references = add sha1 ref in aux { acc with references } | None -> error "%s is not a valid answer" line in @@ -782,9 +802,10 @@ module Make (IO: IO) (Store: Store.S) = struct | None -> todo "local-clone" | Some _ -> let uri = Gri.to_uri gri in + let protocol = protocol_exn uri in let init = Init.to_string r in IO.with_connection uri ~init (fun (ic, oc) -> - Listing.input ic >>= fun listing -> + Listing.input ic protocol >>= fun listing -> (* XXX: check listing.capabilities *) Log.debug "listing:\n %s" (Listing.pretty listing); Store.read_reference t branch >>= fun new_obj -> @@ -816,15 +837,76 @@ module Make (IO: IO) (Store: Store.S) = struct Report_status.input ic ) + let fetch_pack_with_head t (ic, oc) op references head = + Log.debug "PHASE1"; + let deepen = match op with + | Clone { c_deepen = d; _ } + | Fetch { f_deepen = d; _ } -> d + | _ -> None + in + let shallows = match op with + | Fetch { f_shallows = s; _ } -> s + | _ -> [] + in + let capabilities = match op with + | Fetch { f_capabilites = c; _ } + | Clone { c_capabilites = c; _ } -> c + | _ -> [] + in + Upload_request.phase1 (ic, oc) ?deepen ~capabilities + ~shallows ~wants:[SHA.of_commit head] + >>= fun _phase1 -> + + (* XXX: process the shallow / unshallow. *) + (* XXX: need a notion of shallow/unshallow in API. *) + + Log.debug "PHASE2"; + let haves = match op with + | Fetch { f_haves = h; _ } -> h + | _ -> [] in + Upload_request.phase2 (ic,oc) ~haves >>= fun () -> + + Log.debug "PHASE3"; + printf "Receiving data ...%!"; + Pack_file.input ~capabilities ic >>= fun raw -> + + printf " done.\n%!"; + Log.debug "Received a pack file of %d bytes." (String.length raw); + let pack = Cstruct.of_string raw in + + let unpack = match op with + | Clone { c_unpack = u; _ } + | Fetch { f_unpack = u; _ } -> u + | _ -> false in + Log.debug "unpack=%b" unpack; + + begin if unpack then + Pack.unpack ~write:(Store.write ?level:None t) pack + else + let pack = Pack.Raw.input (Mstruct.of_cstruct pack) ~index:None in + Store.write_pack t pack + end >>= fun sha1s -> + match SHA.Set.to_list sha1s with + | [] -> + Log.debug "NO NEW OBJECTS"; + Printf.printf "Already up-to-date.\n%!"; + return { Result.head = Some head; references; sha1s = [] } + | sha1s -> + Log.debug "NEW OBJECTS"; + printf "remote: Counting objects: %d, done.\n%!" + (List.length sha1s); + return { Result.head = Some head; references; sha1s } + let fetch_pack t gri op = let r = Init.upload_pack gri in match Init.host r with | None -> todo "local-clone" | Some _ -> let uri = Gri.to_uri gri in + let protocol = protocol_exn uri in let init = Init.to_string r in IO.with_connection uri ~init (fun (ic, oc) -> - Listing.input ic >>= fun listing -> + Listing.input ic protocol >>= fun listing -> Log.debug "listing:\n %s" (Listing.pretty listing); let references = List.fold_left (fun acc (sha1, refs) -> @@ -860,70 +942,11 @@ module Make (IO: IO) (Store: Store.S) = struct with Not_found -> return_unit end >>= fun () -> - match head with + | Some head -> fetch_pack_with_head t (ic, oc) op references head | None -> Init.close oc >>= fun () -> return { Result.head; references; sha1s = [] } - | Some head -> - Log.debug "PHASE1"; - let deepen = match op with - | Clone { c_deepen = d; _ } - | Fetch { f_deepen = d; _ } -> d - | _ -> None - in - let shallows = match op with - | Fetch { f_shallows = s; _ } -> s - | _ -> [] - in - let capabilities = match op with - | Fetch { f_capabilites = c; _ } - | Clone { c_capabilites = c; _ } -> c - | _ -> [] - in - Upload_request.phase1 (ic,oc) ?deepen ~capabilities - ~shallows ~wants:[SHA.of_commit head] - >>= fun _phase1 -> - - (* XXX: process the shallow / unshallow. *) - (* XXX: need a notion of shallow/unshallow in API. *) - - Log.debug "PHASE2"; - let haves = match op with - | Fetch { f_haves = h; _ } -> h - | _ -> [] in - Upload_request.phase2 (ic,oc) ~haves >>= fun () -> - - Log.debug "PHASE3"; - printf "Receiving data ...%!"; - Pack_file.input ~capabilities ic >>= fun raw -> - - printf " done.\n%!"; - Log.debug "Received a pack file of %d bytes." (String.length raw); - let pack = Cstruct.of_string raw in - - let unpack = match op with - | Clone { c_unpack = u; _ } - | Fetch { f_unpack = u; _ } -> u - | _ -> false in - Log.debug "unpack=%b" unpack; - - begin if unpack then - Pack.unpack ~write:(Store.write ?level:None t) pack - else - let pack = Pack.Raw.input (Mstruct.of_cstruct pack) ~index:None in - Store.write_pack t pack - end >>= fun sha1s -> - match SHA.Set.to_list sha1s with - | [] -> - Log.debug "NO NEW OBJECTS"; - Printf.printf "Already up-to-date.\n%!"; - return { Result.head = Some head; references; sha1s = [] } - | sha1s -> - Log.debug "NEW OBJECTS"; - printf "remote: Counting objects: %d, done.\n%!" - (List.length sha1s); - return { Result.head = Some head; references; sha1s } ) let ls t gri = diff --git a/lib/sync.mli b/lib/sync.mli index d68a89f59..ef77790f9 100644 --- a/lib/sync.mli +++ b/lib/sync.mli @@ -16,6 +16,12 @@ (** Clone/Fecth/Push protocol *) +type protocol = [ `SSH | `Git | `Smart_HTTP ] +(** The type for the different Git protocols. *) + +val protocol: Uri.t -> [`Ok of protocol | `Not_supported of string | `Unknown] +(** [protocol uri] is the Git protocol associated to [uri]. *) + type capability = [ `Multi_ack | `Thin_pack @@ -60,6 +66,8 @@ module type S = sig type t (** Abstract value for stores. *) + (** {1 The base Git protocol and Git+SSH} *) + val ls: t -> Gri.t -> SHA.Commit.t Reference.Map.t Lwt.t (** List the references of the remote repository. *) diff --git a/lib/unix/git_unix.ml b/lib/unix/git_unix.ml index aacc7839a..8d8997200 100644 --- a/lib/unix/git_unix.ml +++ b/lib/unix/git_unix.ml @@ -40,21 +40,23 @@ module M = struct let host = match Uri.host uri with | None -> "localhost" | Some x -> x in - match Uri.scheme uri with - | Some "git+ssh" -> + match Sync.protocol uri with + | `Ok `SSH -> let user = match Uri.userinfo uri with | None -> "" - | Some u -> u ^ "@" in + | Some u -> u ^ "@" + in let cmd = match init with | None -> [| "ssh"; user ^ host; |] - | Some x -> [| "ssh"; user ^ host; x |] in + | Some x -> [| "ssh"; user ^ host; x |] + in Log.info "Executing '%s'" (String.concat " " (Array.to_list cmd)); let env = Unix.environment () in let p = Lwt_process.open_process_full ~env ("ssh", cmd) in Lwt.finalize (fun () -> fn (p#stdout, p#stdin)) (fun () -> let _ = p#close in return_unit) - | Some "git" -> + | `Ok (`Git | `Smart_HTTP) -> Log.debug "Connecting to %s" (Uri.to_string uri); let resolver = Resolver_lwt_unix.system in Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> @@ -69,11 +71,10 @@ module M = struct end >>= fun () -> fn (ic, oc)) (fun () -> Lwt_io.close ic) - | Some x -> - (* XXX: make it work for smart-HTTP *) - (* XXX: make it work over SSL *) + | `Not_supported x -> fail (Failure ("Scheme " ^ x ^ " not supported yet")) - | None -> fail (Failure ("Must supply a scheme like git://")) + | `Unknown -> + fail (Failure ("Unknown protocol. Must supply a scheme like git://")) let read_all ic = let len = 64_1024 in From a8a161da88e38724f68de7fc942756c80704bb90 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Fri, 9 Jan 2015 17:51:18 +0000 Subject: [PATCH 5/9] Try to protect the Mirage backend with invalid filenames as well This is not pretty --- lib/mirage/git_mirage.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/lib/mirage/git_mirage.ml b/lib/mirage/git_mirage.ml index 69c10378c..05e07e985 100644 --- a/lib/mirage/git_mirage.ml +++ b/lib/mirage/git_mirage.ml @@ -116,9 +116,12 @@ module FS (FS: FS) = struct let read_file t file = Log.debug "read_file %s" file; FS.stat t file >>| fun s -> - FS.read t file 0 (Int64.to_int s.FS.size) >>| fun bs -> - let s = Cstruct.copyv bs in - return (Cstruct.of_string s) + is_directory t file >>= function + | false -> + FS.read t file 0 (Int64.to_int s.FS.size) >>| fun bs -> + let s = Cstruct.copyv bs in + return (Cstruct.of_string s) + | true -> fail (Failure (Printf.sprintf "%s is a directory" file)) let write_file t file b = Log.debug "write_file %s" file; From f48945a368f19380a778faa7a50bb9683e0ac765 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 10 Jan 2015 02:34:26 +0000 Subject: [PATCH 6/9] Depend on cohttp --- .merlin | 2 +- _oasis | 6 +++--- _tags | 7 ++++++- lib/META | 4 ++-- setup.ml | 7 ++++--- 5 files changed, 16 insertions(+), 10 deletions(-) diff --git a/.merlin b/.merlin index 8c38b85c6..832d9e2f3 100644 --- a/.merlin +++ b/.merlin @@ -1,4 +1,4 @@ PKG cstruct dolog ocamlgraph re zip uri lwt mstruct cmdliner mirage-types -PKG nocrypto hex +PKG nocrypto hex cohttp.lwt B _build/** S lib/ \ No newline at end of file diff --git a/_oasis b/_oasis index 27249f363..dc70d1115 100644 --- a/_oasis +++ b/_oasis @@ -29,15 +29,15 @@ Library git lwt, hex Library "git-unix" - Build$: flag(unix) + Build$: flag(unix) Path: lib/unix/ FindlibParent: git Findlibname: unix Modules: Git_unix - BuildDepends: git, lwt.unix, conduit.lwt-unix, uri.services + BuildDepends: git, cohttp.lwt, lwt.unix, conduit.lwt-unix, uri.services Library "git-mirage" - Build$: flag(mirage) + Build$: flag(mirage) Path: lib/mirage/ FindlibParent: git Findlibname: mirage diff --git a/_tags b/_tags index bd2963d37..efd815829 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: e523e8688c7da528848c072b66cdd8f7) +# DO NOT EDIT (digest: e20b5ffb1f25bd996a030452be571ff3) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -50,6 +50,7 @@ true: annot, bin_annot : pkg_zip # Library git-unix "lib/unix/git-unix.cmxs": use_git-unix +: pkg_cohttp.lwt : pkg_conduit.lwt-unix : pkg_dolog : pkg_hex @@ -77,6 +78,7 @@ true: annot, bin_annot : use_git # Executable ogit : pkg_cmdliner +: pkg_cohttp.lwt : pkg_conduit.lwt-unix : pkg_dolog : pkg_hex @@ -91,6 +93,7 @@ true: annot, bin_annot : use_git : use_git-unix : pkg_cmdliner +: pkg_cohttp.lwt : pkg_conduit.lwt-unix : pkg_dolog : pkg_hex @@ -106,6 +109,7 @@ true: annot, bin_annot : use_git-unix # Executable test_git : pkg_alcotest +: pkg_cohttp.lwt : pkg_conduit.lwt-unix : pkg_dolog : pkg_hex @@ -125,6 +129,7 @@ true: annot, bin_annot : use_git-mirage : use_git-unix : pkg_alcotest +: pkg_cohttp.lwt : pkg_conduit.lwt-unix : pkg_dolog : pkg_hex diff --git a/lib/META b/lib/META index ccbb98b32..958c5099c 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 3c1beaeb2c5ef2d099fded34938c9432) +# DO NOT EDIT (digest: d56eca42c04f2ba009b85e2caa624ca2) version = "1.4.3" description = "A low-level interface to Git in pure OCaml" requires = "mstruct dolog ocamlgraph zip nocrypto uri lwt hex" @@ -11,7 +11,7 @@ exists_if = "git.cma" package "unix" ( version = "1.4.3" description = "A low-level interface to Git in pure OCaml" - requires = "git lwt.unix conduit.lwt-unix uri.services" + requires = "git cohttp.lwt lwt.unix conduit.lwt-unix uri.services" archive(byte) = "git-unix.cma" archive(byte, plugin) = "git-unix.cma" archive(native) = "git-unix.cmxa" diff --git a/setup.ml b/setup.ml index 17826e4c4..4118d4199 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: 793d056568d1cc66fb8919bf950106e8) *) +(* DO NOT EDIT (digest: 2707048d828f3ca65e6b3f460cdf9de7) *) (* Regenerated by OASIS v0.4.5 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7017,6 +7017,7 @@ let setup_t = bs_build_depends = [ InternalLibrary "git"; + FindlibPackage ("cohttp.lwt", None); FindlibPackage ("lwt.unix", None); FindlibPackage ("conduit.lwt-unix", None); FindlibPackage ("uri.services", None) @@ -7218,7 +7219,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.5"; - oasis_digest = Some "ÃÐóFâù#/\\Ó+t\127°á\158"; + oasis_digest = Some "¯\159Òë\029´U&ã^)\002\003ªÙ\021"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -7226,6 +7227,6 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 7230 "setup.ml" +# 7231 "setup.ml" (* OASIS_STOP *) let () = setup ();; From 0cd3323a1543d94dbf38e7779c4a23f134483fe3 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 10 Jan 2015 02:35:58 +0000 Subject: [PATCH 7/9] Support for the "smart" HTTP protocol #26 This was a bit more painful than what was planned, as: - the the "smart" HTTP mode and in the Git/SSH ones have minor differences - it was quite involved to wrap Lwt_io.{input,output}_channel and Cohttp response and request bodies. But surpisingly, it seems to work well now. Very limited testing so far but this works: ogit clone https://github.com/samoht/test.git (And it's using conduit, so `export CONDUIT_TLS=native` works as well: OCaml everywhere!) --- lib/gri.ml | 8 --- lib/gri.mli | 6 -- lib/sync.ml | 115 ++++++++++++++++++++--------- lib/unix/git_unix.ml | 167 +++++++++++++++++++++++++++++++++++-------- 4 files changed, 219 insertions(+), 77 deletions(-) diff --git a/lib/gri.ml b/lib/gri.ml index 1a7895b24..07eaee571 100644 --- a/lib/gri.ml +++ b/lib/gri.ml @@ -45,11 +45,3 @@ let to_string uri = | Some h -> h in Printf.sprintf "%s%s:%s" userinfo host (Uri.path uri) | _ -> Uri.to_string uri - -type mode = [ `Git | `SSH | `HTTP ] - -let mode t = - match Uri.scheme t with - | Some "git" -> `Git - | Some "git+ssh" -> `SSH - | _ -> `HTTP diff --git a/lib/gri.mli b/lib/gri.mli index c4e638d49..01001c09d 100644 --- a/lib/gri.mli +++ b/lib/gri.mli @@ -37,9 +37,3 @@ val to_uri: t -> Uri.t val of_uri: Uri.t -> t (** Cast from [Uri.t]. *) - -type mode = [ `Git | `SSH | `HTTP ] -(** The three transmission protocols. *) - -val mode: t -> mode -(** Return the protocol mode. *) diff --git a/lib/sync.ml b/lib/sync.ml index f3e227cb5..3a67610cc 100644 --- a/lib/sync.ml +++ b/lib/sync.ml @@ -17,7 +17,7 @@ open Lwt open Printf -module Log = Log.Make(struct let section = "remote" end) +module Log = Log.Make(struct let section = "sync" end) type protocol = [ `SSH | `Git | `Smart_HTTP ] @@ -264,10 +264,12 @@ module Make (IO: IO) (Store: Store.S) = struct type t = { request: request; + discover: bool; (* The smart HTTP protocol has 2 modes. *) gri: Gri.t; } let host t = Uri.host (Gri.to_uri t.gri) + let uri t = Gri.to_uri t.gri (* Initialisation sentence for the Git protocol *) let git t = @@ -295,23 +297,45 @@ module Make (IO: IO) (Store: Store.S) = struct PacketLine.string_of_line message let ssh t = - sprintf "%s %s" (string_of_request t.request) (Uri.path (Gri.to_uri t.gri)) + sprintf "%s %s" (string_of_request t.request) + (Uri.path (Gri.to_uri t.gri)) + + let smart_http t = + if t.discover then None else + let headers : (string * string) list = [ + "Content-Type", + sprintf "application/x-%s-request" (string_of_request t.request); + ] + in + Some (Marshal.to_string headers []) - (* XXX: as we don't support the smart HTTP protocol (yet) we fall - back the default Git protocol. *) let to_string t = - match Gri.mode t.gri with - | `HTTP | `Git -> git t - | `SSH -> ssh t - - let close oc = - PacketLine.flush oc + match protocol_exn (Gri.to_uri t.gri) with + | `Git -> Some (git t) + | `SSH -> Some (ssh t) + | `Smart_HTTP -> smart_http t + + let create request ~discover gri = + Log.debug "Init.create request=%s discover=%b gri=%s" + (string_of_request request) discover (Gri.to_string gri); + let protocol = protocol_exn (Gri.to_uri gri) in + let gri = match protocol with + | `SSH | `Git -> gri + | `Smart_HTTP -> + let service = if discover then "info/refs?service=" else "" in + let url = Gri.to_string gri in + let request = string_of_request request in + Gri.of_string (sprintf "%s/%s%s" url service request) + in + Log.debug "computed-gri: %s" (Gri.to_string gri); + { request; discover; gri } - let upload_pack gri = { request = Upload_pack; gri } - let receive_pack gri = { request = Receive_pack; gri } - let _upload_archive gri = { request = Upload_archive; gri } + let upload_pack = create Upload_pack + let receive_pack = create Receive_pack + let _upload_archive = create Upload_archive end + module Listing = struct type t = { @@ -354,13 +378,28 @@ module Make (IO: IO) (Store: Store.S) = struct let input ic protocol = Log.debug "Listing.input (protocol=%s)" (pretty_protocol protocol); + let skip_smart_http () = + match protocol with + | `Git | `SSH -> return_unit + | `Smart_HTTP -> + PacketLine.input ic >>= function + | None -> error "SMART-HTTP: missing # header." + | Some line -> + match Misc.string_lsplit2 line ~on:Misc.sp with + | Some ("#", service) -> + Log.debug "skipping %s" service; + begin PacketLine.input ic >>= function + | None -> return_unit + | Some x -> error "SMART-HTTP: waiting for pkt-flush, got %S" x + end + | Some _ -> error "SMART-HTTP: waiting for # header, got %S" line + | None -> error "SMART-HTTP: waiting for # header, got pkt-flush" + in let rec aux acc = PacketLine.input ic >>= function | None -> return acc | Some line -> match Misc.string_lsplit2 line ~on:Misc.sp with - | Some ("#", _) -> - if protocol <> `Smart_HTTP then error "ERROR: %s" line else aux acc | Some ("ERR", err) -> error "ERROR: %s" err | Some (sha1, ref) -> let add sha1 ref = @@ -385,6 +424,7 @@ module Make (IO: IO) (Store: Store.S) = struct aux { acc with references } | None -> error "%s is not a valid answer" line in + skip_smart_http () >>= fun () -> aux empty end @@ -797,14 +837,15 @@ module Make (IO: IO) (Store: Store.S) = struct module Graph = Global_graph.Make(Store) let push t ~branch gri = - let r = Init.receive_pack gri in - match Init.host r with + Log.debug "Sync.push"; + let init = Init.receive_pack ~discover:true gri in + match Init.host init with | None -> todo "local-clone" | Some _ -> - let uri = Gri.to_uri gri in + let uri = Init.uri init in let protocol = protocol_exn uri in - let init = Init.to_string r in - IO.with_connection uri ~init (fun (ic, oc) -> + let init = Init.to_string init in + IO.with_connection uri ?init (fun (ic, oc) -> Listing.input ic protocol >>= fun listing -> (* XXX: check listing.capabilities *) Log.debug "listing:\n %s" (Listing.pretty listing); @@ -838,7 +879,7 @@ module Make (IO: IO) (Store: Store.S) = struct ) let fetch_pack_with_head t (ic, oc) op references head = - Log.debug "PHASE1"; + Log.debug "Sync.fetch_pack_with_head"; let deepen = match op with | Clone { c_deepen = d; _ } | Fetch { f_deepen = d; _ } -> d @@ -853,6 +894,7 @@ module Make (IO: IO) (Store: Store.S) = struct | Clone { c_capabilites = c; _ } -> c | _ -> [] in + Log.debug "PHASE1"; Upload_request.phase1 (ic, oc) ?deepen ~capabilities ~shallows ~wants:[SHA.of_commit head] >>= fun _phase1 -> @@ -898,14 +940,15 @@ module Make (IO: IO) (Store: Store.S) = struct return { Result.head = Some head; references; sha1s } let fetch_pack t gri op = - let r = Init.upload_pack gri in - match Init.host r with + Log.debug "Sync.fetch_pack"; + let init = Init.upload_pack ~discover:true gri in + match Init.host init with | None -> todo "local-clone" | Some _ -> - let uri = Gri.to_uri gri in + let uri = Init.uri init in let protocol = protocol_exn uri in - let init = Init.to_string r in - IO.with_connection uri ~init (fun (ic, oc) -> + let init = Init.to_string init in + IO.with_connection uri ?init (fun (ic, oc) -> Listing.input ic protocol >>= fun listing -> Log.debug "listing:\n %s" (Listing.pretty listing); let references = @@ -929,10 +972,11 @@ module Make (IO: IO) (Store: Store.S) = struct if Reference.is_valid ref then Store.write_reference t ref sha1 else return_unit in - let references = + let references_no_head = Reference.Map.remove Reference.head references in - Lwt_list.iter_p write_ref (Reference.Map.to_alist references) + Lwt_list.iter_p write_ref + (Reference.Map.to_alist references_no_head) >>= fun () -> let sha1 = Reference.Map.find Reference.head references in let contents = Reference.head_contents references sha1 in @@ -943,10 +987,17 @@ module Make (IO: IO) (Store: Store.S) = struct return_unit end >>= fun () -> match head with - | Some head -> fetch_pack_with_head t (ic, oc) op references head - | None -> - Init.close oc >>= fun () -> - return { Result.head; references; sha1s = [] } + | None -> return { Result.head; references; sha1s = [] } + | Some head -> + if protocol = `Smart_HTTP then + let init = Init.upload_pack ~discover:false gri in + let uri = Init.uri init in + let init = Init.to_string init in + IO.with_connection uri ?init (fun (ic, oc) -> + fetch_pack_with_head t (ic, oc) op references head + ) + else + fetch_pack_with_head t (ic, oc) op references head ) let ls t gri = diff --git a/lib/unix/git_unix.ml b/lib/unix/git_unix.ml index 8d8997200..af7f90449 100644 --- a/lib/unix/git_unix.ml +++ b/lib/unix/git_unix.ml @@ -36,41 +36,146 @@ module M = struct let flush oc = Lwt_io.flush oc - let with_connection uri ?init fn = + let with_ssh_process ?init uri fn = let host = match Uri.host uri with | None -> "localhost" - | Some x -> x in - match Sync.protocol uri with - | `Ok `SSH -> - let user = match Uri.userinfo uri with - | None -> "" - | Some u -> u ^ "@" + | Some x -> x + in + let user = match Uri.userinfo uri with + | None -> "" + | Some u -> u ^ "@" + in + let cmd = match init with + | None -> [| "ssh"; user ^ host; |] + | Some x -> [| "ssh"; user ^ host; x |] + in + Log.info "Executing '%s'" (String.concat " " (Array.to_list cmd)); + let env = Unix.environment () in + let p = Lwt_process.open_process_full ~env ("ssh", cmd) in + Lwt.finalize + (fun () -> fn (p#stdout, p#stdin)) + (fun () -> let _ = p#close in return_unit) + + let with_conduit ?init uri fn = + Log.debug "Connecting to %s" (Uri.to_string uri); + let resolver = Resolver_lwt_unix.system in + Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> + let ctx = Conduit_lwt_unix.default_ctx in + Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client -> + Conduit_lwt_unix.connect ~ctx client >>= fun (_flow, ic, oc) -> + Lwt.finalize + (fun () -> + begin match init with + | None -> return_unit + | Some s -> write oc s + end >>= fun () -> + fn (ic, oc)) + (fun () -> Lwt_io.close ic) + + let http_call ?headers 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 + (meth :> Cohttp.Code.meth) uri + in + let http_oc = + match meth with + | `GET -> oc + | `POST -> + let writer = + Cohttp_lwt_unix.Request.make_body_writer ~flush:true req oc + in + Lwt_io.make ~mode:Lwt_io.output ~close:(fun () -> Lwt_io.close oc) + (fun bytes off len -> + let chunk = Bytes.create len in + Lwt_bytes.blit_to_bytes bytes off chunk 0 len; + Cohttp_lwt_unix.Request.write_body writer chunk >>= fun () -> + return len) + in + let flush_http_oc () = + Log.debug "Closing output connection"; + Cohttp_lwt_unix.Request.write_footer req oc in - let cmd = match init with - | None -> [| "ssh"; user ^ host; |] - | Some x -> [| "ssh"; user ^ host; x |] + let http_ic = + let reader = ref None in + let old_chunk = ref None in + let read reader bytes off len = + let write chunk = + 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 + old_chunk := Some tl; + blit len + in + match !old_chunk with + | Some c -> write 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 + in + Lwt_io.make ~mode:Lwt_io.input ~close:(fun () -> Lwt_io.close ic) + (fun bytes off len -> + match !reader with + | None -> + begin + 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 + | `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 + end + | Some reader -> read reader bytes off len) in - Log.info "Executing '%s'" (String.concat " " (Array.to_list cmd)); - let env = Unix.environment () in - let p = Lwt_process.open_process_full ~env ("ssh", cmd) in - Lwt.finalize - (fun () -> fn (p#stdout, p#stdin)) - (fun () -> let _ = p#close in return_unit) - | `Ok (`Git | `Smart_HTTP) -> - Log.debug "Connecting to %s" (Uri.to_string uri); - let resolver = Resolver_lwt_unix.system in - Resolver_lwt.resolve_uri ~uri resolver >>= fun endp -> - let ctx = Conduit_lwt_unix.default_ctx in - Conduit_lwt_unix.endp_to_client ~ctx endp >>= fun client -> - Conduit_lwt_unix.connect ~ctx client >>= fun (_flow, ic, oc) -> - Lwt.finalize - (fun () -> - begin match init with - | None -> return_unit - | Some s -> write oc s - end >>= fun () -> - fn (ic, oc)) - (fun () -> Lwt_io.close ic) + Cohttp_lwt_unix.Request.write_header req oc >>= fun () -> + fn (http_ic, http_oc) + in + with_conduit uri callback + + let with_http ?init uri fn = + Log.debug "HTTP connecting to %s" (Uri.to_string uri); + let headers = match init with + | None -> Cohttp.Header.of_list [] + | Some s -> + let l = Marshal.from_string s 0 in + Cohttp.Header.of_list l + in + Log.debug "HTTP headers: %s" + (Sexplib.Sexp.to_string (Cohttp.Header.sexp_of_t headers)); + let meth = + let path = Uri.path uri in + let info = Filename.basename (Filename.dirname path) in + let refs = Filename.basename path in + match info, refs with + | "info", "refs" -> `GET + | _ -> `POST + in + http_call ~headers meth uri fn + + let with_connection uri ?init fn = + match Sync.protocol uri with + | `Ok `SSH -> with_ssh_process ?init uri fn + | `Ok `Git -> with_conduit ?init uri fn + | `Ok `Smart_HTTP -> with_http ?init uri fn | `Not_supported x -> fail (Failure ("Scheme " ^ x ^ " not supported yet")) | `Unknown -> From 7c8235e6279336524a8e1ffdab5209824e65b763 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 10 Jan 2015 02:46:48 +0000 Subject: [PATCH 8/9] Update CHANGES --- CHANGES.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGES.md b/CHANGES.md index 73a19545a..baf632f47 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,4 +1,5 @@ ## 1.4.4 +* Support the smart HTTP Git protocol (#26) * Best-effort creation of files when expanding the index into the filesystem: Skip the invalid filenames and continue. Users are expected to sanitize their filenames if they want to use a non-bare repository (#11) From 02afaabd313b334e3acc2375dd85ade34ad872d6 Mon Sep 17 00:00:00 2001 From: Thomas Gazagnaire Date: Sat, 10 Jan 2015 11:51:43 +0000 Subject: [PATCH 9/9] Tweak dependencies in opam --- .travis.yml | 4 ++-- opam | 20 +++++++++++++------- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/.travis.yml b/.travis.yml index d3ae4dffa..ac04eb0cd 100644 --- a/.travis.yml +++ b/.travis.yml @@ -2,6 +2,6 @@ language: c install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-opam.sh script: bash -ex .travis-opam.sh env: - - OCAML_VERSION=4.01 + - OCAML_VERSION=4.01 DEPOTS=cohttp - OCAML_VERSION=latest - - OCAML_VERSION=latest DEPOPTS=mirage-types-lwt TEST=false + - OCAML_VERSION=latest DEPOPTS="cmdliner conduit cohttp mirage-types-lwt" TESTS=false diff --git a/opam b/opam index 2c63c055f..c6c05aa0d 100644 --- a/opam +++ b/opam @@ -9,8 +9,9 @@ dev-repo: "https://github.com/mirage/ocaml-git.git" build: [ ["./configure" "--prefix" prefix - "--%{mirage-types+io-page+ipaddr+mirage-fs-unix:enable}%-mirage" - "--%{alcotest:enable}%-tests" + "--%{mirage-types-lwt:enable}%-mirage" + "--%{mirage-fs-unix+alcotest:enable}%-tests" + "--%{cmdliner+conduit+cohttp+base-unix:enable}%-unix" ] [make] ] @@ -20,20 +21,25 @@ remove: [ ["rm" "-f" "%{bin}%/ogit"] ] depends: [ - "dolog" {>= "1.0"} "mstruct" {>= "1.3.1"} + "dolog" {>= "1.0"} + "ocamlgraph" "camlzip" {>= "1.05"} "nocrypto" {>= "0.2.0"} "uri" {>= "1.3.12"} - "cmdliner" - "ocamlgraph" "lwt" {>= "2.4.5"} "hex" - "conduit" {>= "0.6.0"} "alcotest" {test} "mirage-fs-unix" {test} + "mirage-types-lwt" {test} + "cohttp" {test} + "conduit" {test} ] depopts: [ - "mirage-types-lwt" + "cmdliner" +] +conflicts: [ + "cohttp" {<= "0.15.0"} + "conduit" {< "0.6.0"} ] available: [ocaml-version >= "4.01.0"]