package git-net
A Mirage_kv implementation using git
Install
Dune Dependency
Authors
Maintainers
Sources
git-kv-0.2.0.tbz
sha256=40de3010d82dd8e9229e7df09c0a649e81efd47e991ef6eb31ee0c713dfe400d
sha512=fe70e3d1ad0f2a07dfd594ea87b4a4fcc1fe5633ced537206e61d566a2f97061dd0b348b1e93b8de1196af5878f307b7a3f595b1b51b25da89ee918328b977d9
doc/src/git-net.unix/git_net_unix.ml.html
Source file git_net_unix.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
open Lwt.Infix let ( >>? ) = Lwt_result.bind let open_error_msg = function Ok _ as v -> v | Error (`Msg _) as v -> v module Happy_eyeballs = struct type t = Happy_eyeballs_lwt.t type flow = Lwt_unix.file_descr let happy_eyeballs = Mimic.make ~name:"happy-eyeballs-lwt" let resolve t ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries addr ports = Happy_eyeballs_lwt.connect ?aaaa_timeout ?connect_delay ?connect_timeout ?resolve_timeout ?resolve_retries t addr ports >|= open_error_msg end module TCP = struct type flow = Lwt_unix.file_descr type error = [ `Refused | `Timeout | `Error of Unix.error * string * string ] type write_error = [ `Refused | `Timeout | `Closed | `Error of Unix.error * string * string ] let pp_error ppf = function | `Error (err, f, v) -> Fmt.pf ppf "%s(%s) : %s" f v (Unix.error_message err) | `Refused -> Fmt.pf ppf "Connection refused" | `Timeout -> Fmt.pf ppf "Connection timeout" let pp_write_error ppf = function | #error as err -> pp_error ppf err | `Closed -> Fmt.pf ppf "Connection closed by peer" let read fd = let tmp = Bytes.create 0x1000 in let process () = Lwt_unix.read fd tmp 0 (Bytes.length tmp) >>= function | 0 -> Lwt.return_ok `Eof | len -> Lwt.return_ok (`Data (Cstruct.of_bytes ~off:0 ~len tmp)) in Lwt.catch process @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> Lwt.fail exn let write fd ({Cstruct.len; _} as cs) = let rec process buf off max = Lwt_unix.write fd buf off max >>= fun len -> if max - len = 0 then Lwt.return_ok () else process buf (off + len) (max - len) in let buf = Cstruct.to_bytes cs in Lwt.catch (fun () -> process buf 0 len) @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> Lwt.fail exn let rec writev fd = function | [] -> Lwt.return_ok () | x :: r -> write fd x >>? fun () -> writev fd r let close fd = Lwt_unix.close fd let shutdown fd mode = let m = match mode with | `read -> Lwt_unix.SHUTDOWN_RECEIVE | `write -> Lwt_unix.SHUTDOWN_SEND | `read_write -> Lwt_unix.SHUTDOWN_ALL in Lwt_unix.shutdown fd m; Lwt.return_unit type endpoint = Lwt_unix.sockaddr let connect sockaddr = let process () = let domain = Unix.domain_of_sockaddr sockaddr in let socket = Lwt_unix.socket domain Unix.SOCK_STREAM 0 in Lwt_unix.connect socket sockaddr >>= fun () -> Lwt.return_ok socket in Lwt.catch process @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> Lwt.fail exn (* fake *) type listener = { process: flow -> unit Lwt.t; keepalive: Tcpip.Tcp.Keepalive.t option; } type t = | type ipaddr = Ipaddr.t let disconnect _ = assert false let dst _ = assert false let src _ = assert false let write_nodelay _ _ = assert false let writev_nodelay _ _ = assert false let create_connection ?keepalive:_ _ _ = assert false let input _ ~src:_ ~dst:_ _ = assert false let listen _ = assert false let unlisten _ = assert false end module FIFO = struct open Lwt.Infix let ( >>? ) = Lwt_result.bind type flow = Lwt_unix.file_descr * Lwt_unix.file_descr type endpoint = Fpath.t type error = [ `Error of Unix.error * string * string ] type write_error = [ `Closed | `Error of Unix.error * string * string ] let pp_error ppf (`Error (err, f, v)) = Fmt.pf ppf "%s(%s) : %s" f v (Unix.error_message err) let pp_write_error ppf = function | #error as err -> pp_error ppf err | `Closed -> Fmt.pf ppf "Closed by peer" let read (ic, _) = let tmp = Bytes.create 0x1000 in let process () = Lwt_unix.read ic tmp 0 (Bytes.length tmp) >>= function | 0 -> Lwt.return_ok `Eof | len -> Lwt.return_ok (`Data (Cstruct.of_bytes ~off:0 ~len tmp)) in Lwt.catch process @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> raise exn let write (_, oc) ({Cstruct.len; _} as cs) = let rec process buf off max = Lwt_unix.write oc buf off max >>= fun len -> if max - len = 0 then Lwt.return_ok () else process buf (off + len) (max - len) in let buf = Cstruct.to_bytes cs in Lwt.catch (fun () -> process buf 0 len) @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> raise exn let rec writev fd = function | [] -> Lwt.return_ok () | x :: r -> write fd x >>? fun () -> writev fd r let close (ic, oc) = Lwt_unix.close ic >>= fun () -> Lwt_unix.close oc let shutdown (ic, oc) = function | `read -> Lwt_unix.close ic | `write -> Lwt_unix.close oc | `read_write -> close (ic, oc) let connect fpath = let process () = Lwt_unix.openfile (Fpath.to_string fpath ^ "-ic") Unix.[O_RDONLY] 0o644 >>= fun ic -> Lwt_unix.openfile (Fpath.to_string fpath ^ "-oc") Unix.[O_WRONLY] 0o644 >>= fun oc -> Lwt.return_ok (ic, oc) in Lwt.catch process @@ function | Unix.Unix_error (e, f, v) -> Lwt.return_error (`Error (e, f, v)) | exn -> raise exn end let fifo_endpoint, _ = Mimic.register ~name:"fifo" (module FIFO) module A = Git_net.TCP.Make (TCP) (Happy_eyeballs) module B = Git_net.SSH.Make (TCP) (Happy_eyeballs) module C = Git_net.HTTP.Make (TCP) (Happy_eyeballs) let ctx happy_eyeballs = let ctx = Mimic.add Happy_eyeballs.happy_eyeballs happy_eyeballs Mimic.empty in A.connect ctx >>= fun ctx -> B.connect ctx >>= fun ctx -> C.connect ctx >>= fun ctx -> let k1 git_transmission git_scheme git_hostname = match git_transmission, git_scheme, Fpath.of_string git_hostname with | `Exec, `Scheme "fifo", Ok fpath -> Lwt.return_some fpath | _ -> Lwt.return_none in let k2 git_scheme = match git_scheme with | `Scheme "fifo" -> Lwt.return_some `Exec | _ -> Lwt.return_none in let ctx = Mimic.fold fifo_endpoint Mimic.Fun. [ req Git_store.Endpoint.git_transmission; req Git_store.Endpoint.git_scheme; req Git_store.Endpoint.git_hostname; ] ~k:k1 ctx in let ctx = Mimic.fold Git_store.Endpoint.git_transmission Mimic.Fun.[req Git_store.Endpoint.git_scheme] ~k:k2 ctx in C.with_optional_tls_config_and_headers ctx
sectionYPositions = computeSectionYPositions($el), 10)"
x-init="setTimeout(() => sectionYPositions = computeSectionYPositions($el), 10)"
>