Something went wrong. Try again.
GitHub GraphQL client whose answers are kept in a raw store
Something went wrong. Try again.
47 kB · 1431 lines
OCaml
at main
1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432let log = Logs.Src.create "github-query"
module Log = (val Logs.src_log log)
(* Query text *)
let is_name_char = function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true | _ -> false
let contains ~affix s = let n = String.length s and m = String.length affix in let rec go i = i + m <= n && (String.sub s i m = affix || go (i + 1)) in go 0
let starts_with s i prefix = let n = String.length prefix in i + n <= String.length s && String.sub s i n = prefix
(* The index just after the string or block string that starts at [i]. A string left open ends after its line. *)let string_end s i = let n = String.length s in if starts_with s i {|"""|} then let rec go j = if j >= n then n else if starts_with s j {|\"""|} then go (j + 4) else if starts_with s j {|"""|} then j + 3 else go (j + 1) in go (i + 3) else let rec go j = if j >= n then n else match s.[j] with | '\\' -> go (j + 2) | '"' -> j + 1 | '\n' -> j + 1 | _ -> go (j + 1) in go (i + 1)
let normalise s = let n = String.length s in let b = Buffer.create n in let last () = if Buffer.length b = 0 then None else Some (Buffer.nth b (Buffer.length b - 1)) in let separate next = match last () with | Some c when is_name_char c && is_name_char next -> Buffer.add_char b ' ' | Some '"' when next = '"' -> Buffer.add_char b ' ' | _ -> () in let rec go i ~space = if i < n then match s.[i] with | ' ' | '\t' | '\n' | '\r' | ',' -> go (i + 1) ~space:true | '#' -> let j = try String.index_from s i '\n' with Not_found -> n in go j ~space:true | '"' -> if space then separate '"'; let j = string_end s i in Buffer.add_string b (String.sub s i (j - i)); go j ~space:false | c -> if space then separate c; Buffer.add_char b c; go (i + 1) ~space:false in go 0 ~space:false; Buffer.contents b
let quote s = Json.Value.to_string (Json.Value.string s)
(* The rate limit selection goes first in the operation's selection set: fragments are skipped, and a mutation or subscription is left alone, since [rateLimit] is a field of [Query]. *)let rate_limit_field = "rateLimit{cost remaining resetAt}"
let with_rate_limit s = let n = String.length s in let rec go i ~braces ~parens ~first = if i >= n then None else match s.[i] with | '"' -> go (string_end s i) ~braces ~parens ~first | '(' -> go (i + 1) ~braces ~parens:(parens + 1) ~first | ')' -> go (i + 1) ~braces ~parens:(parens - 1) ~first | '{' when braces = 0 && parens = 0 -> ( match first with | Some ("fragment" | "mutation" | "subscription") -> go (i + 1) ~braces:1 ~parens ~first | _ -> Some (String.sub s 0 (i + 1) ^ rate_limit_field ^ String.sub s (i + 1) (n - i - 1))) | '{' -> go (i + 1) ~braces:(braces + 1) ~parens ~first | '}' when braces = 1 && parens = 0 -> go (i + 1) ~braces:0 ~parens ~first:None | '}' -> go (i + 1) ~braces:(braces - 1) ~parens ~first | c when braces = 0 && parens = 0 && first = None && is_name_char c -> let j = ref i in while !j < n && is_name_char s.[!j] do incr j done; go !j ~braces ~parens ~first:(Some (String.sub s i (!j - i))) | _ -> go (i + 1) ~braces ~parens ~first in if contains ~affix:"rateLimit" s then None else go 0 ~braces:0 ~parens:0 ~first:None
module Template = struct type 'a t = { text : string; vars : 'a -> (string * Json.t) list }
let v text vars = { text = normalise text; vars } let const text = v text (fun () -> []) let text t = t.text
let variables t x = Json.Value.object' (List.map (fun (k, v) -> Json.Value.member (Json.Value.name k) v) (t.vars x))
let normalise = normalise let quote = quoteend
(* JSON helpers *)
let members = function Json.Object (ms, _) -> Some ms | _ -> None
let member name j = Option.bind (members j) (fun ms -> Option.map snd (Json.Value.member_key name ms))
let string_member name j = match member name j with Some (Json.String (s, _)) -> Some s | _ -> None
let int_member name j = match member name j with | Some (Json.Number (n, _)) -> Json.Number.to_int n | _ -> None
let without name j = match j with | Json.Object (ms, meta) -> Json.Object (List.filter (fun ((n, _), _) -> n <> name) ms, meta) | j -> j
let with_member name v j = match j with | Json.Object (ms, meta) -> Json.Object ( List.map (fun ((n, m), x) -> ((n, m), if n = name then v else x)) ms, meta ) | j -> j
let obj members = Json.Value.object' (List.map (fun (k, v) -> Json.Value.member (Json.Value.name k) v) members)
(* Transports *)
type response = { status : int; headers : (string * string) list; body : string;}
let response ?(headers = []) ~status body = { status; headers; body }
let header name r = let name = String.lowercase_ascii name in List.find_map (fun (k, v) -> if String.lowercase_ascii k = name then Some (String.trim v) else None) r.headers
let err_io e = Error (`Msg (Fmt.str "%a" Eio.Exn.pp e))
type transport = headers:(string * string) list -> string -> (response, [ `Timeout | `Msg of string ]) result
let requests ?(endpoint = "https://api.github.com/graphql") session ~headers body = let headers = Requests_eio.Headers.of_list headers in let body = Requests_eio.Body.of_string Requests_eio.Mime.json body in match Requests_eio.post session ~headers ~body endpoint with | r -> Ok { status = Requests_eio.Response.status_code r; headers = Requests_eio.Headers.to_list (Requests_eio.Response.headers r); body = Requests_eio.Response.text r; } | exception Eio.Io (Requests_eio.Error.E e, _) when Requests_eio.Error.is_timeout e -> Error `Timeout | exception (Eio.Io _ as e) -> err_io e
(* Errors *)
type error = | Http of int * string | Graphql of Json.t | Not_found | Incomplete of string | Too_large | Transport of string | Invalid of string
let pp_error ppf = function | Http (status, body) -> let body = if String.length body > 200 then String.sub body 0 200 ^ "..." else body in Fmt.pf ppf "HTTP %d: %s" status body | Graphql errors -> Fmt.pf ppf "GraphQL errors: %a" Json.Value.pp errors | Not_found -> Fmt.string ppf "not found" | Incomplete m -> Fmt.pf ppf "incomplete answer: %s" m | Too_large -> Fmt.string ppf "query too large for GitHub's resource limits" | Transport m -> Fmt.pf ppf "transport: %s" m | Invalid m -> Fmt.pf ppf "invalid input: %s" m
let err_transport fmt = Fmt.kstr (fun s -> Error (Transport s)) fmt
exception Failed of error
(* Clients *)
type t = { store : Cas_store.t; transport : transport; token : string; principal : string; retries : int; reserve : int; id : string; (** The token's digest, which names its budgets. *) endpoint : string; (** The REST API's root; [""] for GraphQL. *) now : unit -> float; sleep : float -> unit;}
let client ~clock ~store ~principal ~retries ~reserve ~token ~endpoint transport = { store; transport; token; principal; retries; reserve; id = String.sub (Cas.Hash.to_hex (Cas.Hash.sha256 token)) 0 16; endpoint; now = (fun () -> Eio.Time.now clock); sleep = Eio.Time.sleep clock; }
let v ~clock ~store ?(principal = "public") ?(retries = 5) ?(reserve = 50) ~token transport = client ~clock ~store ~principal ~retries ~reserve ~token ~endpoint:"" transport
let key t q x = Cas_store.Key.of_spec (obj [ ("src", Json.Value.string "github.graphql"); ("query", Json.Value.string (Template.text q)); ("variables", Template.variables q x); ("principal", Json.Value.string t.principal); ])
(* Budgets: a token's remaining points of one of GitHub's rate-limit resources ([graphql], [core], [search], ...) and their reset, as a ref of the store's heap so that every process opening it reads the same one. *)
let graphql = "graphql"let budget_ref t resource = Fmt.str "github-query/budget/%s/%s" resource t.id
let is_resource_char = function | 'a' .. 'z' | '0' .. '9' | '_' | '-' -> true | _ -> false
(* The resource a response says it was counted against, else [default]. *)let resource_of ~default r = match header "x-ratelimit-resource" r with | Some s when s <> "" && String.for_all is_resource_char s -> s | _ -> default
let time_of_rfc3339 s = match Ptime.of_rfc3339 s with Ok (p, _, _) -> Some p | Error _ -> None
let heap t = Cas_eio.Fs.heap (Cas_store.objects t.store)
let budget_of t resource = Option.bind (Cas.Heap.ref (heap t) (budget_ref t resource)) (fun h -> Option.bind (Cas.Heap.find (heap t) h) (fun s -> match Json.Value.of_string s with | Error _ -> None | Ok j -> ( match (int_member "remaining" j, string_member "reset_at" j) with | Some remaining, Some reset -> Option.map (fun r -> (remaining, r)) (time_of_rfc3339 reset) | _ -> None)))
let budget t = budget_of t graphql
let set_budget t resource ~remaining ~reset_at = let s = Json.Value.to_canonical (obj [ ("remaining", Json.Value.int remaining); ( "reset_at", Json.Value.string (Ptime.to_rfc3339 ~tz_offset_s:0 reset_at) ); ]) in Cas.Heap.set_ref (heap t) (budget_ref t resource) (Cas_eio.Fs.add (Cas_store.objects t.store) s)
let ptime_of_float f = Option.value (Ptime.of_float_s f) ~default:Ptime.epoch
let pause t resource ~until = set_budget t resource ~remaining:0 ~reset_at:(ptime_of_float until); let d = until -. t.now () in if d > 0. then t.sleep d
let wait_for_budget t resource = match budget_of t resource with | Some (remaining, reset_at) when remaining <= t.reserve -> let d = Ptime.to_float_s reset_at -. t.now () in if d > 0. then ( Log.info (fun m -> m "%s budget at %d points, waiting %.0fs for its reset" resource remaining d); t.sleep d) | _ -> ()
(* Sending *)
let resource_limits = "Resource limits for this query exceeded"
let errors_of body = match member "errors" body with | Some (Json.Array (es, _) as errors) when es <> [] -> Some (errors, es) | _ -> None
let has_error p es = List.exists p es
(* The first step of an error's path, the alias it is about, and whether the path has no other step. *)let path_head e = match member "path" e with | Some (Json.Array (Json.String (s, _) :: rest, _)) -> Some (s, rest = []) | _ -> None
(* The errors of [body] whose path starts at [name]. *)let errors_at body name = match errors_of body with | None -> [] | Some (_, es) -> List.filter (fun e -> match path_head e with Some (s, _) -> s = name | None -> false) es
let message_has affix e = match string_member "message" e with | Some m -> contains ~affix m | None -> false
let type_is ty e = string_member "type" e = Some ty
let has_data body = match member "data" body with | None | Some (Json.Null _) -> false | Some _ -> true
let float_header name r = Option.bind (header name r) (fun s -> float_of_string_opt s)
(* When a refused response says the token may ask again, if it says. *)let retry_at t r = match float_header "retry-after" r with | Some s -> Some (t.now () +. s) | None -> ( match (header "x-ratelimit-remaining" r, float_header "x-ratelimit-reset" r) with | Some "0", Some reset -> Some reset | _ -> if r.status = 429 then Some (t.now () +. 60.) else None)
let backoff n = Float.min 60. (2. ** float_of_int n)
let header_rate_limit r = match ( Option.bind (header "x-ratelimit-remaining" r) int_of_string_opt, float_header "x-ratelimit-reset" r ) with | Some remaining, Some reset -> Some (remaining, ptime_of_float reset) | _ -> None
let rate_limit added body r = let from_body = if not added then None else Option.bind (member "data" body) (fun data -> Option.bind (member "rateLimit" data) (fun rl -> match (int_member "remaining" rl, string_member "resetAt" rl) with | Some remaining, Some reset -> Option.map (fun p -> (remaining, p)) (time_of_rfc3339 reset) | _ -> None)) in match from_body with Some _ as b -> b | None -> header_rate_limit r
let strip added body = if not added then body else match member "data" body with | Some data -> with_member "data" (without "rateLimit" data) body | None -> body
let request_body text variables = Json.Value.to_string (obj [ ("query", Json.Value.string text); ("variables", variables) ])
(* What one response asks the client to do next. *)type 'a next = | Answer of 'a | Fail of error | Pause of string * float * error (** Pause the budget of this resource until then. *) | Retry of float option * error (** Retry after this many seconds, else after the backoff. *)
let rate_limited t ~resource r err = match retry_at t r with | Some until -> Pause (resource, until, err) | None -> Fail err
let next_of_answer t ~added r j = Option.iter (fun (remaining, reset_at) -> set_budget t graphql ~remaining ~reset_at) (rate_limit added j r); (* Selections refused for the resource limits beside others answered are left to {!batch}, which asks them again. *) let too_large e = message_has resource_limits e && ((not (has_data j)) || path_head e = None) in match errors_of j with | Some (_, es) when has_error too_large es -> Fail Too_large | Some (errors, es) when has_error (type_is "RATE_LIMITED") es -> rate_limited t ~resource:graphql r (Graphql errors) | Some (errors, _) when not (has_data j) -> Fail (Graphql errors) | _ -> Answer (strip added j)
let next t ~added = function | Error `Timeout -> Retry (None, Too_large) | Error (`Msg m) -> Retry (None, Transport m) | Ok r when r.status = 403 || r.status = 429 -> rate_limited t ~resource:graphql r (Http (r.status, r.body)) | Ok r when r.status >= 500 -> let err = if r.status = 502 || r.status = 504 then Too_large else Http (r.status, r.body) in Retry (float_header "retry-after" r, err) | Ok r when r.status <> 200 -> Fail (Http (r.status, r.body)) | Ok r -> ( match Json.Value.of_string r.body with | Error _ -> Fail (Http (r.status, r.body)) | Ok j -> next_of_answer t ~added r j)
(* Sends [payload] until [next] reads an answer or an error from the response, waiting on the budget of [resource] before each try. *)let send t ~resource ~headers ~next payload = let rec attempt n = wait_for_budget t resource; match next (t.transport ~headers payload) with | Answer a -> Ok a | Fail e -> Error e | (Pause (_, _, e) | Retry (_, e)) when n >= t.retries -> Error e | Pause (resource, until, e) -> Log.info (fun m -> m "%s paused until %.0f: %a" resource until pp_error e); pause t resource ~until; attempt (n + 1) | Retry (after, e) -> let d = Option.value after ~default:(backoff n) in Log.info (fun m -> m "retrying in %.0fs: %a" d pp_error e); t.sleep d; attempt (n + 1) in attempt 0
let send_query t q x = let text, added = match with_rate_limit (Template.text q) with | Some text -> (text, true) | None -> (Template.text q, false) in let body = request_body text (Template.variables q x) in let headers = [ ("Authorization", "bearer " ^ t.token); ("Accept", "application/json") ] in send t ~resource:graphql ~headers ~next:(next t ~added) body
let canonical j = match Json.Value.to_canonical j with | s -> s | exception Json.Error _ -> Json.Value.to_string j
let mark_of = function Cas_store.Policy.Probe m -> Some m | _ -> None
exception Unstored of Json.t
(* An answer is kept when it holds no error, or only NOT_FOUND ones: any other may not hold when asked again. *)let storable j = match errors_of j with | None -> true | Some (_, es) -> List.for_all (type_is "NOT_FOUND") es
let query t ~policy q x = let validators = Cas_store.Validators.v ?mark:(mark_of policy) () in let fetch _ = match send_query t q x with | Ok j when storable j -> Cas_store.Body (canonical j, validators) | Ok j -> raise (Unstored j) | Error e -> raise (Failed e) in match Cas_store.resolve t.store ~policy ~fetch (key t q x) with | Ok (_, s) -> ( match Json.Value.of_string s with | Ok j -> Ok j | Error e -> Error (Http (200, Fmt.str "stored answer: %a" Json.Error.pp e))) | Error (`Gone status) -> Error (Http (status, "")) | exception Failed e -> Error e | exception Unstored j -> Ok j
(* A mutation is sent again only after a rate limit, which GitHub answers before applying it; after a 5xx, a timeout or a transport failure it may have been applied. *)let mutate t q x = let next r = match next t ~added:false r with Retry (_, e) -> Fail e | n -> n in let body = request_body (Template.text q) (Template.variables q x) in let headers = [ ("Authorization", "bearer " ^ t.token); ("Accept", "application/json") ] in send t ~resource:graphql ~headers ~next body
let alias i = "a" ^ string_of_int i
let rec take n = function | x :: xs when n > 0 -> let l, r = take (n - 1) xs in (x :: l, r) | xs -> ([], xs)
let rec chunks n = function | [] -> [] | xs -> let c, rest = take n xs in c :: chunks n rest
let is_null = function None | Some (Json.Null _) -> true | Some _ -> false
(* The answer to the selection under [name] of the response [j]: its errors win over its value, which may be partial. [None] if GitHub refused it for its resource limits. *)let aliased j name = let value = Option.bind (member "data" j) (member name) in let not_found e = type_is "NOT_FOUND" e && match path_head e with Some (_, whole) -> whole | None -> false in match errors_at j name with | [] -> Some (Ok (Option.value value ~default:(Json.Value.null ()))) | es when has_error (message_has resource_limits) es -> None | es when is_null value && List.exists not_found es -> Some (Error Not_found) | es -> Some (Error (Graphql (Json.Value.list es)))
(* The answers of a batch, the refused ones taken in order from [again]. *)let rec merge answers again = match (answers, again) with | [], _ -> [] | (x, Some a) :: rest, again -> (x, a) :: merge rest again | (x, None) :: rest, (_, a) :: again -> (x, a) :: merge rest again | (x, None) :: rest, [] -> (x, Error Too_large) :: merge rest []
let rec ask t ~policy field xs = let text = "query{" ^ String.concat " " (List.mapi (fun i x -> alias i ^ ":" ^ field x) xs) ^ "}" in match query t ~policy (Template.const text) () with | Ok j -> ( let answers = List.mapi (fun i x -> (x, aliased j (alias i))) xs in let refused = List.filter_map (fun (x, a) -> if a = None then Some x else None) answers in match refused with | [] -> List.map (fun (x, a) -> (x, Option.get a)) answers | _ when List.length refused = List.length xs -> too_large t ~policy field xs | _ -> merge answers (ask t ~policy field refused)) | Error Too_large -> too_large t ~policy field xs | Error e -> List.map (fun x -> (x, Error e)) xs
(* A batch GitHub refused for its resource limits, asked again in halves down to one selection. *)and too_large t ~policy field xs = match xs with | [] -> [] | [ x ] -> [ (x, Error Too_large) ] | xs -> let half = List.length xs / 2 in let l, r = take half xs in Log.info (fun m -> m "splitting a batch of %d" (List.length xs)); let l = ask t ~policy field l in l @ ask t ~policy field r
let batch t ~policy ?(size = 100) field xs = if size <= 0 then Fmt.invalid_arg "Github_query.batch: size %d" size; List.concat_map (ask t ~policy field) (chunks size xs)
(* Connections *)
let err_incomplete fmt = Fmt.kstr (fun s -> Error (Incomplete s)) fmtlet pp_path = Fmt.(list ~sep:(any ".") string)
(* [q] with its [after] variable set to the cursor given beside [x]. *)let with_after (q : 'a Template.t) : ('a * Json.t) Template.t = { Template.text = q.text; vars = (fun (x, after) -> List.filter (fun (k, _) -> k <> "after") (q.vars x) @ [ ("after", after) ]); }
(* The object at [path] under the [data] of the response [j]. A [null] on the way is GitHub not knowing the object, when no other error says why. *)let at_path ~path j = let rec go v = function | [] -> `Value v | name :: rest -> ( match member name v with | Some (Json.Null _) -> `Null | Some v -> go v rest | None -> `Missing name) in let data = Option.value (member "data" j) ~default:(Json.Value.null ()) in match (errors_of j, go data path) with | None, `Value v -> Ok v | None, `Null -> Error Not_found | None, `Missing name -> err_incomplete "no member %s on the path %a" name pp_path path | Some (_, es), (`Null | `Missing _) when List.for_all (type_is "NOT_FOUND") es -> Error Not_found | Some (errors, _), _ -> Error (Graphql errors)
(* The nodes of the connection at [path] of the page [j], and the cursor of the next page if there is one. *)let page ~path j = match at_path ~path j with | Error _ as e -> e | Ok c -> ( let info = member "pageInfo" c in let has_next = match Option.bind info (member "hasNextPage") with | Some (Json.Bool (b, _)) -> Some b | _ -> None in match (member "nodes" c, has_next) with | Some (Json.Array (nodes, _)), Some false -> Ok (nodes, None) | Some (Json.Array (nodes, _)), Some true -> ( match Option.bind info (string_member "endCursor") with | Some cursor -> Ok (nodes, Some cursor) | None -> err_incomplete "no endCursor at %a" pp_path path) | Some (Json.Array _), None -> err_incomplete "no pageInfo { hasNextPage } at %a" pp_path path | _ -> err_incomplete "no nodes at %a" pp_path path)
(* The nodes before the first one [until] holds for, onto [acc] in reverse, and whether there was one. *)let rec before ~until acc = function | [] -> (acc, false) | n :: _ when until n -> (acc, true) | n :: rest -> before ~until (n :: acc) rest
let cursor = function | None -> Json.Value.null () | Some c -> Json.Value.string c
let nodes t ~policy ?(until = fun _ -> false) ~path q x = if not (contains ~affix:"$after" (Template.text q)) then Fmt.invalid_arg "Github_query.nodes: the query has no $after variable"; let q = with_after q in let rec go after acc = match query t ~policy q (x, cursor after) with | Error e -> Error e | Ok j -> ( match page ~path j with | Error e -> Error e | Ok (ns, next) -> ( let acc, stopped = before ~until acc ns in match next with | _ when stopped -> Ok (List.rev acc) | None -> Ok (List.rev acc) | Some c when Some c = after -> err_incomplete "the cursor at %a does not move" pp_path path | next -> go next acc)) in go None []
module Search = struct type kind = Repository | Issue | User | Discussion
let cap = 1000
let type_name = function | Repository -> "REPOSITORY" | Issue -> "ISSUE" | User -> "USER" | Discussion -> "DISCUSSION"
let count_name = function | Repository -> "repositoryCount" | Issue -> "issueCount" | User -> "userCount" | Discussion -> "discussionCount"
let template ~kind ~fields = Template.v (Fmt.str "query($q:String!,$after:String){search(query:$q type:%s first:100 \ after:$after){%s pageInfo{hasNextPage endCursor} nodes{%s}}}" (type_name kind) (count_name kind) fields) (fun q -> [ ("q", Json.Value.string q) ])
let seconds p = Float.to_int (Float.floor (Ptime.to_float_s p))
let time s = match Ptime.of_float_s (float_of_int s) with | None -> Fmt.invalid_arg "Github_query.Search: time %d out of range" s | Some p -> let (y, m, d), ((hh, mm, ss), _) = Ptime.to_date_time p in Fmt.str "%04d-%02d-%02dT%02d:%02d:%02d+00:00" y m d hh mm ss
let nodes t ~policy ?(qualifier = "created") ~kind ~fields ~range:(lo, hi) q = let lo = seconds lo and hi = seconds hi in if lo > hi then Fmt.invalid_arg "Github_query.Search.nodes: empty range"; let tmpl = template ~kind ~fields in let ranged lo hi = Fmt.str "%s %s:%s..%s" q qualifier (time lo) (time hi) in let count lo hi = match query t ~policy (with_after tmpl) (ranged lo hi, cursor None) with | Error e -> Error e | Ok j -> ( match at_path ~path:[ "search" ] j with | Error e -> Error e | Ok s -> ( match int_member (count_name kind) s with | Some n -> Ok n | None -> err_incomplete "no %s in the search" (count_name kind))) in let rec split lo hi = match count lo hi with | Error e -> Error e | Ok 0 -> Ok [] | Ok n when n <= cap -> nodes t ~policy ~path:[ "search" ] tmpl (ranged lo hi) | Ok n when lo = hi -> err_incomplete "%d results over the cap of %d in %s" n cap (ranged lo hi) | Ok n -> ( let mid = lo + ((hi - lo) / 2) in Log.info (fun m -> m "splitting a search of %d results" n); match split lo mid with | Error e -> Error e | Ok l -> Result.map (fun r -> l @ r) (split (mid + 1) hi)) in split lo hiend
module Probe = struct type repo = { id : string; name : string; is_private : bool; pushed_at : string option; newest_pull_request : string option; newest_issue : string option; }
let id r = r.id let name r = r.name let is_private r = r.is_private let pushed_at r = r.pushed_at let newest_pull_request r = r.newest_pull_request let newest_issue r = r.newest_issue
let newest conn = conn ^ "(first:1 orderBy:{field:UPDATED_AT direction:DESC}){nodes{updatedAt}}"
let field (owner, name) = Fmt.str "repository(owner:%s name:%s){id nameWithOwner isPrivate pushedAt %s %s}" (quote owner) (quote name) (newest "pullRequests") (newest "issues")
let newest_of conn j = match Option.bind (member conn j) (member "nodes") with | Some (Json.Array (n :: _, _)) -> string_member "updatedAt" n | _ -> None
let of_json j = match (string_member "id" j, string_member "nameWithOwner" j) with | Some id, Some name -> Some { id; name; is_private = (match member "isPrivate" j with | Some (Json.Bool (b, _)) -> b | _ -> false); pushed_at = string_member "pushedAt" j; newest_pull_request = newest_of "pullRequests" j; newest_issue = newest_of "issues" j; } | _ -> None
let repos t ~policy ?size names = batch t ~policy ?size field names |> List.map (fun (n, r) -> match r with | Error Not_found -> (n, Ok None) | r -> (n, Result.map of_json r))end
module Project = struct type kind = | Text | Number | Date | Single_select of (string * string) list | Iteration of (string * string) list | Other of string
type field = { id : string; name : string; kind : kind }
type t = { owner : string; number : int; id : string; title : string; fields : field list; }
let id t = t.id let title t = t.title let fields t = t.fields let same a b = String.lowercase_ascii a = String.lowercase_ascii b
let field t name = match List.find_opt (fun (f : field) -> f.name = name) t.fields with | Some f -> Some f | None -> List.find_opt (fun (f : field) -> same f.name name) t.fields
let array = function Some (Json.Array (l, _)) -> l | _ -> []
let pairs k j = List.filter_map (fun o -> match (string_member k o, string_member "id" o) with | Some n, Some id -> Some (n, id) | _ -> None) (array j)
let field_of_json j = match (string_member "id" j, string_member "name" j) with | Some id, Some name -> let kind = match string_member "dataType" j with | Some "TEXT" -> Text | Some "NUMBER" -> Number | Some "DATE" -> Date | Some "SINGLE_SELECT" -> Single_select (pairs "name" (member "options" j)) | Some "ITERATION" -> let c = member "configuration" j in let at k = Option.bind c (member k) in Iteration (pairs "title" (at "iterations") @ pairs "title" (at "completedIterations")) | Some d -> Other d | None -> Other "" in Some { id; name; kind } | _ -> None
let owner_vars (owner, number) = [ ("owner", Json.Value.string owner); ("number", Json.Value.int number) ]
let in_project s = Fmt.str "repositoryOwner(login: $owner) { ... on ProjectV2Owner { \ projectV2(number: $number) { %s } } }" s
let get_query = Template.v ("query($owner: String!, $number: Int!) { " ^ in_project "id title fields(first: 100) { nodes { ... on ProjectV2FieldCommon { \ id name dataType } ... on ProjectV2SingleSelectField { options { id \ name } } ... on ProjectV2IterationField { configuration { \ iterations { id title } completedIterations { id title } } } } }" ^ " }") owner_vars
let project_of data = Option.bind (member "repositoryOwner" data) (member "projectV2")
let get c ~policy ~owner number = match query c ~policy get_query (owner, number) with | Error e -> Error e | Ok j -> ( match Option.bind (member "data" j) project_of with | None | Some (Json.Null _) -> Error Not_found | Some p -> ( match (string_member "id" p, string_member "title" p) with | Some id, title -> let fields = List.filter_map field_of_json (array (Option.bind (member "fields" p) (member "nodes"))) in Ok { owner; number; id; title = Option.value ~default:"" title; fields; } | None, _ -> Error (Incomplete "a project with no id")))
type value = [ `Text of string | `Number of float | `Date of string | `Option of string | `Iteration of string ]
type item = { item : string; archived : bool; content : Json.t option; values : (string * value) list; }
let value_selection = let named s = Fmt.str "%s field { ... on ProjectV2FieldCommon { name } }" s in Fmt.str "fieldValues(first: 50) { nodes { ... on ProjectV2ItemFieldTextValue { \ %s } ... on ProjectV2ItemFieldNumberValue { %s } ... on \ ProjectV2ItemFieldDateValue { %s } ... on \ ProjectV2ItemFieldSingleSelectValue { %s } ... on \ ProjectV2ItemFieldIterationValue { %s } } }" (named "text") (named "number") (named "date") (named "name") (named "title")
let default_content = "content { ... on Issue { id number } ... on PullRequest { id number } ... \ on DraftIssue { id } }"
let item_selection ?(content = default_content) () = Fmt.str "id isArchived %s %s" content value_selection
let value_of_json j = let name = Option.bind (member "field" j) (string_member "name") in let v = match string_member "text" j with | Some s -> Some (`Text s) | None -> ( match member "number" j with | Some (Json.Number (n, _)) -> Some (`Number (Json.Number.to_float n)) | _ -> ( match string_member "date" j with | Some d -> Some (`Date d) | None -> ( match string_member "name" j with | Some o -> Some (`Option o) | None -> Option.map (fun s -> `Iteration s) (string_member "title" j)))) in match (name, v) with Some n, Some v -> Some (n, v) | _ -> None
let item_of_json j = match string_member "id" j with | None -> None | Some item -> Some { item; archived = (match member "isArchived" j with | Some (Json.Bool (b, _)) -> b | _ -> false); content = (match member "content" j with | Some (Json.Null _) | None -> None | c -> c); values = List.filter_map value_of_json (array (Option.bind (member "fieldValues" j) (member "nodes"))); }
let items c ~policy ?content t = let q = Template.v ("query($owner: String!, $number: Int!, $after: String) { " ^ Fmt.kstr in_project "items(first: 100, after: $after) { pageInfo { hasNextPage \ endCursor } nodes { %s } }" (item_selection ?content ()) ^ " }") owner_vars in nodes c ~policy ~path:[ "repositoryOwner"; "projectV2"; "items" ] q (t.owner, t.number) |> Result.map (List.filter_map item_of_json)
let errors_or_ok j = match member "errors" j with | Some (Json.Array (_ :: _, _) as es) -> Error (Graphql es) | _ -> Ok j
(* The input of one field's update: the variable it takes and its value, or none for a clear. *) let update t (name, v) = let err_invalid fmt = Fmt.kstr (fun s -> Error (Invalid s)) fmt in let pick what l x = match List.assoc_opt x l with | Some id -> Ok id | None -> ( match List.find_opt (fun (n, _) -> same n x) l with | Some (_, id) -> Ok id | None -> err_invalid "%s has no %s %S" name what x) in match field t name with | None -> err_invalid "the project has no field %S" name | Some f -> ( let ok k j = Ok (f.id, Some (obj [ (k, j) ])) in match (f.kind, v) with | _, None -> Ok (f.id, None) | Text, Some (`Text s) -> ok "text" (Json.Value.string s) | Number, Some (`Number n) when Float.is_finite n -> ok "number" (Json.Value.number n) | Date, Some (`Date d) -> ok "date" (Json.Value.string d) | Single_select l, Some (`Option o) -> Result.bind (pick "option" l o) (fun id -> ok "singleSelectOptionId" (Json.Value.string id)) | Iteration l, Some (`Iteration i) -> Result.bind (pick "iteration" l i) (fun id -> ok "iterationId" (Json.Value.string id)) | _, Some _ -> err_invalid "%S does not take that value" name)
let rec all = function | [] -> Ok [] | Ok x :: rest -> Result.map (fun l -> x :: l) (all rest) | (Error _ as e) :: _ -> e
let in_item = "input: { projectId: $project, itemId: $item }"
let set c t ~item ?(archived = false) updates = match all (List.map (update t) updates) with | Error e -> Error e | Ok us -> let parts = List.mapi (fun i (fid, v) -> let f = Fmt.str "f%d" i and x = Fmt.str "v%d" i in match v with | None -> ( [ Fmt.str "$%s: ID!" f ], Fmt.str "u%d: clearProjectV2ItemFieldValue(input: { projectId: \ $project, itemId: $item, fieldId: $%s }) { \ projectV2Item { id } }" i f, [ (f, Json.Value.string fid) ] ) | Some v -> ( [ Fmt.str "$%s: ID!" f; Fmt.str "$%s: ProjectV2FieldValue!" x; ], Fmt.str "u%d: updateProjectV2ItemFieldValue(input: { projectId: \ $project, itemId: $item, fieldId: $%s, value: $%s }) { \ projectV2Item { id } }" i f x, [ (f, Json.Value.string fid); (x, v) ] )) us in let decl = List.concat_map (fun (d, _, _) -> d) parts and sel = List.map (fun (_, s, _) -> s) parts and vars = List.concat_map (fun (_, _, v) -> v) parts in let around s = if archived then [ Fmt.str "unarchive: unarchiveProjectV2Item(%s) { item { id } }" in_item; ] @ s @ [ Fmt.str "archive: archiveProjectV2Item(%s) { item { id } }" in_item; ] else s in let text = Fmt.str "mutation(%s) { %s }" (String.concat ", " ("$project: ID!" :: "$item: ID!" :: decl)) (String.concat " " (around sel)) in let vars () = ("project", Json.Value.string t.id) :: ("item", Json.Value.string item) :: vars in Result.bind (mutate c (Template.v text vars) ()) errors_or_ok |> Result.map ignore
let add_mutation = Template.v "mutation($project: ID!, $content: ID!) { addProjectV2ItemById(input: { \ projectId: $project, contentId: $content }) { item { id } } }" (fun (p, c) -> [ ("project", Json.Value.string p); ("content", Json.Value.string c) ])
let add c t ~content = match Result.bind (mutate c add_mutation (t.id, content)) errors_or_ok with | Error e -> Error e | Ok j -> ( match Option.bind (member "data" j) (fun d -> Option.bind (member "addProjectV2ItemById" d) (fun a -> Option.bind (member "item" a) (string_member "id"))) with | Some id -> Ok id | None -> Error (Incomplete "no item id in the answer"))end
module Rest = struct type nonrec t = t
type transport = headers:(string * string) list -> string -> (response, [ `Timeout | `Msg of string ]) result
let requests session ~headers url = let headers = Requests_eio.Headers.of_list headers in match Requests_eio.get session ~headers url with | r -> Ok { status = Requests_eio.Response.status_code r; headers = Requests_eio.Headers.to_list (Requests_eio.Response.headers r); body = Requests_eio.Response.text r; } | exception Eio.Io (Requests_eio.Error.E e, _) when Requests_eio.Error.is_timeout e -> Error `Timeout | exception (Eio.Io _ as e) -> err_io e
let trim_slash s = let n = String.length s in if n > 0 && s.[n - 1] = '/' then String.sub s 0 (n - 1) else s
let v ~clock ~store ?(endpoint = "https://api.github.com") ?(principal = "public") ?(retries = 5) ?(reserve = 50) ~token transport = client ~clock ~store ~principal ~retries ~reserve ~token ~endpoint:(trim_slash endpoint) transport
let under t url = String.starts_with ~prefix:(t.endpoint ^ "/") url
let url t path = if String.starts_with ~prefix:"/" path then t.endpoint ^ path else if under t path then path else Fmt.invalid_arg "Github_query.Rest: %S is neither a path nor under %s" path t.endpoint
let key t path = Cas_store.Key.of_spec (obj [ ("src", Json.Value.string "github.rest"); ("url", Json.Value.string (url t path)); ("principal", Json.Value.string t.principal); ])
(* Link header values (RFC 8288 Section 3): each target with its relation types. Malformed links are skipped. *)
let is_space c = c = ' ' || c = '\t'
let links s = let n = String.length s in let rec skip_ws i = if i < n && is_space s.[i] then skip_ws (i + 1) else i in let rec skip_sep i = if i < n && (is_space s.[i] || s.[i] = ',') then skip_sep (i + 1) else i in let rec stop_at p i = if i < n && not (p s.[i]) then stop_at p (i + 1) else i in let quoted i = let b = Buffer.create 16 in let rec go i = if i >= n then i else match s.[i] with | '"' -> i + 1 | '\\' when i + 1 < n -> Buffer.add_char b s.[i + 1]; go (i + 2) | c -> Buffer.add_char b c; go (i + 1) in let j = go i in (Buffer.contents b, j) in let delim c = is_space c || c = ';' || c = ',' || c = '=' in (* The parameters after a target, up to the comma that ends the link. *) let rec params i rel = let i = skip_ws i in if i >= n || s.[i] = ',' then (i, rel) else if s.[i] <> ';' then params (i + 1) rel else let i = skip_ws (i + 1) in let j = stop_at delim i in let name = String.lowercase_ascii (String.sub s i (j - i)) in let j = skip_ws j in if j < n && s.[j] = '=' then let k = skip_ws (j + 1) in let value, k = if k < n && s.[k] = '"' then quoted (k + 1) else let e = stop_at delim k in (String.sub s k (e - k), e) in params k (if name = "rel" && rel = None then Some value else rel) else params j rel in let rels = function | None -> [] | Some r -> String.split_on_char ' ' r |> List.filter (( <> ) "") |> List.map String.lowercase_ascii in let rec go i acc = let i = skip_sep i in if i >= n then List.rev acc else if s.[i] = '<' then match String.index_from_opt s i '>' with | None -> List.rev acc | Some j -> let target = String.sub s (i + 1) (j - i - 1) in let k, rel = params (j + 1) None in go k ((target, rels rel) :: acc) else go (stop_at (fun c -> c = ',') i) acc in go 0 []
let next_page s = List.find_map (fun (target, rels) -> if List.mem "next" rels then Some target else None) (links s)
(* The resource GitHub counts a request against, by its path. *) let resource_of_url t url = let path = String.sub url (String.length t.endpoint) (String.length url - String.length t.endpoint) in if String.starts_with ~prefix:"/search/code" path then "code_search" else if String.starts_with ~prefix:"/search/" path then "search" else "core"
let budget ?(resource = "core") t = budget_of t resource
(* A stored page: the response body and the link to the page after it. *) let page_of body next = obj [ ("body", body); ( "next", match next with | Some u -> Json.Value.string u | None -> Json.Value.null () ); ]
let validators_of ~mark r = Cas_store.Validators.v ?etag:(header "etag" r) ?last_modified:(header "last-modified" r) ?mark ()
let next t ~resource ~mark ~revalidating = function | Error `Timeout -> Retry (None, Transport "timed out") | Error (`Msg m) -> Retry (None, Transport m) | Ok r -> ( let resource = resource_of ~default:resource r in Option.iter (fun (remaining, reset_at) -> set_budget t resource ~remaining ~reset_at) (header_rate_limit r); match r.status with | 403 | 429 -> rate_limited t ~resource r (Http (r.status, r.body)) | s when s >= 500 -> Retry (float_header "retry-after" r, Http (s, r.body)) | 304 when revalidating -> Answer (Cas_store.Not_modified (validators_of ~mark r)) | (404 | 409 | 410 | 451) as s -> Answer (Cas_store.Gone s) | 200 -> ( match Json.Value.of_string r.body with | Error _ -> Fail (Http (200, r.body)) | Ok j -> let next = Option.bind (header "link" r) next_page in Answer (Cas_store.Body (canonical (page_of j next), validators_of ~mark r))) | s -> Fail (Http (s, r.body)))
let send_get t ~mark url stale = let conditional = match stale with | None -> [] | Some v -> let h name = Option.map (fun x -> (name, x)) in List.filter_map Fun.id [ h "If-None-Match" (Cas_store.Validators.etag v); h "If-Modified-Since" (Cas_store.Validators.last_modified v); ] in let headers = [ ("Authorization", "Bearer " ^ t.token); ("Accept", "application/vnd.github+json"); ("X-GitHub-Api-Version", "2022-11-28"); ] @ conditional in send t ~resource:(resource_of_url t url) ~headers ~next: (next t ~resource:(resource_of_url t url) ~mark ~revalidating:(conditional <> [])) url
let page t ~policy url = let mark = mark_of policy in let fetch stale = match send_get t ~mark url stale with | Ok f -> f | Error e -> raise (Failed e) in match Cas_store.resolve t.store ~policy ~fetch (key t url) with | Ok (_, s) -> ( match Json.Value.of_string s with | Ok j -> ( match member "body" j with | Some body -> Ok (body, string_member "next" j) | None -> Error (Http (200, "stored page: no body"))) | Error e -> Error (Http (200, Fmt.str "stored page: %a" Json.Error.pp e))) | Error (`Gone status) -> Error (Http (status, "")) | exception Failed e -> Error e
let get t ~policy path = Result.map fst (page t ~policy (url t path))
let pages t ~policy ?limit path = (match limit with | Some n when n <= 0 -> Fmt.invalid_arg "Github_query.Rest.pages: limit %d" n | _ -> ()); let rec go n u acc = match page t ~policy u with | Error e -> Error e | Ok (body, next) -> ( let acc = body :: acc in match next with | Some _ when Option.fold ~none:false ~some:(fun l -> n >= l) limit -> Ok (List.rev acc) | None -> Ok (List.rev acc) | Some u when under t u -> go (n + 1) u acc | Some u -> err_transport "next page %s is not under %s" u t.endpoint) in go 1 (url t path) []end