Support SSH

Author: dinosaure

src/git-unix/ogit-fetch/dune

@@ -2,7 +2,7 @@
  (name main)
  (package git-unix)
  (public_name ogit-fetch)
- (libraries tcpip.stack-socket ipaddr ipaddr.unix domain-name mimic git
+ (libraries awa-mirage mirage-flow tcpip.stack-socket ipaddr ipaddr.unix domain-name mimic git
    git-unix cohttp-lwt-unix conduit conduit-lwt mirage-clock
    mirage-clock-unix awa git-nss.git fpath rresult result lwt lwt.unix
    git-cohttp-unix cmdliner mtime mtime.clock.os fmt.cli fmt.tty logs.cli

src/git-unix/ogit-fetch/main.ml

@@ -71,10 +71,47 @@ module TCP = struct
     >>= fun t -> create_connection t (ipaddr, port)
 end
 
+module SSH = struct
+  include Awa_mirage.Make(Tcpip_stack_socket.V4V6.TCP)(Mclock)
+
+  type nonrec error =
+    [ `TCP of TCP.error
+    | `SSH of error ]
+
+  let pp_error ppf = function
+    | `TCP err -> TCP.pp_error ppf err
+    | `SSH err -> pp_error ppf err
+
+  type endpoint =
+    { authenticator : Awa.Keys.authenticator option
+    ; user : string
+    ; path : string
+    ; key : Awa.Hostkey.priv
+    ; endpoint: TCP.endpoint }
+
+  let ( >>? ) = Lwt_result.bind
+  open Lwt.Infix
+
+  let read flow = read flow >|= Rresult.R.reword_error (fun err -> `SSH err)
+
+  let connect { authenticator; user; path; key; endpoint; } =
+    let channel_request = Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" path) in
+    TCP.connect endpoint
+    >|= Rresult.R.reword_error (fun err -> `TCP err) >>? fun flow ->
+    client_of_flow ?authenticator ~user key channel_request flow
+    >|= Rresult.R.reword_error (fun err -> `SSH err)
+end
+
 let tcp_value, tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
 let domain_name = Mimic.make ~name:"domain-namme"
 let port = Mimic.make ~name:"port"
 
+let ssh_value, ssh_protocol = Mimic.register ~name:"ssh" (module SSH)
+let path = Mimic.make ~name:"path"
+let seed = Mimic.make ~name:"ssh-seed"
+let user = Mimic.make ~name:"user"
+let authenticator = Mimic.make ~name:"ssh-authenticator"
+
 let resolv ctx =
   let k domain_name port =
     match Unix.gethostbyname (Domain_name.to_string domain_name) with
@@ -84,16 +121,28 @@ let resolv ctx =
   in
   Mimic.fold tcp_value Mimic.Fun.[ req domain_name; dft port 9418 ] ~k ctx
 
+let resolv_ssh ctx =
+  let k authenticator sockaddr path user seed =
+    let key = Awa.Keys.of_seed `Rsa seed in
+    Lwt.return_some { SSH.authenticator; user; path; key; endpoint= sockaddr } in
+  Mimic.fold ssh_value Mimic.Fun.[ opt authenticator; req tcp_value; req path; req user; req seed ] ~k ctx
+
+let of_smart_git_endpoint edn ctx = match edn with
+  | { Smart_git.Endpoint.scheme= `SSH v_user; path= v_path; host; } ->
+    ctx |> Mimic.add domain_name host |> Mimic.add path v_path |> Mimic.add user v_user
+  | { Smart_git.Endpoint.path= v_path; host; _ } ->
+    ctx |> Mimic.add domain_name host |> Mimic.add path v_path
+
 let main (_ssh_seed : string)
     (references : (Git.Reference.t * Git.Reference.t) list) (directory : string)
-    ({ Smart_git.Endpoint.host; _ } as repository : Smart_git.Endpoint.t) :
+    (repository : Smart_git.Endpoint.t) :
     (unit, 'error) Lwt_result.t =
   let repo_root =
     (match directory with "" -> Sys.getcwd () | _ -> directory) |> Fpath.v
   in
   let ( >>?= ) = Lwt_result.bind in
   let ( >>!= ) v f = Lwt_result.map_err f v in
-  let ctx = resolv Mimic.empty |> Mimic.add domain_name host in
+  let ctx = Mimic.empty |> resolv |> resolv_ssh |> of_smart_git_endpoint repository in
   Store.v repo_root >>!= store_err >>?= fun store ->
   let push_stdout = print_endline in
   let push_stderr = prerr_endline in