git-mirage: allow password authentication, as supported by awa 0.2.0

.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

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"

src/git-mirage/git_mirage_ssh.ml

@@ -5,11 +5,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 ];
 }
 
+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 +20,11 @@ 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 +69,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 +82,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 +130,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 +143,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

src/git-mirage/git_mirage_ssh.mli

@@ -3,19 +3,24 @@ 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
 
 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

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 () ->

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

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

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

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 =

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
 

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 ];