[bug#78568,5/5] teams: Add ‘sync-codeberg-teams’ action.

* 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.

Change-Id: I6b1f437a3407bc2d44965519990deb524afa9528
---
 etc/teams.scm | 252 +++++++++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 250 insertions(+), 2 deletions(-)
  

Hi,

Ludovic Courtès <ludo@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.
  

Hi Maxim,

Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:

> 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.

Agreed.

>> +(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.

Because it could in theory construct an invalid URL.  It’s OK here
because we can assume that KEY and VALUE don’t contain things like
ampersands, question marks, etc.

>> +(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?

Updating in general is tricky: you would need to check every aspect of
the team, compute the diff between the current list of members and the
target list of members, etc.  It’s more code and it’s hard to get it
right.

Since the remove/recreate approach doesn’t have undesirable side effects
AFAICS, and since it’s much easier and more reliable, I went for it.

>> +    (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.

It’s in traditional Unix fashion: logging and error messages go to
standard error.

> Apart from having preferred a more surgical approach to update the teams
> (assuming that would be less overhead for Codeberg), this LGTM.

Thanks!

Ludo’.
  

Hello,

Pushed as 848ebb7f72fa529b0a3da47fbef2a6cf6f7fba8a.

I added Codeberg account names that people gave on guix-devel in the
meantime.  There are still a few missing.

Thanks,
Ludo’.
  

Turns out that the brute-force approach breaks assumptions in Forgejo
after all:

  https://codeberg.org/Codeberg/Community/issues/1952#issuecomment-4899291

So I’ll have to do what you suggested and explicitly synchronize the
various bits without deleting/recreating teams.

Ludo’.