Something went wrong. Try again.
GitHub GraphQL client whose answers are kept in a raw store
Something went wrong. Try again.
34 kB · 897 lines
OCaml
at main
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898module G = Github_query
let json s = Json.Value.of_string_exn slet to_string = Json.Value.to_canonical
let member name j = match j with | Json.Object (ms, _) -> Option.map snd (Json.Value.member_key name ms) | _ -> None
let contains s affix = 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 string_member name j = match member name j with Some (Json.String (s, _)) -> s | _ -> ""
(* A stub transport: [answer ~now ~query] is the response to the request whose GraphQL text is [query], at [now]. It records each request. *)type call = { at : float; query : string; headers : (string * string) list }
let stub ~clock answer = let calls = ref [] in let transport ~headers body = let query = string_member "query" (json body) in let at = Eio.Time.now clock in calls := { at; query; headers } :: !calls; answer ~at ~query in (calls, transport)
let ok ?headers body = Ok (G.response ?headers ~status:200 body)let status ?headers n = Ok (G.response ?headers ~status:n "")let sent r = List.rev !r
let reset_at s = Ptime.to_rfc3339 ~tz_offset_s:0 (Option.get (Ptime.of_float_s s))
let rate_limit ?(remaining = 4999) ?(reset = 3600.) () = Fmt.str {|"rateLimit":{"cost":1,"remaining":%d,"resetAt":"%s"}|} remaining (reset_at reset)
let with_env f = Eio_mock.Backend.run_full @@ fun env -> let clock = env#clock in let store = Cas_store.in_memory ~clock () in f clock store
let client ?retries ?reserve ?principal ~clock store transport = G.v ~clock ~store ?retries ?reserve ?principal ~token:"t0k3n" transport
let get = function | Ok j -> j | Error e -> Alcotest.failf "unexpected error: %a" G.pp_error e
let viewer = G.Template.const "query { viewer { login } }"let snapshot d = Cas_store.Policy.Snapshot d
(* Keys *)
let test_key_stable () = with_env @@ fun clock store -> let _, transport = stub ~clock (fun ~at:_ ~query:_ -> status 500) in let t = client ~clock store transport in let vars (a, b) = [ ("owner", Json.Value.string a); ("n", Json.Value.int b) ] in let vars' (a, b) = List.rev (vars (a, b)) in let q0 = G.Template.v "query($owner: String!, $n: Int!) {\n\ \ repositoryOwner(login: $owner) { login } # who\n\ \ search(query: \"a b\", first: $n) { issueCount }\n\ }" vars in let q1 = G.Template.v "query($owner:String! $n:Int!){repositoryOwner(login:$owner){login}\n\ search(query:\"a b\",first:$n){issueCount}}" vars' in let k0 = G.key t q0 ("ocaml", 3) and k1 = G.key t q1 ("ocaml", 3) in Alcotest.(check string) "layout, comments and member order change no key" (Cas_store.Key.to_hex k0) (Cas_store.Key.to_hex k1); Alcotest.(check string) "spec" {|{"principal":"public","query":"query($owner:String!$n:Int!){repositoryOwner(login:$owner){login}search(query:\"a b\"first:$n){issueCount}}","src":"github.graphql","variables":{"n":3,"owner":"ocaml"}}|} (Cas_store.Key.canonical k0); let k2 = G.key t q0 ("ocaml", 4) in Alcotest.(check (list string)) "variables" [ "variables.n" ] (Cas_store.Key.diff k0 k2); let alice = client ~principal:"alice" ~clock store transport in Alcotest.(check (list string)) "principal" [ "principal" ] (Cas_store.Key.diff k0 (G.key alice q0 ("ocaml", 3)))
let test_normalise () = let n = G.Template.normalise in Alcotest.(check string) "block string kept" {|{a(s:"""x # y""")}|} (n "{ a ( s: \"\"\"x # y\"\"\" ) }"); Alcotest.(check string) "spread" "{...on Foo{a b}}" (n "{ ... on Foo { a, b } }"); Alcotest.(check string) "two strings" {|{a(x:["" ""])}|} (n {|{ a(x: ["", ""]) }|}); let s = "query Q { a # c\n b }" in Alcotest.(check string) "idempotent" (n s) (n (n s))
(* rateLimit *)
let test_rate_limit_stripped () = with_env @@ fun clock store -> let remaining = ref 5000 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> decr remaining; (* Members in another order on every answer. *) if !remaining mod 2 = 0 then Fmt.kstr ok {|{"data":{%s,"viewer":{"login":"x","id":"U1"}}}|} (rate_limit ~remaining:!remaining ()) else Fmt.kstr ok {|{"data":{"viewer":{"id":"U1","login":"x"},%s}}|} (rate_limit ~remaining:!remaining ())) in let t = client ~clock store transport in let a = get (G.query t ~policy:(snapshot "d1") viewer ()) in let b = get (G.query t ~policy:(snapshot "d2") viewer ()) in let sent = sent calls in Alcotest.(check int) "two fetches" 2 (List.length sent); Alcotest.(check string) "rateLimit added" "query{rateLimit{cost remaining resetAt}viewer{login}}" (List.hd sent).query; Alcotest.(check (list (pair string string))) "token sent" [ ("Authorization", "bearer t0k3n") ] (List.filter (fun (k, _) -> k = "Authorization") (List.hd sent).headers); Alcotest.(check string) "rateLimit stripped" {|{"data":{"viewer":{"id":"U1","login":"x"}}}|} (to_string a); Alcotest.(check string) "same answer" (to_string a) (to_string b); let e = Option.get (Cas_store.find store (G.key t viewer ())) in Alcotest.(check (option string)) "one object" (Some {|{"data":{"viewer":{"id":"U1","login":"x"}}}|}) (Cas.Heap.find (Cas_eio.Fs.heap (Cas_store.objects store)) (Cas_store.Entry.digest e)); Alcotest.(check (list string)) "no older observation" [] (List.map (fun (h, _) -> Cas.Hash.to_hex h) (Cas_store.observations store (G.key t viewer ()))); Alcotest.(check (option int)) "budget recorded" (Some 4998) (Option.map fst (G.budget t))
let test_cached_replay () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> Fmt.kstr ok {|{"data":{%s,"viewer":{"login":"x"}}}|} (rate_limit ())) in let t = client ~clock store transport in let a = get (G.query t ~policy:(snapshot "d1") viewer ()) in let b = get (G.query t ~policy:(snapshot "d1") viewer ()) in Alcotest.(check int) "one fetch" 1 (List.length !calls); Alcotest.(check string) "same answer" (to_string a) (to_string b)
let test_errors_not_stored () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n = 1 then ok {|{"errors":[{"message":"Bad credentials"}]}|} else ok {|{"data":{"viewer":{"login":"x"}}}|}) in let t = client ~clock store transport in (match G.query t ~policy:(snapshot "d1") viewer () with | Error (G.Graphql _) -> () | r -> Alcotest.failf "expected GraphQL errors, got %b" (Result.is_ok r)); ignore (get (G.query t ~policy:(snapshot "d1") viewer ())); Alcotest.(check int) "asked again" 2 (List.length !calls)
(* Budget *)
let test_budget_shared () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> Fmt.kstr ok {|{"data":{%s,"viewer":{"login":"x"}}}|} (rate_limit ~remaining:10 ~reset:100. ())) in let a = client ~reserve:20 ~clock store transport in let b = client ~reserve:20 ~clock store transport in ignore (get (G.query a ~policy:(snapshot "d1") viewer ())); Alcotest.(check (option (pair int string))) "b reads a's budget" (Some (10, reset_at 100.)) (Option.map (fun (n, p) -> (n, Ptime.to_rfc3339 ~tz_offset_s:0 p)) (G.budget b)); ignore (get (G.query b ~policy:(snapshot "d2") viewer ())); Alcotest.(check (list (float 0.))) "b waited for the reset" [ 0.; 100. ] (List.map (fun c -> c.at) (sent calls))
(* Backoff *)
let test_retry_after () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n = 1 then status ~headers:[ ("Retry-After", "30") ] 403 else ok {|{"data":{"viewer":{"login":"x"}}}|}) in let t = client ~clock store transport in ignore (get (G.query t ~policy:(snapshot "d1") viewer ())); Alcotest.(check (list (float 0.))) "asked again after 30s" [ 0.; 30. ] (List.map (fun c -> c.at) (sent calls))
let test_rate_limit_reset () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n = 1 then status ~headers: [ ("X-RateLimit-Remaining", "0"); ("X-RateLimit-Reset", "120") ] 403 else ok {|{"data":{"viewer":{"login":"x"}}}|}) in let t = client ~clock store transport in ignore (get (G.query t ~policy:(snapshot "d1") viewer ())); Alcotest.(check (list (float 0.))) "asked again at the reset" [ 0.; 120. ] (List.map (fun c -> c.at) (sent calls)); let n = ref 0 in let _, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; status 403) in let t = client ~clock store transport in (match G.query t ~policy:(snapshot "d2") viewer () with | Error (G.Http (403, _)) -> () | _ -> Alcotest.fail "a plain 403 is an error"); Alcotest.(check int) "not retried" 1 !n
let test_5xx_retry () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n <= 2 then status 500 else ok {|{"data":{"viewer":{"login":"x"}}}|}) in let t = client ~clock store transport in ignore (get (G.query t ~policy:(snapshot "d1") viewer ())); Alcotest.(check (list (float 0.))) "exponential backoff" [ 0.; 1.; 3. ] (List.map (fun c -> c.at) (sent calls)); let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> status 503) in let t = client ~retries:2 ~clock store transport in (match G.query t ~policy:(snapshot "d2") viewer () with | Error (G.Http (503, _)) -> () | _ -> Alcotest.fail "persistent 503"); Alcotest.(check int) "bounded" 3 (List.length !calls)
(* Batches *)
let aliases query = let n = String.length query in let rec go i acc = if i + 1 >= n then acc else if query.[i] = 'a' && query.[i + 1] >= '0' && query.[i + 1] <= '9' then go (i + 1) (acc + 1) else go (i + 1) acc in go 0 0
let test_batch_split () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query -> let k = aliases query in if k > 2 || contains query {|"big"|} then ok {|{"data":null,"errors":[{"message":"Resource limits for this query exceeded."}]}|} else let members = List.init k (fun i -> Fmt.str {|"a%d":{"n":%d}|} i i) in Fmt.kstr ok {|{"data":{%s}}|} (String.concat "," members)) in let t = client ~clock store transport in let field x = Fmt.str "f(x:%s){n}" (G.Template.quote x) in let r = G.batch t ~policy:(snapshot "d1") field [ "1"; "2"; "3"; "4"; "big" ] in Alcotest.(check (list string)) "answers in order" [ "1"; "2"; "3"; "4"; "big" ] (List.map fst r); let ok_count = List.length (List.filter (fun (_, r) -> Result.is_ok r) r) in Alcotest.(check int) "four answered" 4 ok_count; (match List.assoc "big" r with | Error G.Too_large -> () | _ -> Alcotest.fail "one selection still too large"); Alcotest.(check (list int)) "halved down to one" [ 5; 2; 3; 1; 2; 1; 1 ] (List.map (fun c -> aliases c.query) (sent calls))
(* GitHub can refuse some selections of a query for its resource limits and answer the others: the errors name the refused aliases in their paths. *)let test_batch_partial_limits () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query -> let k = aliases query in if k = 4 then ok {|{"data":{"a0":{"n":0},"a1":{"n":1},"a2":null,"a3":null},"errors":[{"path":["a2"],"message":"Resource limits for this query exceeded."},{"path":["a3"],"message":"Resource limits for this query exceeded."}]}|} else let members = List.init k (fun i -> Fmt.str {|"a%d":{"n":%d}|} i (i + 2)) in Fmt.kstr ok {|{"data":{%s}}|} (String.concat "," members)) in let t = client ~clock store transport in let field x = Fmt.str "f(x:%s){n}" (G.Template.quote x) in let r = G.batch t ~policy:(snapshot "d1") field [ "0"; "1"; "2"; "3" ] in Alcotest.(check (list (pair string string))) "every alias answered" [ ("0", {|{"n":0}|}); ("1", {|{"n":1}|}); ("2", {|{"n":2}|}); ("3", {|{"n":3}|}); ] (List.map (fun (x, r) -> (x, to_string (get r))) r); (* A client that halves the whole batch sends [4; 2; 2]. *) Alcotest.(check (list int)) "only the refused aliases asked again" [ 4; 2 ] (List.map (fun c -> aliases c.query) (sent calls))
(* An answer with an error other than NOT_FOUND is not kept: the selection is asked again under the same policy. *)let test_batch_error_not_stored () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n = 1 then ok {|{"data":{"a0":null},"errors":[{"path":["a0"],"message":"Something went wrong while executing your query."}]}|} else ok {|{"data":{"a0":{"n":1}}}|}) in let t = client ~clock store transport in let field x = Fmt.str "f(x:%s){n}" (G.Template.quote x) in let ask () = List.assoc "x" (G.batch t ~policy:(snapshot "d1") field [ "x" ]) in (match ask () with | Error (G.Graphql _) -> () | r -> Alcotest.failf "expected an error, got %b" (Result.is_ok r)); Alcotest.(check string) "asked again" {|{"n":1}|} (to_string (get (ask ()))); Alcotest.(check int) "two fetches" 2 (List.length !calls); let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> ok {|{"data":{"a0":null},"errors":[{"type":"NOT_FOUND","path":["a0"],"message":"Could not resolve"}]}|}) in let t = client ~clock store transport in let ask () = List.assoc "y" (G.batch t ~policy:(snapshot "d1") field [ "y" ]) in ignore (ask ()); ignore (ask ()); Alcotest.(check int) "NOT_FOUND is kept" 1 (List.length !calls)
(* Probes *)
let probe_answer = {|{"data":{"a0":{"id":"R_1","nameWithOwner":"ocaml/dune","isPrivate":false,"pushedAt":"2026-10-07T10:00:00Z","pullRequests":{"nodes":[{"updatedAt":"2026-10-07T09:00:00Z"}]},"issues":{"nodes":[]}},"a1":null},"errors":[{"type":"NOT_FOUND","path":["a1"],"message":"Could not resolve to a Repository"}]}|}
let test_probe () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> ok probe_answer) in let t = client ~clock store transport in let r = G.Probe.repos t ~policy:(Cas_store.Policy.Max_age (Ptime.Span.of_int_s 600)) [ ("ocaml", "dune"); ("ocaml", "gone") ] in Alcotest.(check int) "one query" 1 (List.length !calls); Alcotest.(check bool) "no nested pages" true (contains (List.hd (sent calls)).query "pullRequests(first:1 orderBy:{field:UPDATED_AT direction:DESC})"); (match List.assoc ("ocaml", "dune") r with | Ok (Some repo) -> Alcotest.(check string) "id" "R_1" (G.Probe.id repo); Alcotest.(check string) "name" "ocaml/dune" (G.Probe.name repo); Alcotest.(check (option string)) "newest pull request" (Some "2026-10-07T09:00:00Z") (G.Probe.newest_pull_request repo); Alcotest.(check (option string)) "no issue" None (G.Probe.newest_issue repo) | _ -> Alcotest.fail "ocaml/dune"); match List.assoc ("ocaml", "gone") r with | Ok None -> () | _ -> Alcotest.fail "ocaml/gone is unknown"
let test_probe_policy () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> ok {|{"data":{"items":[1]}}|}) in let t = client ~clock store transport in let items = G.Template.const "{ items }" in let ask mark = ignore (get (G.query t ~policy:(Cas_store.Policy.Probe mark) items ())) in ask "2026-10-01T00:00:00Z"; ask "2026-10-01T00:00:00Z"; Alcotest.(check int) "unchanged probe, no fetch" 1 (List.length !calls); ask "2026-10-02T00:00:00Z"; Alcotest.(check int) "later probe, fetched" 2 (List.length !calls); ask "2026-10-02T00:00:00Z"; Alcotest.(check int) "then fresh again" 2 (List.length !calls)
(* REST *)
module R = G.Rest
type rest_call = { r_at : float; url : string; r_headers : (string * string) list;}
let rest_stub ~clock answer = let calls = ref [] in let transport ~headers url = let r_at = Eio.Time.now clock in calls := { r_at; url; r_headers = headers } :: !calls; answer ~at:r_at ~url ~headers in (calls, transport)
let rest ?retries ?reserve ~clock store transport = R.v ~clock ~store ?retries ?reserve ~token:"t0k3n" transport
let api = "https://api.github.com"
let test_links () = Alcotest.(check (list (pair string (list string)))) "GitHub's form" [ (api ^ "/repositories/1/issues?page=2", [ "next" ]); (api ^ "/repositories/1/issues?page=5", [ "last" ]); ] (R.links ("<" ^ api ^ "/repositories/1/issues?page=2>; rel=\"next\", <" ^ api ^ "/repositories/1/issues?page=5>; rel=\"last\"")); (* RFC 8288 Section 3.3: rel holds space-separated types, case-insensitive; only its first occurrence counts. A token value needs no quotes. *) Alcotest.(check (list (pair string (list string)))) "RFC 8288 forms" [ ("/a", [ "prev"; "next" ]); ("/b", [ "last" ]); ("/c", []) ] (R.links {|</a>; title="x, y"; rel="PREV next"; rel=first, </b>;rel=last,junk, </c>|}); Alcotest.(check (option string)) "next" (Some "/a") (R.next_page {|</b>; rel="last", </a>; rel="next"|}); Alcotest.(check (option string)) "no next" None (R.next_page {|</b>; rel=last|}); Alcotest.(check (option string)) "empty" None (R.next_page "")
let link n = Fmt.str "<%s/orgs/o/repos?page=%d>; rel=\"next\"" api n
let test_rest_pages () = with_env @@ fun clock store -> let calls, transport = rest_stub ~clock (fun ~at:_ ~url ~headers:_ -> let page = match String.index_opt url '=' with | None -> 1 | Some i -> int_of_string (String.sub url (i + 1) (String.length url - i - 1)) in let headers = [ ("X-RateLimit-Remaining", string_of_int (5000 - page)); ("X-RateLimit-Reset", "3600"); ("X-RateLimit-Resource", "core"); ] @ if page < 3 then [ ("Link", link (page + 1)) ] else [] in Fmt.kstr (ok ~headers) {|[{"page":%d}]|} page) in let t = rest ~clock store transport in let policy = snapshot "d1" in let bodies = function | Ok l -> List.map to_string l | Error e -> Alcotest.failf "unexpected error: %a" G.pp_error e in Alcotest.(check (list string)) "three pages" [ {|[{"page":1}]|}; {|[{"page":2}]|}; {|[{"page":3}]|} ] (bodies (R.pages t ~policy "/orgs/o/repos")); Alcotest.(check (list string)) "urls" [ api ^ "/orgs/o/repos"; api ^ "/orgs/o/repos?page=2"; api ^ "/orgs/o/repos?page=3"; ] (List.map (fun c -> c.url) (sent calls)); let h = (List.hd (sent calls)).r_headers in Alcotest.(check (option string)) "token sent" (Some "Bearer t0k3n") (List.assoc_opt "Authorization" h); Alcotest.(check (option string)) "media type" (Some "application/vnd.github+json") (List.assoc_opt "Accept" h); Alcotest.(check (option int)) "core budget recorded" (Some 4997) (Option.map fst (R.budget t)); Alcotest.(check (option int)) "graphql budget untouched" None (Option.map fst (G.budget (client ~clock store transport))); Alcotest.(check (list string)) "replayed from the store, links included" [ {|[{"page":1}]|}; {|[{"page":2}]|}; {|[{"page":3}]|} ] (bodies (R.pages t ~policy "/orgs/o/repos")); Alcotest.(check int) "no new fetch" 3 (List.length !calls); Alcotest.(check (list string)) "limit" [ {|[{"page":1}]|}; {|[{"page":2}]|} ] (bodies (R.pages t ~policy:(snapshot "d2") ~limit:2 "/orgs/o/repos")); Alcotest.(check int) "two more fetches" 5 (List.length !calls); Alcotest.(check string) "key spec" {|{"principal":"public","src":"github.rest","url":"https://api.github.com/orgs/o/repos"}|} (Cas_store.Key.canonical (R.key t "/orgs/o/repos")); Alcotest.(check string) "a path and its URL are one key" (Cas_store.Key.to_hex (R.key t "/orgs/o/repos")) (Cas_store.Key.to_hex (R.key t (api ^ "/orgs/o/repos")))
let test_rest_foreign_link () = with_env @@ fun clock store -> let calls, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers:_ -> ok ~headers:[ ("Link", {|<https://evil.example/x>; rel="next"|}) ] "[]") in let t = rest ~clock store transport in (match R.pages t ~policy:(snapshot "d1") "/x" with | Error (G.Transport _) -> () | _ -> Alcotest.fail "a next link off the endpoint is an error"); Alcotest.(check int) "never sent" 1 (List.length !calls); match R.get t ~policy:(snapshot "d1") "https://evil.example/x" with | exception Invalid_argument _ -> () | _ -> Alcotest.fail "a URL off the endpoint is refused"
let test_rest_revalidate () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers -> incr n; match List.assoc_opt "If-None-Match" headers with | Some {|"v1"|} -> status ~headers:[ ("ETag", {|"v1"|}) ] 304 | _ -> ok ~headers:[ ("ETag", {|"v1"|}) ] {|{"login":"x"}|}) in let t = rest ~clock store transport in let policy = Cas_store.Policy.Revalidate (Ptime.Span.of_int_s 60) in let a = get (R.get t ~policy "/users/x") in Eio.Time.sleep clock 120.; let b = get (R.get t ~policy "/users/x") in Alcotest.(check int) "asked twice" 2 (List.length !calls); Alcotest.(check (option string)) "conditional" (Some {|"v1"|}) (List.assoc_opt "If-None-Match" (List.nth (sent calls) 1).r_headers); Alcotest.(check string) "kept" (to_string a) (to_string b); Alcotest.(check string) "body" {|{"login":"x"}|} (to_string b)
let test_rest_gone () = with_env @@ fun clock store -> let calls, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers:_ -> status 404) in let t = rest ~clock store transport in let policy = Cas_store.Policy.Max_age (Ptime.Span.of_int_s 600) in let ask () = match R.get t ~policy "/repos/o/gone" with | Error (G.Http (404, _)) -> () | _ -> Alcotest.fail "404" in ask (); ask (); Alcotest.(check int) "gone is stored" 1 (List.length !calls)
let test_rest_rate_limit () = with_env @@ fun clock store -> let n = ref 0 in let calls, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers:_ -> incr n; match !n with | 1 -> status ~headers: [ ("X-RateLimit-Remaining", "0"); ("X-RateLimit-Reset", "120"); ("X-RateLimit-Resource", "search"); ] 403 | 2 -> status ~headers:[ ("Retry-After", "30") ] 429 | _ -> ok {|{"total_count":0,"items":[]}|}) in let t = rest ~clock store transport in ignore (get (R.get t ~policy:(snapshot "d1") "/search/issues?q=x")); Alcotest.(check (list (float 0.))) "reset, then Retry-After" [ 0.; 120.; 150. ] (List.map (fun c -> c.r_at) (sent calls)); Alcotest.(check (option int)) "search budget paused" (Some 0) (Option.map fst (R.budget ~resource:"search" t)); let n = ref 0 in let _, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers:_ -> incr n; status 403) in let t = rest ~clock store transport in (match R.get t ~policy:(snapshot "d1") "/repos/o/private" with | Error (G.Http (403, _)) -> () | _ -> Alcotest.fail "a plain 403 is an error"); Alcotest.(check int) "not retried" 1 !n
let test_rest_budget_shared () = with_env @@ fun clock store -> let calls, transport = rest_stub ~clock (fun ~at:_ ~url:_ ~headers:_ -> ok ~headers: [ ("X-RateLimit-Remaining", "10"); ("X-RateLimit-Reset", "100") ] "{}") in let a = rest ~reserve:20 ~clock store transport in let b = rest ~reserve:20 ~clock store transport in ignore (get (R.get a ~policy:(snapshot "d1") "/a")); ignore (get (R.get b ~policy:(snapshot "d1") "/b")); Alcotest.(check (list (float 0.))) "b waited for the reset" [ 0.; 100. ] (List.map (fun c -> c.r_at) (sent calls))
(* Mutations *)
let set_title = G.Template.v "mutation($id: ID!, $title: String!) { updateIssue(input: {id: $id, title: \ $title}) { issue { title } } }" (fun title -> [ ("id", Json.Value.string "I_1"); ("title", Json.Value.string title) ])
let updated = ok {|{"data":{"updateIssue":{"issue":{"title":"x"}}}}|}
(* A mutation is sent every time, never answered from the store; a rate limit is waited out, while a 5xx is not sent again. *)let test_mutate () = with_env @@ fun clock store -> let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> updated) in let t = client ~clock store transport in ignore (get (G.mutate t set_title "x")); ignore (get (G.mutate t set_title "x")); Alcotest.(check int) "sent twice" 2 (List.length !calls); let n = ref 0 in let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> incr n; if !n = 1 then status ~headers:[ ("Retry-After", "30") ] 403 else updated) in let t = client ~clock store transport in ignore (get (G.mutate t set_title "x")); Alcotest.(check (list (float 0.))) "sent again after 30s" [ 0.; 30. ] (List.map (fun c -> c.at) (sent calls)); let calls, transport = stub ~clock (fun ~at:_ ~query:_ -> status 502) in let t = client ~clock store transport in (match G.mutate t set_title "x" with | Error _ -> () | Ok _ -> Alcotest.fail "a 502 is an error"); Alcotest.(check int) "not sent again" 1 (List.length !calls)
(* Projects *)
let project_answer = {|{"data":{"repositoryOwner":{"projectV2":{"id":"P_1","title":"Objectives", "fields":{"nodes":[ {"id":"F_t","name":"Title","dataType":"TITLE"}, {"id":"F_f","name":"Funding source","dataType":"SINGLE_SELECT", "options":[{"id":"O_e","name":"Europe"},{"id":"O_o","name":"Europe ORCHIDE"}]}, {"id":"F_s","name":"Starts","dataType":"DATE"}, {"id":"F_n","name":"FTE","dataType":"NUMBER"}, {"id":"F_i","name":"Iteration","dataType":"ITERATION", "configuration":{"iterations":[{"id":"I_2","title":"Q2"}], "completedIterations":[{"id":"I_1","title":"Q1"}]}}, {}]}}}}}|}
(* Each request's query text and variables. *)let bodies answer = let calls = ref [] in let transport ~headers:_ body = let j = json body in calls := (string_member "query" j, member "variables" j) :: !calls; answer (string_member "query" j) in (calls, transport)
let project ~clock store = let calls, transport = bodies (fun q -> if contains q "mutation" then ok {|{"data":{"u0":{"projectV2Item":{"id":"PVTI_1"}}}}|} else ok project_answer) in let t = client ~clock store transport in (calls, t, get (G.Project.get t ~policy:(snapshot "d1") ~owner:"acme" 27))
let test_project_fields () = with_env @@ fun clock store -> let _, _, p = project ~clock store in Alcotest.(check string) "id" "P_1" (G.Project.id p); Alcotest.(check (list string)) "fields" [ "Title"; "Funding source"; "Starts"; "FTE"; "Iteration" ] (List.map (fun (f : G.Project.field) -> f.name) (G.Project.fields p)); (match G.Project.field p "funding SOURCE" with | Some { kind = Single_select l; _ } -> Alcotest.(check (list (pair string string))) "options" [ ("Europe", "O_e"); ("Europe ORCHIDE", "O_o") ] l | _ -> Alcotest.fail "no single-select field up to case"); match G.Project.field p "Iteration" with | Some { kind = Iteration l; _ } -> Alcotest.(check (list string)) "iterations" [ "Q2"; "Q1" ] (List.map fst l) | _ -> Alcotest.fail "no iteration field"
let variable k = function | Some v -> Option.map to_string (member k v) | None -> None
(* An archived item is unarchived first and archived again last, in the one mutation; an option is sent as its id, a clear as no value. *)let test_project_set () = with_env @@ fun clock store -> let calls, t, p = project ~clock store in calls := []; (match G.Project.set t p ~item:"PVTI_1" ~archived:true [ ("Funding source", Some (`Option "Europe ORCHIDE")); ("Starts", None) ] with | Ok () -> () | Error e -> Alcotest.failf "%a" G.pp_error e); match sent calls with | [ (q, vars) ] -> let at affix = let n = String.length q and m = String.length affix in let rec go i = if i + m > n then -1 else if String.sub q i m = affix then i else go (i + 1) in go 0 in Alcotest.(check bool) "unarchive, update, clear, archive" true (0 <= at "unarchive:" && at "unarchiveProjectV2Item" < at "updateProjectV2ItemFieldValue" && at "updateProjectV2ItemFieldValue" < at "clearProjectV2ItemFieldValue" && at "clearProjectV2ItemFieldValue" < at "archive:archiveProjectV2Item" ); Alcotest.(check (option string)) "option id" (Some {|{"singleSelectOptionId":"O_o"}|}) (variable "v0" vars); Alcotest.(check (option string)) "field" (Some {|"F_f"|}) (variable "f0" vars); Alcotest.(check (option string)) "cleared" (Some {|"F_s"|}) (variable "f1" vars); Alcotest.(check (option string)) "project" (Some {|"P_1"|}) (variable "project" vars) | l -> Alcotest.failf "%d requests, not one" (List.length l)
(* An unknown field or option, or a value of another kind, sends nothing. *)let test_project_invalid () = with_env @@ fun clock store -> let calls, t, p = project ~clock store in calls := []; let invalid name u = match G.Project.set t p ~item:"PVTI_1" [ u ] with | Error (G.Invalid _) -> () | _ -> Alcotest.failf "%s: not refused" name in invalid "field" ("Nope", Some (`Text "x")); invalid "option" ("Funding source", Some (`Option "Mars")); invalid "kind" ("Starts", Some (`Number 1.)); invalid "computed" ("Title", Some (`Text "x")); Alcotest.(check int) "nothing sent" 0 (List.length !calls)
let test_project_items () = with_env @@ fun clock store -> let _, transport = bodies (fun q -> if contains q "items(" then ok {|{"data":{"repositoryOwner":{"projectV2":{"items":{ "pageInfo":{"hasNextPage":false,"endCursor":null}, "nodes":[{"id":"PVTI_1","isArchived":false, "content":{"id":"I_663","number":663}, "fieldValues":{"nodes":[ {"name":"Europe","field":{"name":"Funding source"}}, {"date":"2024-02-07","field":{"name":"Starts"}}, {"number":2.5,"field":{"name":"FTE"}}, {"title":"Q1","field":{"name":"Iteration"}}, {}]}}]}}}}}|} else ok project_answer) in let t = client ~clock store transport in let p = get (G.Project.get t ~policy:(snapshot "d1") ~owner:"acme" 27) in match G.Project.items t ~policy:(snapshot "d1") p with | Ok [ i ] -> Alcotest.(check string) "item" "PVTI_1" i.item; Alcotest.(check bool) "values" true (i.values = [ ("Funding source", `Option "Europe"); ("Starts", `Date "2024-02-07"); ("FTE", `Number 2.5); ("Iteration", `Iteration "Q1"); ]) | Ok l -> Alcotest.failf "%d items, not one" (List.length l) | Error e -> Alcotest.failf "%a" G.pp_error e
let suite = ( "github_query", [ Alcotest.test_case "key is stable" `Quick test_key_stable; Alcotest.test_case "normalise" `Quick test_normalise; Alcotest.test_case "rateLimit added and stripped" `Quick test_rate_limit_stripped; Alcotest.test_case "cached replay" `Quick test_cached_replay; Alcotest.test_case "errors are not stored" `Quick test_errors_not_stored; Alcotest.test_case "budget shared by two clients" `Quick test_budget_shared; Alcotest.test_case "Retry-After" `Quick test_retry_after; Alcotest.test_case "X-RateLimit-Reset" `Quick test_rate_limit_reset; Alcotest.test_case "5xx retried" `Quick test_5xx_retry; Alcotest.test_case "batch split on resource limits" `Quick test_batch_split; Alcotest.test_case "batch keeps the aliases answered" `Quick test_batch_partial_limits; Alcotest.test_case "batch errors are not stored" `Quick test_batch_error_not_stored; Alcotest.test_case "probe" `Quick test_probe; Alcotest.test_case "probe policy" `Quick test_probe_policy; Alcotest.test_case "Link header" `Quick test_links; Alcotest.test_case "REST pages" `Quick test_rest_pages; Alcotest.test_case "REST next link off the endpoint" `Quick test_rest_foreign_link; Alcotest.test_case "REST revalidation" `Quick test_rest_revalidate; Alcotest.test_case "REST gone" `Quick test_rest_gone; Alcotest.test_case "REST rate limits" `Quick test_rest_rate_limit; Alcotest.test_case "REST budget shared" `Quick test_rest_budget_shared; Alcotest.test_case "mutations" `Quick test_mutate; Alcotest.test_case "project fields" `Quick test_project_fields; Alcotest.test_case "project set" `Quick test_project_set; Alcotest.test_case "project input refused" `Quick test_project_invalid; Alcotest.test_case "project items" `Quick test_project_items; ] )