Package: guix-patches;
Reported by: Ludovic Courtès <ludo <at> gnu.org>
Date: Fri, 23 May 2025 19:54:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
View this message in rfc822 format
From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> To: Ludovic Courtès <ludo <at> gnu.org> Cc: 78568 <at> debbugs.gnu.org Subject: [bug#78568] [PATCH 5/5] teams: Add ‘sync-codeberg-teams’ action. Date: Tue, 27 May 2025 17:32:26 +0900
Hi,
Ludovic Courtès <ludo <at> gnu.org> writes:
> * etc/teams.scm (<forgejo-team>): New JSON mapping.
> (unit-map->json, json->unit-map): New procedures.
> (%default-forgejo-team-units, %default-forgejo-team-unit-map)
> (%codeberg-organization): New variables.
> (codeberg-url, forgejo-http-headers): New procedures.
> (&forgejo-error): New record type.
> (process-url-components, define-forgejo-request): New macros.
> (organization-teams, create-team, add-team-member)
> (team->forgejo-team, synchronize-team, synchronize-teams): New
> procedures.
> (main): Add ‘sync-codeberg-teams’ action.
That's a sizable amount of code! Maybe we should embark on a
guile-codeberg project at some point to have a library for interacting
with its API.
> Change-Id: I6b1f437a3407bc2d44965519990deb524afa9528
> ---
> etc/teams.scm | 252 +++++++++++++++++++++++++++++++++++++++++++++++++-
> 1 file changed, 250 insertions(+), 2 deletions(-)
>
> diff --git a/etc/teams.scm b/etc/teams.scm
> index e881e916ab..08ca891e0d 100755
> --- a/etc/teams.scm
> +++ b/etc/teams.scm
> @@ -41,12 +41,21 @@
> (use-modules (srfi srfi-1)
> (srfi srfi-9)
> (srfi srfi-26)
> + (srfi srfi-34)
> + (srfi srfi-35)
> + (srfi srfi-71)
> (ice-9 format)
> (ice-9 regex)
> (ice-9 match)
> (ice-9 rdelim)
> (guix ui)
> - (git))
> + (git)
> + (json)
> + (web client)
> + (web request)
> + (web response)
> + (rnrs bytevectors)
> + (guix base64))
>
> (define-record-type <regexp*>
> (%make-regexp* pat flag rx)
> @@ -116,6 +125,241 @@ (define-syntax-rule (define-member person teams ...)
> team (cons p (team-members team)))))
> (quote (teams ...)))))
>
> +
> +;;;
> +;;; Forgejo support.
> +;;;
> +
> +;; Forgejo team. This corresponds to both the 'Team' and 'CreateTeamOption'
> +;; structures in Forgejo.
> +(define-json-mapping <forgejo-team>
> + forgejo-team forgejo-team?
> + json->forgejo-team <=> forgejo-team->json
> + (name forgejo-team-name)
> + (id forgejo-team-id) ;integer
> + (description forgejo-team-description)
> + (all-repositories? forgejo-team-all-repositories?
> + "includes_all_repositories")
> + (can-create-org-repository? forgejo-team-can-create-org-repository?
> + "can_create_org_repo")
> + (permission forgejo-team-permission
> + "permission" string->symbol symbol->string)
> + ;; A 'units' field exists but is deprecated in favor of 'units_map'.
> + (unit-map forgejo-team-unit-map
> + "units_map" json->unit-map unit-map->json))
> +
> +(define (unit-map->json lst)
> + (map (match-lambda
> + ((unit . permission)
> + (cons unit (symbol->string permission))))
> + lst))
> +
> +(define (json->unit-map lst)
> + (map (match-lambda
> + ((unit . permission)
> + (cons unit (string->symbol permission))))
> + lst))
> +
> +(define %default-forgejo-team-units
> + '("repo.code" "repo.issues" "repo.pulls" "repo.releases"
> + "repo.wiki" "repo.ext_wiki" "repo.ext_issues" "repo.projects"
> + "repo.packages" "repo.actions"))
> +
> +(define %default-forgejo-team-unit-map
> + ;; Everything (including "repo.code") is read-only by default, except a few
> + ;; units.
> + (map (match-lambda
> + ("repo.pulls" (cons "repo.pulls" 'write))
> + ("repo.issues" (cons "repo.issues" 'write))
> + ("repo.wiki" (cons "repo.wiki" 'write))
> + (unit (cons unit 'read)))
> + %default-forgejo-team-units))
>
> +(define (forgejo-http-headers token)
> + "Return the HTTP headers for basic authorization with TOKEN."
> + `((content-type . (application/json (charset . "UTF-8")))
> + ;; The "Auth Basic" scheme needs a base64-encoded colon-separated user and
> + ;; token values. Forgejo doesn't seem to care for the user part but the
> + ;; colon seems to be necessary for the token value to get extracted.
> + (authorization . (basic . ,(base64-encode
> + (string->utf8
> + (string-append ":" token)))))))
> +
> +;; Error with a Forgejo request.
> +(define-condition-type &forgejo-error &error
> + forgejo-error?
> + (url forgejo-error-url)
> + (method forgejo-error-method)
> + (response forgejo-error-response))
> +
> +(define %codeberg-organization
> + ;; Name of the organization at codeberg.org.
> + "guix")
> +
> +(define* (codeberg-url items #:key (parameters '()))
> + "Construct a Codeberg API URL with the path components ITEMS and query
> +PARAMETERS."
> + (define query
> + (match parameters
> + (() "")
> + (((keys . values) ...)
> + (string-append "?" (string-join
> + (map (lambda (key value)
> + (string-append key "=" value)) ;XXX: hackish
Why is the above considered hackish? You could use cut to simplify
out the lambda.
[...]
> +(define* (synchronize-team token team
> + #:key
> + (current-teams
> + (organization-teams token
> + %codeberg-organization))
> + (log-port (current-error-port)))
> + "Synchronize TEAM, a <team> record, so that its metadata and list of members
> +are accurate on Codeberg. Lookup team IDs among CURRENT-TEAMS."
> + (let ((forgejo-team
> + (find (let ((name (team-id->forgejo-id (team-id team))))
> + (lambda (candidate)
> + (string=? (forgejo-team-name candidate) name)))
> + current-teams)))
> + (when forgejo-team
> + ;; Delete the previously-created team.
> + (format log-port "team '~a' already exists; deleting it~%"
> + (forgejo-team-name forgejo-team))
> + (delete-team token forgejo-team))
It'd be nicer to update the team, maybe lighter for the endpoint? What
was the rationale for going with this more brute force approach? Was
the API complex to use, or not available for this?
> + ;; Create the team.
> + (let ((forgejo-team
> + (create-team token %codeberg-organization
> + (or forgejo-team
> + (team->forgejo-team team)))))
> + (format log-port "created team '~a'~%"
> + (forgejo-team-name forgejo-team))
> + (let ((members (filter-map person-codeberg-account
> + (team-members team))))
> + (for-each (lambda (member)
> + (add-team-member token forgejo-team member))
> + members)
> + (format log-port "added ~a members to team '~a'~%"
> + (length members)
> + (forgejo-team-name forgejo-team))
> + forgejo-team))))
> +
> +(define (synchronize-teams token)
> + "Push all the existing teams on Codeberg."
> + (let ((teams (sort-teams
> + (hash-map->list (lambda (_ value) value) %teams))))
> + (format (current-error-port)
> + "creating ~a teams in the '~a' organization at Codeberg...~%"
> + (length teams) %codeberg-organization)
A bit odd to use current-error-port for this message here; I think the
other usages of current-error-port were motivated by the fact that the
other actions of the script were producing copy-pastable output, so you
could redirect the errors somewhere to avoid corrupting it? But that's
not an issue here, so I think we should use current-output-port.
> +
> + ;; Arrange to compute the list of existing teams once and for all.
> + (for-each (let ((teams (organization-teams token
> + %codeberg-organization)))
> + (lambda (team)
> + (synchronize-team token team
> + #:current-teams teams)))
> + teams)))
Interesting technique.
Apart from having preferred a more surgical approach to update the teams
(assuming that would be less overhead for Codeberg), this LGTM.
--
Thanks,
Maxim
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.