From 6c7374d7915f5acae27fcca09e8dc70b2fec79f0 Mon Sep 17 00:00:00 2001 From: Ray Miller Date: Wed, 25 Jun 2025 16:53:37 +0000 Subject: [PATCH] Initial check-in. --- README.md | 30 +++++++++++ anarres/gitlab.scm | 122 +++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+) create mode 100644 README.md create mode 100644 anarres/gitlab.scm diff --git a/README.md b/README.md new file mode 100644 index 0000000..091c1b3 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +# Guile Anarres + +## Why Anarres? + +This is the name of the home world of the main character in Ursula K Le Guin's +book "The Dispossessed". + +Google Gemini says: + +Anarres from Ursula K. Le Guin's "The Dispossessed" is a fantastic name for a +general-purpose Guile Scheme library. It perfectly encapsulates the spirit of +what a foundational, general-purpose library should be. It evokes: + +* Self-Sufficiency and Independence: Like the planet, your library can provide + the core tools needed to build and function, reducing external dependencies. +* Fundamental Principles: Anarres is built on a philosophy of shared resources + and direct action, mirroring a library that offers fundamental, robust + primitives and utilities. +* Flexibility and Adaptability: The Urrasti found Anarres an "unappealing" + world, yet its inhabitants thrived through ingenuity and adaptation—qualities + vital for versatile code. +* Collaborative Spirit: The Odonian society on Anarres emphasizes collective + good and shared contribution, resonating with the open-source nature of Scheme + and community-driven development. +* Efficiency and Practicality: Stripped of unnecessary complexities, Anarres + represents a focus on what is essential and effective. + +Using Anarres as your library's name immediately signals a connection to these +themes, suggesting a collection of tools that are fundamental, reliable, and +designed to empower users to build freely and effectively. diff --git a/anarres/gitlab.scm b/anarres/gitlab.scm new file mode 100644 index 0000000..06271f7 --- /dev/null +++ b/anarres/gitlab.scm @@ -0,0 +1,122 @@ +(define-module (anarres gitlab) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 match) + #:use-module (ice-9 optargs) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:use-module (web client) + #:use-module (web response) + #:use-module (web uri) + #:export (api-error? + api-error-endpoint + api-error-status-code + + gitlab-client? + gitlab-client-base-url + set-gitlab-client-base-url! + gitlab-client-token + set-gitlab-client-token!)) + +(define-exception-type &api-error &external-error + make-api-error + api-error? + (endpoint api-error-endpoint) + (status-code api-error-status-code) + (body api-error-body)) + +(define-record-type + (make-gitlab-client base-url token) + gitlab-client? + (base-url gitlab-client-base-url set-gitlab-client-base-url!) + (token gitlab-client-token set-gitlab-client-token!)) + +(define*-public (gitlab-client #:key (base-url "https://gitlab.com/api/v4") (token (getenv "GITLAB_TOKEN"))) + (make-gitlab-client base-url (string-trim-both token))) + +(define (encode-query alist) + "Encode an association list as a query string. The keys should be symbols and the +values strings or #f, in which case the parameter is skipped." + (fold (match-lambda* + (((k . v) s) + (if v + (string-append s + (if (zero? (string-length s)) "" "&") + (if (symbol? k) (symbol->string k) k) + "=" + (uri-encode v)) + s))) + "" + alist)) + +(define forward-slash (char-set #\/)) + +(define (strip-leading-slash s) + (string-trim s forward-slash)) + +(define (strip-trailing-slash s) + (string-trim-right s forward-slash)) + +(define (json-response? res) + (eq? 'application/json (car (response-content-type res)))) + +(define (json-ok? res) + (and (= 200 (response-code res)) + (json-response? res))) + +(define* (api-call client method endpoint #:key query payload return-headers? (ok? json-ok?) (post-proc identity)) + (let* ((base-url (gitlab-client-base-url client)) + (token (gitlab-client-token client)) + (res body (method (if query + (string-append base-url endpoint "?" (encode-query query)) + (string-append base-url endpoint)) + #:headers `((private-token . ,token) + (content-type . (application/json (charset . "utf-8")))) + #:body (if payload (scm->json payload) #f))) + (body (if (json-response? res) (call-with-input-bytevector body json->scm) body))) + (if (ok? res) + (let ((body (post-proc body))) + (if return-headers? + (values body (response-headers res)) + body)) + (raise-exception (make-api-error endpoint (response-code res) body))))) + +(define (ensure-per-page params page-size) + (if (assoc 'per_page params) + params + (alist-cons 'per_page page-size params))) + +(define* (get-paged client endpoint #:key (query '()) (post-proc identity)) + (let ((query-params (ensure-per-page query "100"))) + (define (get-pages accum next-page) + (let* ((body headers (api-call client http-get endpoint #:query (alist-cons 'page next-page query-params) #:post-proc post-proc #:return-headers? #t)) + (accum (append accum body)) + (next-page (assoc-ref headers 'x-next-page))) + (if (and (string? next-page) (> (string-length next-page) 0)) + (get-pages accum next-page) + accum))) + (get-pages '() #f))) + +(define-public (list-merge-requests client params) + (get-paged client "/merge_requests" #:query params #:post-proc vector->list)) + +(define-public (find-group client group-path) + (let* ((group-path (strip-leading-slash group-path)) + (groups (api-call client http-get "/groups" #:query `((search . ,group-path)) #:post-proc vector->list)) + (group (find (lambda (g) (string=? (assoc-ref g "full_path") group-path)) groups))) + (or group (error (format #f "find-group: group ~a not found" group-path))))) + +(define-public get-group-id (compose (cut assoc-ref <> "id") find-group)) + +(define-public (find-project client project-path) + (let* ((project-path (strip-leading-slash project-path)) + (group-id (get-group-id client (dirname project-path))) + (project-name (basename project-path)) + (projects (api-call client http-get (format #f "/groups/~a/projects" group-id) #:query `((search . ,project-name)) #:post-proc vector->list)) + (project (find (lambda (p) (string=? (assoc-ref p "path_with_namespace") project-path)) projects))) + (or project (error (format #f "find-project: project ~a not found" project-path))))) + +(define-public get-project-id (compose (cut assoc-ref <> "id") find-project))