Something went wrong. Try again.
GitHub GraphQL client whose answers are kept in a raw store
Something went wrong. Try again.
23 kB · 540 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541(** GitHub GraphQL queries answered through a cas store.
[Github_query] sends GraphQL queries to GitHub's API and keeps every answer in a {!Cas_store.t}, so a query asked again reads the stored answer while its {!Cas_store.Policy.t} says the answer is fresh.
A query is a {!Template.t} applied to its variables. Its key is the spec [{"src":"github.graphql","query":q,"variables":v,"principal":p}], where [q] is the query text with comments removed and whitespace collapsed, [v] the variables object and [p] the principal the client asks as. The key hashes the {{:https://www.rfc-editor.org/rfc/rfc8785}RFC 8785} form of the spec, so variables given in another member order are the same key.
The text sent also selects [rateLimit { cost remaining resetAt }]. The stored answer is the response without that member, in its RFC 8785 form, so two fetches of unchanged content store one object. The rate data is written to a budget the store keeps per token: every client on that store and token, in this process or another, waits for the reset when the budget is spent.
A response with HTTP status [403] or [429] that carries [Retry-After] or a spent [X-RateLimit-Remaining] pauses the token's budget until the time it gives, then the query is sent again. A [5xx] status, a timeout or a transport failure is retried with exponential backoff. A query GitHub refuses as too costly ([Resource limits for this query exceeded], or a timeout that retries do not cure) is the error {!Too_large}, on which {!batch} halves its batch. A response that answers some selections and refuses others as too costly, naming them in its errors' paths, is an answer: {!batch} asks the refused ones again.
{!Probe} asks many repositories in one cheap query for their latest activity, which says whether a costlier query is worth sending again. *)
(** {1:templates Templates} *)
(** Query templates. *)module Template : sig type 'a t (** The type for GraphQL queries whose variables are given by a value of type ['a]. *)
val v : string -> ('a -> (string * Json.t) list) -> 'a t (** [v text vars] is the query [text] whose variables for [x] are the members [vars x]. [text] is held in {!normalise}d form. *)
val const : string -> unit t (** [const text] is [v text (fun () -> [])]. *)
val text : 'a t -> string (** [text t] is the normalised text of [t]. *)
val variables : 'a t -> 'a -> Json.t (** [variables t x] is the variables object of [t] for [x]. *)
val normalise : string -> string (** [normalise s] is the GraphQL text [s] with its comments removed, each run of whitespace and commas outside strings replaced by one space, and the spaces next to punctuation removed. Strings and block strings are kept as written. [normalise (normalise s)] is [normalise s]. *)
val quote : string -> string (** [quote s] is [s] as a GraphQL string literal. *)end
(** {1:transports Transports} *)
type response(** The type for HTTP responses. *)
val response : ?headers:(string * string) list -> status:int -> string -> response(** [response ~headers ~status body] is the response with HTTP status [status], headers [headers] (defaults to none) and body [body]. *)
type transport = headers:(string * string) list -> string -> (response, [ `Timeout | `Msg of string ]) result(** The type for transports. [transport ~headers body] posts the JSON request [body] with [headers] to GitHub's GraphQL endpoint. It is [Error `Timeout] if no response came in time and [Error (`Msg m)] if the request failed otherwise. *)
val requests : ?endpoint:string -> Requests_eio.t -> transport(** [requests ~endpoint session] posts with [session] to [endpoint] (defaults to ["https://api.github.com/graphql"]). [session] should not retry on its own: the client does. *)
(** {1:errors Errors} *)
(** The type for errors. *)type error = | Http of int * string (** A status the client does not retry, or a retried one that persisted, with the response body. *) | Graphql of Json.t (** The [errors] member of a response that has no [data], or the errors of one selection of a {!batch}. *) | Not_found (** GitHub does not know the object a {!batch} selection or a {!nodes} path names, or does not show it to the token: its error has the type [NOT_FOUND], or it is [null]. *) | Incomplete of string (** The answer cannot be read whole, for the reason given: a page with no [pageInfo], a cursor that does not move, or a search with more results than GitHub returns in a range that cannot be split. *) | Too_large (** GitHub refused the query as too costly, or timed out on it. *) | Transport of string (** The transport failed on every try. *) | Invalid of string (** An input refused before anything is sent: a field, an option or an iteration the project does not have, or a value of another kind than its field's. *)
val pp_error : error Fmt.t(** [pp_error] formats an error for humans. *)
(** {1:clients Clients} *)
type t(** The type for clients. *)
val v : clock:_ Eio.Time.clock -> store:Cas_store.t -> ?principal:string -> ?retries:int -> ?reserve:int -> token:string -> transport -> t(** [v ~clock ~store ~principal ~retries ~reserve ~token transport] is a client that sends queries through [transport] with [token] and keeps their answers in [store]: - [principal] (defaults to ["public"]) is who the answers are for: ["public"] when they do not depend on [token]'s access, else the token owner's login. It is part of every key. - [retries] (defaults to [5]) is how many times one query is sent again after a rate limit, a [5xx] status, a timeout or a transport failure. Backoff starts at one second and doubles up to a minute. - [reserve] (defaults to [50]) is the number of points of the budget left unused: a query waits for the reset while the budget's remaining points are at most [reserve]. *)
val key : t -> 'a Template.t -> 'a -> Cas_store.Key.t(** [key t q x] is the key of the query [q] with the variables for [x], asked as [t]'s principal. *)
val query : t -> policy:Cas_store.Policy.t -> 'a Template.t -> 'a -> (Json.t, error) result(** [query t ~policy q x] is GitHub's answer to [q] with the variables for [x]: the stored one while [policy] says it is fresh, else the one fetched and stored. It is the whole response object, [data] and, for a partial answer, [errors]. Under {!Cas_store.Policy.Probe}[ m] a fetched answer is stored with the mark [m], so it stays fresh until a probe reports a later one. A response that is an error is not stored, nor is a partial answer with an error whose type is not [NOT_FOUND]: it is answered once and asked again next time. *)
val batch : t -> policy:Cas_store.Policy.t -> ?size:int -> ('a -> string) -> 'a list -> ('a * (Json.t, error) result) list(** [batch t ~policy ~size field xs] asks the selections [field x] for every [x] of [xs], [size] (defaults to [100]) at a time, each under an alias in one {!query}. It is each [x] with the answer to its alias: - [Error Not_found] if the alias is [null] and an error of type [NOT_FOUND] has the path [[alias]]; - [Error (Graphql es)] otherwise if any error has a path that starts at the alias, with [es] those errors: a value beside them may be partial; - [Ok j] otherwise, with [j] the alias's value, {!Json.Null} when the answer has none.
The aliases GitHub refuses for its resource limits beside others it answers are asked again in a batch of their own. A batch that is {!Too_large} is asked again in halves, down to one selection, which is then the error; an error of the whole query is each [x]'s. [xs] are answered in order.
@raise Invalid_argument if [size] is not positive. *)
val nodes : t -> policy:Cas_store.Policy.t -> ?until:(Json.t -> bool) -> path:string list -> 'a Template.t -> 'a -> (Json.t list, error) result(** [nodes t ~policy ~until ~path q x] is every node of the connection at [path] under the [data] of [q]'s answer with the variables for [x], in order. [q] declares a [$after: String] variable that it passes as the connection's [after] argument, and selects the connection's [pageInfo { hasNextPage endCursor }] and [nodes]. Each page is a {!query} under [policy], with [after] set to [null] for the first page and to the [endCursor] of the page before for the next ones, so a page read again while [policy] says it is fresh is not fetched.
Paging stops at the first node [until] holds for (defaults to none): that node and the ones after it are left out, and no page after it is asked.
It is an error, never the nodes read so far, if a page is an error, if a page's response has errors ({!Graphql}), if a [null] is on [path] ({!Not_found}) or if a page lacks its [nodes], its [pageInfo] or the [endCursor] of a next page, or repeats the cursor it was asked with ({!Incomplete}).
@raise Invalid_argument if the text of [q] has no [$after]. *)
(** GitHub searches past their cap.
GitHub's [search] connection answers at most {!cap} results of a query. A search over a time range is asked for its count first, and a range with more results than {!cap} is split in two halves, each asked the same way, until every part is under the cap. *)module Search : sig (** The type for what a search finds. *) type kind = | Repository (** [type: REPOSITORY], counted by [repositoryCount]. *) | Issue (** [type: ISSUE], counted by [issueCount]. *) | User (** [type: USER], counted by [userCount]. *) | Discussion (** [type: DISCUSSION], counted by [discussionCount]. *)
val cap : int (** [cap] is [1000], the number of results GitHub returns of one search. *)
val nodes : t -> policy:Cas_store.Policy.t -> ?qualifier:string -> kind:kind -> fields:string -> range:Ptime.t * Ptime.t -> string -> (Json.t list, error) result (** [nodes t ~policy ~qualifier ~kind ~fields ~range:(lo, hi) q] is every result of the search [q] of [kind] whose [qualifier] (defaults to ["created"]) is between [lo] and [hi], both included, to the second: each result is the selection [fields] of a node, such as ["... on Repository { nameWithOwner }"]. The range is given to GitHub as [qualifier:lo..hi] in RFC 3339 times. A range with more than {!cap} results is split at its middle second; one second with more results than {!cap} is the error {!Incomplete}. Each part is read with {!val-nodes} under [policy], and the parts are in time order.
@raise Invalid_argument if [hi] is before [lo]. *)end
(** {1:mutations Mutations} *)
val mutate : t -> 'a Template.t -> 'a -> (Json.t, error) result(** [mutate t m x] sends the mutation [m] with the variables for [x] and is GitHub's response, [data] and, for a partial answer, [errors]. Nothing is read from or kept in the store: every call is sent. It waits on the token's budget like {!query} and is sent again only after GitHub refused it for its rate limit, which it does before applying it. A [5xx] status, a timeout or a transport failure is the error, never retried: the mutation may have been applied, which only reading its target back tells. *)
val budget : t -> (int * Ptime.t) option(** [budget t] is the remaining points of [t]'s token and when they reset, as last reported to any client of [t]'s store, or [None] if none was. *)
(** {1:probes Probes} *)
(** Freshness probes of repositories. *)module Probe : sig type repo (** The type for a repository's probed activity. *)
val id : repo -> string (** [id r] is the node identifier of [r]. *)
val name : repo -> string (** [name r] is the [owner/name] of [r], after renames. *)
val is_private : repo -> bool (** [is_private r] is [true] iff [r] is private. *)
val pushed_at : repo -> string option (** [pushed_at r] is when [r] was last pushed to, an RFC 3339 time. *)
val newest_pull_request : repo -> string option (** [newest_pull_request r] is the latest [updatedAt] of the pull requests of [r], if it has any. *)
val newest_issue : repo -> string option (** [newest_issue r] is the latest [updatedAt] of the issues of [r], if it has any. *)
val field : string * string -> string (** [field (owner, name)] is the selection that probes [owner/name]. *)
val of_json : Json.t -> repo option (** [of_json j] is the repository [j] describes as {!field} selects it, or [None] if [j] is [null] or not such a description. *)
val repos : t -> policy:Cas_store.Policy.t -> ?size:int -> (string * string) list -> ((string * string) * (repo option, error) result) list (** [repos t ~policy ~size names] probes the repositories [names], given as [(owner, name)], {!batch}ed [size] (defaults to [100]) a query. A repository GitHub does not know, or that [t]'s token cannot see, is [Ok None]; one whose selection failed otherwise, such as one GitHub refuses as [FORBIDDEN], is the {!batch}'s error. A probe should use a short policy, such as {!Cas_store.Policy.Max_age}, and its marks the {!Cas_store.Policy.Probe} policy of the queries it guards. *)end
(** {1:projects Projects} *)
(** GitHub Projects: a project's fields, its items' field values, and the mutations that set them.
A project is read with {!get}, which gives its id and its fields; its items with {!items}. {!set} sets or clears some of an item's fields in one mutation, an archived item included, and {!add} adds an issue or a pull request to a project. *)
type client := t
module Project : sig (** The type for field kinds. *) type kind = | Text | Number | Date | Single_select of (string * string) list (** each option's name and id, in the project's order *) | Iteration of (string * string) list (** each iteration's title and id, current then completed *) | Other of string (** a field {!set} cannot write (assignees, labels, a repository, sub-issues, ...): its GraphQL [dataType] *)
type field = { id : string; name : string; kind : kind } (** The type for a project's fields. *)
type t (** The type for projects. *)
val get : client -> policy:Cas_store.Policy.t -> owner:string -> int -> (t, error) result (** [get c ~policy ~owner n] is the project number [n] of the organization or user [owner], read with {!query} under [policy]. It is [Error Not_found] when [owner] has no such project or [c]'s token cannot see it. *)
val id : t -> string (** [id t] is [t]'s node id. *)
val title : t -> string (** [title t] is [t]'s title. *)
val fields : t -> field list (** [fields t] is [t]'s fields, in the project's order. *)
val field : t -> string -> field option (** [field t name] is [t]'s field named [name], or else the one named [name] up to case. *)
type value = [ `Text of string | `Number of float | `Date of string (** [yyyy-mm-dd] *) | `Option of string (** a single-select option, by name *) | `Iteration of string (** an iteration, by title *) ] (** The type for field values. *)
type item = { item : string; (** the item's node id *) archived : bool; content : Json.t option; (** the item's [content] selection, [None] when it has none *) values : (string * value) list; (** each set field's name and value; fields {!set} cannot write are left out *) } (** The type for project items. *)
val item_selection : ?content:string -> unit -> string (** [item_selection ~content ()] is the selection of a [ProjectV2Item] that {!item_of_json} reads: [content] (defaults to the issue's, pull request's or draft's [id], and [number]) and the field values. A query of the caller's selects it where GitHub has an item, such as an issue's [projectItems(includeArchived: true)], which has the archived items {!items} does not list. *)
val item_of_json : Json.t -> item option (** [item_of_json j] is the item [j] selects with {!item_selection}, [None] when [j] has no [id]. *)
val items : client -> policy:Cas_store.Policy.t -> ?content:string -> t -> (item list, error) result (** [items c ~policy ~content t] is every item of [t] GitHub lists, read with {!val-nodes} under [policy] and selected by {!item_selection} [~content]. GitHub does not list archived items. *)
val set : client -> t -> item:string -> ?archived:bool -> (string * value option) list -> (unit, error) result (** [set c t ~item ~archived updates] sets each field of [updates], by name (see {!field}), on the item [item] of [t] to its value, or clears it for [None], in one {!mutate}. Options and iterations are given by name and sent as their ids. An [archived] item (defaults to [false]) is unarchived first and archived again last, in the same mutation, whose fields GitHub runs in order. It is [Error (Invalid _)], with nothing sent, when a field, an option or an iteration is not [t]'s, or a value is not of its field's kind, and [Error (Graphql es)] when the response has errors [es]: some of the updates may then have been applied. *)
val add : client -> t -> content:string -> (string, error) result (** [add c t ~content] adds the issue or pull request whose node id is [content] to [t] with one {!mutate}, and is the item's id. Adding content already in [t] is its item. *)end
(** {1:rest REST} *)
(** GET requests to GitHub's REST API answered through the same cas store.
A REST client sends [GET] requests with its token and keeps each page of an answer in its {!Cas_store.t}, under the key of the spec [{"src":"github.rest","url":u,"principal":p}], where [u] is the page's absolute URL and [p] the principal the client asks as. The stored page is the response body with the target of its [Link] header's [rel="next"] link, so a paged answer read again from the store follows the same pages.
The budgets are the ones {!Github_query.v} clients use: one per token and per GitHub rate-limit resource, kept in the store. A REST response records its [X-RateLimit-Remaining] and [X-RateLimit-Reset] in the budget its [X-RateLimit-Resource] names ([core], [search], ...), and a request waits while the budget of the resource of its path is spent. A [403] or [429] with [Retry-After] or a spent [X-RateLimit-Remaining] pauses that budget until the time it gives, then the request is sent again; a [5xx] status, a timeout or a transport failure is retried with exponential backoff, as for GraphQL.
A stale entry with an [ETag] or a [Last-Modified] date is asked again with [If-None-Match] or [If-Modified-Since], and GitHub's [304 Not Modified] keeps it without counting against the budget. A [404], [409], [410] or [451] is stored as gone, so a missing repository is not asked again while the policy says the answer is fresh. *)module Rest : sig type t (** The type for REST clients. *)
type transport = headers:(string * string) list -> string -> (response, [ `Timeout | `Msg of string ]) result (** The type for REST transports. [transport ~headers url] sends a [GET] of the absolute [url] with [headers]. It is [Error `Timeout] if no response came in time and [Error (`Msg m)] if the request failed otherwise. *)
val requests : Requests_eio.t -> transport (** [requests session] sends with [session]. [session] should neither retry nor follow redirects to another host on its own. *)
val v : clock:_ Eio.Time.clock -> store:Cas_store.t -> ?endpoint:string -> ?principal:string -> ?retries:int -> ?reserve:int -> token:string -> transport -> t (** [v ~clock ~store ~endpoint ~principal ~retries ~reserve ~token transport] is a client that sends requests to the REST API at [endpoint] (defaults to ["https://api.github.com"]) through [transport] with [token]. The other arguments are those of {!Github_query.v}. A REST client and a GraphQL client on one store and one token share their budgets. *)
val key : t -> string -> Cas_store.Key.t (** [key t path] is the key of the page at [path], asked as [t]'s principal. [path] is as for {!get}. *)
val get : t -> policy:Cas_store.Policy.t -> string -> (Json.t, error) result (** [get t ~policy path] is GitHub's answer to a [GET] of [path], a path with its query string such as ["/orgs/ocaml/repos?per_page=100"] or an absolute URL under [t]'s endpoint: the stored body while [policy] says it is fresh, else the one fetched and stored. A gone answer is [Error (Http (status, ""))]. Under {!Cas_store.Policy.Probe}[ m] a fetched answer is stored with the mark [m].
@raise Invalid_argument if [path] neither starts with ["/"] nor is under [t]'s endpoint, which would send the token elsewhere. *)
val pages : t -> policy:Cas_store.Policy.t -> ?limit:int -> string -> (Json.t list, error) result (** [pages t ~policy ~limit path] is the body of each page of the answer to [path], in order: the page {!get} answers, then each page its [Link] header names as [rel="next"], up to [limit] pages (defaults to all). Each page is resolved under [policy] on its own. A next link that is not under [t]'s endpoint is the error {!Transport}, since following it would send the token elsewhere.
@raise Invalid_argument as {!get} does, or if [limit] is not positive. *)
val links : string -> (string * string list) list (** [links s] is the target and the relation types, lowercased, of each link of the [Link] header value [s] ({{:https://www.rfc-editor.org/rfc/rfc8288#section-3}RFC 8288 Section 3}), in order. A link whose target is not enclosed in [<] and [>] is skipped. *)
val next_page : string -> string option (** [next_page s] is the target of the first link of the [Link] header value [s] whose relation types include [next], if any. *)
val budget : ?resource:string -> t -> (int * Ptime.t) option (** [budget ~resource t] is the remaining requests of [t]'s token for the rate-limit resource [resource] (defaults to ["core"]) and when they reset, as last reported to any client of [t]'s store, or [None] if none was. *)end