Source file git_mirage_ssh.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
open Lwt.Infix

type endpoint = {
  port : int;
  hostname : string;
  authenticator : Awa.Keys.authenticator option;
  user : string;
  key : Awa.Hostkey.priv;
  path : string;
  capabilities : [ `Rd | `Wr ];
}

let git_mirage_ssh_key = Mimic.make ~name:"git-mirage-ssh-key"

let git_mirage_ssh_authenticator =
  Mimic.make ~name:"git-mirage-ssh-authenticator"

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

  val ctx : Mimic.ctx
end

module Make
    (Mclock : Mirage_clock.MCLOCK)
    (TCP : Tcpip.Tcp.S)
    (Time : Mirage_time.S)
    (Happy_eyeballs : Git_mirage_happy_eyeballs.S with type flow = TCP.flow) :
  S = struct
  module SSH = struct
    include Awa_mirage.Make (TCP) (Time) (Mclock)

    type nonrec endpoint = Happy_eyeballs.t * endpoint

    type nonrec write_error =
      [ `Write of write_error | `Connect of error | `Closed ]

    let pp_write_error ppf = function
      | `Connect err -> pp_error ppf err
      | `Write err -> pp_write_error ppf err
      | `Closed as err -> pp_write_error ppf err

    let write flow cs =
      write flow cs >>= function
      | Ok _ as v -> Lwt.return v
      | Error err -> Lwt.return_error (`Write err)

    let writev flow css =
      writev flow css >>= function
      | Ok _ as v -> Lwt.return v
      | Error err -> Lwt.return_error (`Write err)

    let connect (happy_eyeballs, edn) =
      let open Lwt.Infix in
      let channel_request =
        match edn.capabilities with
        | `Rd -> Awa.Ssh.Exec (Fmt.str "git-upload-pack '%s'" edn.path)
        | `Wr -> Awa.Ssh.Exec (Fmt.str "git-receive-pack '%s'" edn.path)
      in
      Happy_eyeballs.resolve happy_eyeballs edn.hostname [ edn.port ]
      >>= 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
          >>= function
          | Error err -> Lwt.return_error (`Connect err)
          | Ok _ as v -> Lwt.return v)
  end

  let ssh_endpoint, _ssh_protocol = Mimic.register ~name:"ssh" (module SSH)

  let connect ctx =
    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_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;
            }
          in
          Lwt.return_some edn
      | _ -> Lwt.return_none
    in
    let k2 git_scheme =
      match git_scheme with
      | `SSH -> Lwt.return_some `Exec
      | _ -> Lwt.return_none
    in
    let ctx =
      Mimic.fold ssh_endpoint
        Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs; req edn ]
        ~k:k0 ctx
    in
    let ctx =
      Mimic.fold edn
        Mimic.Fun.
          [
            req Smart_git.git_transmission;
            req Smart_git.git_scheme;
            req Smart_git.git_ssh_user;
            req Smart_git.git_hostname;
            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_authenticator;
          ]
        ~k:k1 ctx
    in
    let ctx =
      Mimic.fold Smart_git.git_transmission
        Mimic.Fun.[ req Smart_git.git_scheme ]
        ~k:k2 ctx
    in
    Lwt.return ctx

  let with_optionnal_key ?authenticator ~key 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 = 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
        Lwt.return ctx
    | Some (Ok _), None | None, None -> Lwt.return ctx

  let ctx = Mimic.empty
end