package git-mirage
- Overview
- No Docs
You can search for identifiers within the package.
in-package search v0.2.0
A package to use ocaml-git with MirageOS backend
Install
Dune Dependency
Authors
Maintainers
Sources
git-3.18.0.tbz
sha256=925795627e6daae0b4bd16aa506879df11cb201e65fefe38e81378f18d517d4b
sha512=8e407d49808ec26445b0c706f7b010b35050d274b534e265487cb82bcac1f29cd5c41365851d42f84794ddbceb57b90143768a23154117e902b45419d156c410
doc/src/git-mirage.http/git_mirage_http.ml.html
Source file git_mirage_http.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 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
open Lwt.Infix module type S = sig val connect : Mimic.ctx -> Mimic.ctx Lwt.t val with_optional_tls_config_and_headers : ?headers:(string * string) list -> ?authenticator:string -> Mimic.ctx -> Mimic.ctx Lwt.t val ctx : Mimic.ctx end let git_mirage_http_headers = Mimic.make ~name:"git-mirage-http-headers" let git_mirage_http_tls_config = Mimic.make ~name:"git-mirage-tls-config" module Make (TCP : Tcpip.Tcp.S) (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = struct module TCP = struct include TCP type endpoint = Happy_eyeballs.t * string * int type nonrec write_error = [ `Write of write_error | `Connect of string | `Closed ] let pp_write_error ppf = function | `Connect err -> Fmt.string 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, hostname, port) = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function | Error (`Msg err) -> Lwt.return_error (`Connect err) | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow end let tcp_endpoint, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP) (* XXX(dinosaure): refactor with [git_mirage_tcp]? *) module TLS = struct type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int include Tls_mirage.Make (TCP) let connect (happy_eyeballs, cfg, hostname, port) = let peer_name = Result.to_option (Result.bind (Domain_name.of_string hostname) Domain_name.host) in Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow | Error (`Msg _) -> assert false (* TODO *) end let tls_endpoint, _tls_protocol = Mimic.register ~name:"tls" (module TLS) let context tls ctx = (* HTTP *) let edn = Mimic.make ~name:"paf-http-endpoint" in let k0 happy_eyeballs (hostname, port) = Lwt.return_some (happy_eyeballs, hostname, port) in let k1 git_paf_scheme git_paf_hostname git_paf_port = match git_paf_scheme with | `HTTP -> Lwt.return_some (git_paf_hostname, git_paf_port) | _ -> Lwt.return_none in let ctx = Mimic.fold tcp_endpoint Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs; req edn ] ~k:k0 ctx in let ctx = Mimic.fold edn Mimic.Fun. [ req Git_paf.git_paf_scheme; req Git_paf.git_paf_hostname; dft Git_paf.git_paf_port 80; ] ~k:k1 ctx in (* HTTPS *) let edn = Mimic.make ~name:"paf-https-endpoint" in let k0 happy_eyeballs (hostname, port) = Lwt.return_some (happy_eyeballs, tls, hostname, port) in let k1 git_paf_scheme git_paf_hostname git_paf_port = match git_paf_scheme with | `HTTPS -> Lwt.return_some (git_paf_hostname, git_paf_port) | _ -> Lwt.return_none in let ctx = Mimic.fold tls_endpoint Mimic.Fun.[ req Happy_eyeballs.happy_eyeballs; req edn ] ~k:k0 ctx in let ctx = Mimic.fold edn Mimic.Fun. [ req Git_paf.git_paf_scheme; req Git_paf.git_paf_hostname; dft Git_paf.git_paf_port 443; ] ~k:k1 ctx in ctx module HTTP = struct type state = | Handshake | Get of { advertised_refs : string; uri : Uri.t; headers : (string * string) list; ctx : Mimic.ctx; } | Post of { mutable output : string; uri : Uri.t; headers : (string * string) list; ctx : Mimic.ctx; } | Error of [ `Git_paf of Git_paf.error ] type flow = { happy_eyeballs : Happy_eyeballs.t; mutable state : state } type error = [ `Msg of string ] type write_error = [ `Closed | `Msg of string ] let pp_error ppf (`Msg err) = Fmt.string ppf err let pp_write_error ppf = function | `Closed -> Fmt.string ppf "Connection closed by peer" | `Msg err -> Fmt.string ppf err let write t cs = match t.state with | Handshake | Get _ -> Lwt.return_error (`Msg "Handshake has not been done") | Error (`Git_paf e) -> Lwt.return_error (`Msg (Fmt.str "Handshake got an error: git-paf: %a" Git_paf.pp_error e)) | Post ({ output; _ } as v) -> let output = output ^ Cstruct.to_string cs in v.output <- output; Lwt.return_ok () let writev t css = let rec go = function | [] -> Lwt.return_ok () | x :: r -> ( write t x >>= function | Ok () -> go r | Error _ as err -> Lwt.return err) in go css let read t = match t.state with | Handshake -> Lwt.return_error (`Msg "Handshake has not been done") | Error (`Git_paf e) -> Lwt.return_error (`Msg (Fmt.str "Handshake got an error: git-paf: %a" Git_paf.pp_error e)) | Get { advertised_refs; uri; headers; ctx } -> t.state <- Post { output = ""; uri; headers; ctx }; Lwt.return_ok (`Data (Cstruct.of_string advertised_refs)) | Post { output; uri; headers; ctx } -> ( Git_paf.post ~ctx ~headers uri output >>= function | Ok (_resp, contents) -> Lwt.return_ok (`Data (Cstruct.of_string contents)) | Error err -> Lwt.return_error (`Msg (Fmt.str "%a" Git_paf.pp_error err))) let close _ = Lwt.return_unit let shutdown _ _ = Lwt.return_unit type endpoint = Happy_eyeballs.t let connect happy_eyeballs = Lwt.return_ok { happy_eyeballs; state = Handshake } end let http_endpoint, http_protocol = Mimic.register ~name:"http" (module HTTP) type http_endpoint = HTTP_endpoint let connect ctx = let module T = (val Mimic.repr http_protocol) in let edn = Mimic.make ~name:"http-endpoint" in let k0 happy_eyeballs HTTP_endpoint = Lwt.return_some happy_eyeballs in let k1 git_transmission git_scheme = match git_transmission, git_scheme with | `HTTP _, (`HTTP | `HTTPS) -> Lwt.return_some HTTP_endpoint | _ -> Lwt.return_none in let k2 happy_eyeballs git_scheme git_uri git_http_headers git_mirage_http_headers git_mirage_http_tls_config = match git_scheme with | `Git | `SSH | `Scheme _ -> Lwt.return_none | `HTTP | `HTTPS -> let headers = git_http_headers @ git_mirage_http_headers in let handshake ~uri0 ~uri1 = function | T.T flow -> ( let ctx = Mimic.add Happy_eyeballs.happy_eyeballs happy_eyeballs Mimic.empty in let ctx = context git_mirage_http_tls_config ctx in Git_paf.get ~ctx ~headers uri0 >>= function | Ok (_resp, advertised_refs) -> flow.state <- HTTP.Get { advertised_refs; uri = uri1; headers; ctx }; Lwt.return_unit | Error e -> flow.state <- Error (`Git_paf e); Lwt.return_unit) | _ -> Lwt.return_unit in let git_transmission = `HTTP (git_uri, handshake) in Lwt.return_some git_transmission in let ctx = Mimic.fold http_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 ] ~k:k1 ctx in let ctx = Mimic.fold Smart_git.git_transmission Mimic.Fun. [ req Happy_eyeballs.happy_eyeballs; req Smart_git.git_scheme; req Smart_git.git_uri; dft Smart_git.git_http_headers List.[]; dft git_mirage_http_headers List.[]; req git_mirage_http_tls_config; ] ~k:k2 ctx in Lwt.return ctx let with_optional_tls_config_and_headers ?headers ?authenticator ctx = let time () = Some (Mirage_ptime.now ()) in let authenticator = match authenticator with | None -> ( match Ca_certs_nss.authenticator () with | Ok authenticator -> authenticator | Error (`Msg err) -> print_endline ("[git-mirage-http] NSS authenticator error: " ^ err); exit 64) | Some str -> ( match X509.Authenticator.of_string str with | Ok auth -> auth time | Error (`Msg msg) -> print_endline ("[git-mirage-http] authenticator error: " ^ msg); exit 64) in match Tls.Config.client ~authenticator () with | Error (`Msg msg) -> print_endline ("[git-mirage-http] tls error: " ^ msg); exit 64 | Ok tls -> let ctx = Mimic.add git_mirage_http_tls_config tls ctx in let ctx = Option.fold ~none:ctx ~some:(fun headers -> Mimic.add git_mirage_http_headers headers ctx) headers in Lwt.return ctx let ctx = Mimic.empty end
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>