Initial check-in.

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.

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 <gitlab>
+  (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))