From 7526e9dc3a566d9f7b81c39c27dc44cdbb5b7b36 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Wed, 22 Mar 2023 20:12:37 +0100 Subject: [PATCH 1/2] git-mirage: allow password authentication, as supported by awa 0.2.0 --- git-mirage.opam | 4 +- src/git-mirage/git_mirage_ssh.ml | 67 +++++++++++++++++++------------ src/git-mirage/git_mirage_ssh.mli | 6 ++- 3 files changed, 48 insertions(+), 29 deletions(-) diff --git a/git-mirage.opam b/git-mirage.opam index 9ad8e285b..299d18286 100644 --- a/git-mirage.opam +++ b/git-mirage.opam @@ -14,8 +14,8 @@ depends: [ "base64" {>= "3.5.0"} "git" {= version} "git-paf" {= version} - "awa" {>= "0.1.0"} - "awa-mirage" {>= "0.1.0"} + "awa" {>= "0.2.0"} + "awa-mirage" {>= "0.2.0"} "dns" {>= "6.1.3"} "dns-client" {>= "6.1.3"} "tls" diff --git a/src/git-mirage/git_mirage_ssh.ml b/src/git-mirage/git_mirage_ssh.ml index a6b3d3d02..bac63867d 100644 --- a/src/git-mirage/git_mirage_ssh.ml +++ b/src/git-mirage/git_mirage_ssh.ml @@ -5,11 +5,13 @@ type endpoint = { hostname : string; authenticator : Awa.Keys.authenticator option; user : string; - key : Awa.Hostkey.priv; + credentials : [ `Password of string | `Pubkey of Awa.Hostkey.priv ]; path : string; capabilities : [ `Rd | `Wr ]; } +let git_mirage_ssh_password = Mimic.make ~name:"git-mirage-ssh-password" + let git_mirage_ssh_key = Mimic.make ~name:"git-mirage-ssh-key" let git_mirage_ssh_authenticator = @@ -19,7 +21,7 @@ module type S = sig val connect : Mimic.ctx -> Mimic.ctx Lwt.t val with_optionnal_key : - ?authenticator:string -> key:string option -> Mimic.ctx -> Mimic.ctx Lwt.t + ?authenticator:string -> key:string option -> password:string option -> Mimic.ctx -> Mimic.ctx Lwt.t val ctx : Mimic.ctx end @@ -64,8 +66,8 @@ struct >>= function | Error (`Msg err) -> Lwt.return_error (`Connect (`Msg err)) | Ok ((_ipaddr, _port), flow) -> ( - client_of_flow ?authenticator:edn.authenticator ~user:edn.user edn.key - channel_request flow + client_of_flow ?authenticator:edn.authenticator ~user:edn.user + edn.credentials channel_request flow >>= function | Error err -> Lwt.return_error (`Connect err) | Ok _ as v -> Lwt.return v) @@ -77,24 +79,31 @@ struct let edn = Mimic.make ~name:"ssh-endpoint" in let k0 happy_eyeballs edn = Lwt.return_some (happy_eyeballs, edn) in let k1 git_transmission git_scheme git_ssh_user git_hostname git_port - git_path git_capabilities git_mirage_ssh_key + git_path git_capabilities git_mirage_ssh_key git_mirage_ssh_password git_mirage_ssh_authenticator = match git_transmission, git_scheme with | `Exec, `SSH -> (* XXX(dinosaure): be sure that we don't want to initiate a wrong transmission protocol. * be sure that [k2] is called by [mimic]. *) - let edn = - { - port = git_port; - hostname = git_hostname; - authenticator = git_mirage_ssh_authenticator; - user = git_ssh_user; - key = git_mirage_ssh_key; - path = git_path; - capabilities = git_capabilities; - } + let credentials = + match git_mirage_ssh_key, git_mirage_ssh_password with + | None, None | Some _, Some _ -> None + | Some k, None -> Some (`Pubkey k) + | None, Some p -> Some (`Password p) in - Lwt.return_some edn + Lwt.return + (Option.map + (fun credentials -> + { + port = git_port; + hostname = git_hostname; + authenticator = git_mirage_ssh_authenticator; + user = git_ssh_user; + credentials; + path = git_path; + capabilities = git_capabilities; + }) + credentials) | _ -> Lwt.return_none in let k2 git_scheme = @@ -118,7 +127,8 @@ struct dft Smart_git.git_port 22; req Smart_git.git_path; req Smart_git.git_capabilities; - req git_mirage_ssh_key; + opt git_mirage_ssh_key; + opt git_mirage_ssh_password; opt git_mirage_ssh_authenticator; ] ~k:k1 ctx @@ -130,21 +140,28 @@ struct in Lwt.return ctx - let with_optionnal_key ?authenticator ~key ctx = + let with_optionnal_key ?authenticator ~key ~password ctx = let authenticator = Option.map Awa.Keys.authenticator_of_string authenticator in let key = Option.map Awa.Keys.of_string key in - match authenticator, key with - | Some (Error err), _ | _, Some (Error (`Msg err)) -> failwith err - | Some (Ok authenticator), Some (Ok key) -> + let ctx = + match authenticator with + | Some (Error err) -> failwith err + | Some (Ok authenticator) -> + Mimic.add git_mirage_ssh_authenticator authenticator ctx + | None -> ctx + in + match key, password with + | Some (Error (`Msg err)), _ -> failwith err + | Some _, Some _ -> failwith "both key and password provided" + | Some (Ok key), None -> let ctx = Mimic.add git_mirage_ssh_key key ctx in - let ctx = Mimic.add git_mirage_ssh_authenticator authenticator ctx in Lwt.return ctx - | None, Some (Ok key) -> - let ctx = Mimic.add git_mirage_ssh_key key ctx in + | None, Some password -> + let ctx = Mimic.add git_mirage_ssh_password password ctx in Lwt.return ctx - | Some (Ok _), None | None, None -> Lwt.return ctx + | None, None -> Lwt.return ctx let ctx = Mimic.empty end diff --git a/src/git-mirage/git_mirage_ssh.mli b/src/git-mirage/git_mirage_ssh.mli index 01ec5ae75..42e90821e 100644 --- a/src/git-mirage/git_mirage_ssh.mli +++ b/src/git-mirage/git_mirage_ssh.mli @@ -3,11 +3,12 @@ type endpoint = { hostname : string; authenticator : Awa.Keys.authenticator option; user : string; - key : Awa.Hostkey.priv; + credentials : [ `Password of string | `Pubkey of Awa.Hostkey.priv ]; path : string; capabilities : [ `Rd | `Wr ]; } +val git_mirage_ssh_password : string Mimic.value val git_mirage_ssh_key : Awa.Hostkey.priv Mimic.value val git_mirage_ssh_authenticator : Awa.Keys.authenticator Mimic.value @@ -15,7 +16,8 @@ module type S = sig val connect : Mimic.ctx -> Mimic.ctx Lwt.t val with_optionnal_key : - ?authenticator:string -> key:string option -> Mimic.ctx -> Mimic.ctx Lwt.t + ?authenticator:string -> key:string option -> password:string option -> + Mimic.ctx -> Mimic.ctx Lwt.t val ctx : Mimic.ctx end From 622cbaccc5e9fa073ba46be0cf888a83d6ae4e2c Mon Sep 17 00:00:00 2001 From: Calascibetta Romain Date: Thu, 23 Mar 2023 10:21:07 +0100 Subject: [PATCH 2/2] Apply ocamlformat.0.25.1 --- .ocamlformat | 2 +- src/git-mirage/git_mirage_ssh.ml | 25 ++++++++++++++----------- src/git-mirage/git_mirage_ssh.mli | 7 +++++-- src/git-unix/git_unix.ml | 2 +- src/git/minimal.ml | 3 +-- src/not-so-smart/fetch.ml | 6 ++++-- src/not-so-smart/find_common.ml | 20 +++++++++++--------- src/not-so-smart/smart.ml | 22 +++++++++++----------- src/not-so-smart/smart_flow.ml | 6 ++++-- test/carton/test.ml | 2 +- 10 files changed, 53 insertions(+), 42 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 88415a85d..1cd82ddc8 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.22.4 +version=0.25.1 module-item-spacing=compact break-infix=fit-or-vertical parens-tuple=multi-line-only diff --git a/src/git-mirage/git_mirage_ssh.ml b/src/git-mirage/git_mirage_ssh.ml index bac63867d..082207ad6 100644 --- a/src/git-mirage/git_mirage_ssh.ml +++ b/src/git-mirage/git_mirage_ssh.ml @@ -11,7 +11,6 @@ type endpoint = { } let git_mirage_ssh_password = Mimic.make ~name:"git-mirage-ssh-password" - let git_mirage_ssh_key = Mimic.make ~name:"git-mirage-ssh-key" let git_mirage_ssh_authenticator = @@ -21,7 +20,11 @@ module type S = sig val connect : Mimic.ctx -> Mimic.ctx Lwt.t val with_optionnal_key : - ?authenticator:string -> key:string option -> password:string option -> Mimic.ctx -> Mimic.ctx Lwt.t + ?authenticator:string -> + key:string option -> + password:string option -> + Mimic.ctx -> + Mimic.ctx Lwt.t val ctx : Mimic.ctx end @@ -94,15 +97,15 @@ struct Lwt.return (Option.map (fun credentials -> - { - port = git_port; - hostname = git_hostname; - authenticator = git_mirage_ssh_authenticator; - user = git_ssh_user; - credentials; - path = git_path; - capabilities = git_capabilities; - }) + { + port = git_port; + hostname = git_hostname; + authenticator = git_mirage_ssh_authenticator; + user = git_ssh_user; + credentials; + path = git_path; + capabilities = git_capabilities; + }) credentials) | _ -> Lwt.return_none in diff --git a/src/git-mirage/git_mirage_ssh.mli b/src/git-mirage/git_mirage_ssh.mli index 42e90821e..17f8c9035 100644 --- a/src/git-mirage/git_mirage_ssh.mli +++ b/src/git-mirage/git_mirage_ssh.mli @@ -16,8 +16,11 @@ module type S = sig val connect : Mimic.ctx -> Mimic.ctx Lwt.t val with_optionnal_key : - ?authenticator:string -> key:string option -> password:string option -> - Mimic.ctx -> Mimic.ctx Lwt.t + ?authenticator:string -> + key:string option -> + password:string option -> + Mimic.ctx -> + Mimic.ctx Lwt.t val ctx : Mimic.ctx end diff --git a/src/git-unix/git_unix.ml b/src/git-unix/git_unix.ml index 9c59b200b..fa9575370 100644 --- a/src/git-unix/git_unix.ml +++ b/src/git-unix/git_unix.ml @@ -534,7 +534,7 @@ module Reference_heap = struct Bos.OS.Dir.create ~path:true base >>= fun _ -> Bos.OS.Dir.exists path >>= fun res -> (if res then Bos.OS.Dir.delete ~must_exist:false ~recurse:true path - else R.ok ()) + else R.ok ()) >>= fun () -> Bos.OS.File.tmp "git-reference-%s" >>= fun src -> Bos.OS.File.write src str >>= fun () -> diff --git a/src/git/minimal.ml b/src/git/minimal.ml index 037ca9b5b..4f0727e81 100644 --- a/src/git/minimal.ml +++ b/src/git/minimal.ml @@ -3,8 +3,7 @@ module type S = sig type hash type decode_error := [ `Msg of string ] - type error = - private + type error = private [> `Not_found of hash | `Reference_not_found of Reference.t | decode_error ] val pp_error : error Fmt.t diff --git a/src/not-so-smart/fetch.ml b/src/not-so-smart/fetch.ml index 1cba99b6f..57e8fee93 100644 --- a/src/not-so-smart/fetch.ml +++ b/src/not-so-smart/fetch.ml @@ -29,8 +29,10 @@ module Make struct open Scheduler - module Log = (val let src = Logs.Src.create "fetch" in - Logs.src_log src : Logs.LOG) + module Log = + (val let src = Logs.Src.create "fetch" in + Logs.src_log src + : Logs.LOG) let ( >>= ) x f = IO.bind x f let return x = IO.return x diff --git a/src/not-so-smart/find_common.ml b/src/not-so-smart/find_common.ml index 55ff278d6..59f7b537b 100644 --- a/src/not-so-smart/find_common.ml +++ b/src/not-so-smart/find_common.ml @@ -1,7 +1,9 @@ open Sigs -module Log = (val let src = Logs.Src.create "find-common" in - Logs.src_log src : Logs.LOG) +module Log = + (val let src = Logs.Src.create "find-common" in + Logs.src_log src + : Logs.LOG) type configuration = { stateless : bool; @@ -237,18 +239,18 @@ let find_common (type t) scheduler io flow cfg Log.debug (fun m -> m "Negotiation (got ready: %b, no-done: %b)." !got_ready no_done); (if (not !got_ready) || not no_done then - Smart_flow.run scheduler raise io flow - Smart.(send ctx negotiation_done ()) - else return ()) + Smart_flow.run scheduler raise io flow + Smart.(send ctx negotiation_done ()) + else return ()) >>= fun () -> if !retval <> 0 then ( cfg.multi_ack <- `None; incr flushes); (if (not !got_ready) || not no_done then ( - Log.debug (fun m -> m "Negotiation is done!"); - Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) - >>= fun _shallows -> return ()) - else return ()) + Log.debug (fun m -> m "Negotiation is done!"); + Smart_flow.run scheduler raise io flow Smart.(recv ctx shallows) + >>= fun _shallows -> return ()) + else return ()) >>= fun () -> let rec go () = if !flushes > 0 || cfg.multi_ack = `Some || cfg.multi_ack = `Detailed diff --git a/src/not-so-smart/smart.ml b/src/not-so-smart/smart.ml index 49aeda2ac..8b92c5589 100644 --- a/src/not-so-smart/smart.ml +++ b/src/not-so-smart/smart.ml @@ -92,17 +92,17 @@ module Value = struct in transl (let open Protocol.Decoder in - match w with - | Advertised_refs -> decode_advertised_refs decoder - | Result -> decode_result decoder - | Commands -> decode_commands decoder - | Recv_pack { side_band; push_stdout; push_stderr } -> - decode_pack ~side_band ~push_stdout ~push_stderr decoder - | Ack -> decode_negotiation decoder - | Status sideband -> decode_status ~sideband decoder - | Flush -> decode_flush decoder - | Shallows -> decode_shallows decoder - | Packet trim -> decode_packet ~trim decoder) + match w with + | Advertised_refs -> decode_advertised_refs decoder + | Result -> decode_result decoder + | Commands -> decode_commands decoder + | Recv_pack { side_band; push_stdout; push_stderr } -> + decode_pack ~side_band ~push_stdout ~push_stderr decoder + | Ack -> decode_negotiation decoder + | Status sideband -> decode_status ~sideband decoder + | Flush -> decode_flush decoder + | Shallows -> decode_shallows decoder + | Packet trim -> decode_packet ~trim decoder) end type ('a, 'err) t = ('a, 'err) State.t = diff --git a/src/not-so-smart/smart_flow.ml b/src/not-so-smart/smart_flow.ml index b5a55e5c2..9985fc0c4 100644 --- a/src/not-so-smart/smart_flow.ml +++ b/src/not-so-smart/smart_flow.ml @@ -1,7 +1,9 @@ open Sigs -module Log = (val let src = Logs.Src.create "smart_flow" in - Logs.src_log src : Logs.LOG) +module Log = + (val let src = Logs.Src.create "smart_flow" in + Logs.src_log src + : Logs.LOG) let io_buffer_size = 65536 diff --git a/test/carton/test.ml b/test/carton/test.ml index 50dd2648a..2235d0cde 100644 --- a/test/carton/test.ml +++ b/test/carton/test.ml @@ -1126,7 +1126,7 @@ let () = (* XXX(dinosaure): it seems that a bug exists in Git (not ocaml-git) on git-index-pack until 1.9.0. *) (if Git_version.compare v1_9_0 git_version <= 0 then pack_bomb_pack () - else fake_pack_bomb_pack ()); + else fake_pack_bomb_pack ()); cycle (); ] ); "lwt", [ Test_lwt.test_map_yield ];