232 lines
7.2 KiB
OCaml
232 lines
7.2 KiB
OCaml
let read_file path =
|
|
let ic = open_in path in
|
|
let n = in_channel_length ic in
|
|
let s = really_input_string ic n in
|
|
close_in ic;
|
|
s
|
|
|
|
let contains_sub haystack needle =
|
|
let hl = String.length haystack and nl = String.length needle in
|
|
if nl > hl then false
|
|
else
|
|
let rec check i =
|
|
if i + nl > hl then false
|
|
else if String.sub haystack i nl = needle then true
|
|
else check (i + 1)
|
|
in
|
|
check 0
|
|
|
|
let decode_chunked body =
|
|
let len = String.length body in
|
|
let buf = Buffer.create (len / 2) in
|
|
let i = ref 0 in
|
|
(try
|
|
while !i < len do
|
|
let line_end =
|
|
let rec find j =
|
|
if j >= len then raise Exit else if body.[j] = '\r' then j
|
|
else find (j + 1)
|
|
in
|
|
find !i
|
|
in
|
|
let size_str = String.sub body !i (line_end - !i) in
|
|
let size_str =
|
|
match String.index_opt size_str ';' with
|
|
| Some idx -> String.sub size_str 0 idx
|
|
| None -> size_str
|
|
in
|
|
let size = int_of_string ("0x" ^ String.trim size_str) in
|
|
if size = 0 then raise Exit;
|
|
i := line_end + 2;
|
|
if !i + size <= len then
|
|
Buffer.add_string buf (String.sub body !i size);
|
|
i := !i + size + 2
|
|
done
|
|
with Exit -> ());
|
|
Buffer.contents buf
|
|
|
|
let b64_encode src =
|
|
let tbl = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" in
|
|
let len = String.length src in
|
|
let buf = Buffer.create (len * 4 / 3 + 4) in
|
|
let i = ref 0 in
|
|
while !i + 2 < len do
|
|
let a = Char.code src.[!i] and b = Char.code src.[!i+1] and c = Char.code src.[!i+2] in
|
|
Buffer.add_char buf tbl.[(a lsr 2) land 0x3f];
|
|
Buffer.add_char buf tbl.[((a lsl 4) lor (b lsr 4)) land 0x3f];
|
|
Buffer.add_char buf tbl.[((b lsl 2) lor (c lsr 6)) land 0x3f];
|
|
Buffer.add_char buf tbl.[c land 0x3f];
|
|
i := !i + 3
|
|
done;
|
|
(match len - !i with
|
|
| 2 ->
|
|
let a = Char.code src.[!i] and b = Char.code src.[!i+1] in
|
|
Buffer.add_char buf tbl.[(a lsr 2) land 0x3f];
|
|
Buffer.add_char buf tbl.[((a lsl 4) lor (b lsr 4)) land 0x3f];
|
|
Buffer.add_char buf tbl.[(b lsl 2) land 0x3f];
|
|
Buffer.add_char buf '='
|
|
| 1 ->
|
|
let a = Char.code src.[!i] in
|
|
Buffer.add_char buf tbl.[(a lsr 2) land 0x3f];
|
|
Buffer.add_char buf tbl.[(a lsl 4) land 0x3f];
|
|
Buffer.add_string buf "=="
|
|
| _ -> ());
|
|
Buffer.contents buf
|
|
|
|
let ssl_inited = ref false
|
|
|
|
let https_request ~meth ~host ~path ?(headers=[]) ?(body="") () =
|
|
if not !ssl_inited then (
|
|
Ssl.init ();
|
|
ssl_inited := true);
|
|
let he = Unix.gethostbyname host in
|
|
let addr = he.h_addr_list.(0) in
|
|
let sockaddr = Unix.ADDR_INET (addr, 443) in
|
|
let ctx = Ssl.create_context Ssl.TLSv1_2 Ssl.Client_context in
|
|
let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
|
|
Unix.connect sock sockaddr;
|
|
let ssl = Ssl.embed_socket sock ctx in
|
|
Ssl.set_client_SNI_hostname ssl host;
|
|
Ssl.connect ssl;
|
|
let extra_headers =
|
|
List.fold_left (fun acc (k, v) -> acc ^ k ^ ": " ^ v ^ "\r\n") "" headers
|
|
in
|
|
let content_len = if body <> "" then
|
|
Printf.sprintf "Content-Length: %d\r\n" (String.length body)
|
|
else "" in
|
|
let req =
|
|
Printf.sprintf "%s %s HTTP/1.1\r\nHost: %s\r\nUser-Agent: meat/1.0\r\nConnection: close\r\n%s%s\r\n%s"
|
|
meth path host extra_headers content_len body
|
|
in
|
|
ignore (Ssl.write ssl (Bytes.of_string req) 0 (String.length req));
|
|
let buf = Buffer.create 8192 in
|
|
let chunk = Bytes.create 4096 in
|
|
(try
|
|
while true do
|
|
let n = Ssl.read ssl chunk 0 4096 in
|
|
if n = 0 then raise Exit;
|
|
Buffer.add_subbytes buf chunk 0 n
|
|
done
|
|
with _ -> ());
|
|
(try Ssl.shutdown_connection ssl with _ -> ());
|
|
Unix.close sock;
|
|
let response = Buffer.contents buf in
|
|
let rlen = String.length response in
|
|
let header_end =
|
|
let rec find pos =
|
|
if pos + 3 >= rlen then rlen
|
|
else if
|
|
response.[pos] = '\r'
|
|
&& response.[pos + 1] = '\n'
|
|
&& response.[pos + 2] = '\r'
|
|
&& response.[pos + 3] = '\n'
|
|
then pos
|
|
else find (pos + 1)
|
|
in
|
|
find 0
|
|
in
|
|
let resp_headers = String.sub response 0 header_end in
|
|
let body_start = min (header_end + 4) rlen in
|
|
let resp_body = String.sub response body_start (rlen - body_start) in
|
|
if
|
|
contains_sub
|
|
(String.lowercase_ascii resp_headers)
|
|
"transfer-encoding: chunked"
|
|
then decode_chunked resp_body
|
|
else resp_body
|
|
|
|
let https_get ~host ~path =
|
|
https_request ~meth:"GET" ~host ~path
|
|
~headers:[("User-Agent", "git/2.0")] ()
|
|
|
|
let https_post ~host ~path ~body =
|
|
https_request ~meth:"POST" ~host ~path
|
|
~headers:[
|
|
("Content-Type", "application/json");
|
|
("Accept", "application/json");
|
|
("Authorization", "Basic " ^ b64_encode "aWVSALXpZv:X8gPHnzL52wFEekuxsfQ9cSh");
|
|
] ~body ()
|
|
|
|
let parse_pktline body =
|
|
let len = String.length body in
|
|
let i = ref 0 in
|
|
let refs = ref [] in
|
|
let hex_val c =
|
|
match c with
|
|
| '0' .. '9' -> Char.code c - Char.code '0'
|
|
| 'a' .. 'f' -> Char.code c - Char.code 'a' + 10
|
|
| 'A' .. 'F' -> Char.code c - Char.code 'A' + 10
|
|
| _ -> 0
|
|
in
|
|
let read_pkt_len () =
|
|
if !i + 4 > len then 0
|
|
else
|
|
let a = hex_val body.[!i]
|
|
and b = hex_val body.[!i + 1]
|
|
and c = hex_val body.[!i + 2]
|
|
and d = hex_val body.[!i + 3] in
|
|
i := !i + 4;
|
|
(a * 4096) + (b * 256) + (c * 16) + d
|
|
in
|
|
let plen = read_pkt_len () in
|
|
if plen > 4 then i := !i + (plen - 4);
|
|
ignore (read_pkt_len ());
|
|
let continue = ref true in
|
|
while !continue do
|
|
let plen = read_pkt_len () in
|
|
if plen = 0 then continue := false
|
|
else
|
|
let payload_len = plen - 4 in
|
|
if !i + payload_len <= len && payload_len >= 41 then (
|
|
let payload = String.sub body !i payload_len in
|
|
i := !i + payload_len;
|
|
let sha = String.sub payload 0 40 in
|
|
let rest = String.sub payload 41 (String.length payload - 41) in
|
|
let refname =
|
|
let s =
|
|
match String.index_opt rest '\000' with
|
|
| Some idx -> String.sub rest 0 idx
|
|
| None -> rest
|
|
in
|
|
match String.index_opt s '\n' with
|
|
| Some idx -> String.sub s 0 idx
|
|
| None -> s
|
|
in
|
|
refs := (refname, sha) :: !refs)
|
|
else i := !i + max 0 payload_len
|
|
done;
|
|
List.rev !refs
|
|
|
|
let derelativise base = List.map (fun a -> base ^ "/" ^ a)
|
|
|
|
let filter_dirs fullpath dirs =
|
|
dirs |> derelativise fullpath
|
|
|> List.filter (fun d -> (Unix.stat d).st_kind = Unix.S_DIR)
|
|
|
|
let readdir d = try Sys.readdir d with Sys_error _ -> [||]
|
|
|
|
let walk entry =
|
|
let open List in
|
|
let rec loop dir : string list =
|
|
let contents = readdir dir |> Array.to_list in
|
|
let is_flake = mem "flake.nix" contents in
|
|
if dir = entry then
|
|
let subdirs = contents |> filter_dirs dir in
|
|
flatten (map loop subdirs)
|
|
else if is_flake then
|
|
let subdirs = contents |> filter_dirs dir in
|
|
let children = flatten (map loop subdirs) in
|
|
[ dir ] @ children
|
|
else []
|
|
in
|
|
loop entry
|
|
|
|
let countdepth s =
|
|
s |> String.fold_left (fun acc el -> acc + if el = '/' then 1 else 0) 0
|
|
|
|
let compdepth a b =
|
|
let ad = countdepth a and bd = countdepth b in
|
|
let dif = ad - bd in
|
|
match dif with 0 -> 0 | _ -> dif / abs dif
|
|
|
|
let fmt_dir d = String.split_on_char '/' d |> List.rev |> List.hd |> Common.all_caps
|