From patchwork Fri May 23 19:55:09 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 42888 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 6C16F27BC4C; Fri, 23 May 2025 20:56:26 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-7.4 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED,RCVD_IN_MSPIKE_H2, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 8E8A927BC49 for ; Fri, 23 May 2025 20:56:25 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1uIYUu-0008Bd-S4; Fri, 23 May 2025 15:56:04 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1uIYUt-0008BD-Uq for guix-patches@gnu.org; Fri, 23 May 2025 15:56:03 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1uIYUt-0004Rj-LH for guix-patches@gnu.org; Fri, 23 May 2025 15:56:03 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=NF17NZo+6lgD6OjXe5QFwjqQkMTETXWivWhzlDaiB3Y=; b=S+BNicoOfZw1wATX5vDLtrnmXFrD1nbqyfVUGbfdX7KEXhi+i1xLRXP38WafUAgse1sdZxuUBsg5g+EhpxV4T7SFsK/R7ZtHFM+TdGD+xKNZq2bzFURJQbIWrpltnnv/9+2GHJMCCrl0WEcs38Vfq49OhKEFYHxQLSay1RRt1ujrt+kNb0ebB2j3fjknCCsGmym6ZmxA7Sny1d98jy+RkFk/wdZmncToqaSk6U/l7AGilZjDfYO2OrS26j0S/NDFi3GX8NZc48OqRolF35MC9UpBgQkkmHaJc5UdWK9Vg6imacd+Ik5JBT6cWOukRHc6LekCMLEMys/P8xrv1MfErg==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1uIYUt-0000zB-HE for guix-patches@gnu.org; Fri, 23 May 2025 15:56:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#78568] [PATCH 5/5] teams: Add =?utf-8?b?4oCYc3luYy1jb2RlYmVy?= =?utf-8?b?Zy10ZWFtc+KAmQ==?= action. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 23 May 2025 19:56:03 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 78568 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 78568@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 78568-submit@debbugs.gnu.org id=B78568.17480301473705 (code B ref 78568); Fri, 23 May 2025 19:56:03 +0000 Received: (at 78568) by debbugs.gnu.org; 23 May 2025 19:55:47 +0000 Received: from localhost ([127.0.0.1]:51049 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1uIYUc-0000xf-3M for submit@debbugs.gnu.org; Fri, 23 May 2025 15:55:46 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:39580) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1uIYUW-0000wf-W1 for 78568@debbugs.gnu.org; Fri, 23 May 2025 15:55:42 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1uIYUR-0004QQ-GJ; Fri, 23 May 2025 15:55:35 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=NF17NZo+6lgD6OjXe5QFwjqQkMTETXWivWhzlDaiB3Y=; b=gEEIQX6vQhlq8J6eies6 jkVpcqmhHxaAWUyz2tjvWUSL1p37o9lioSiiesKLAonCtoXLtkDFSfXXhGVaILvbqCsXHPwIo0u3x Zv3jM8s+1jUqcxkvmkJ8Ij76I/K/eE6QSL4kjr9bq0w6v70+pJOV6xXpQgQjdCoKbWvlL8sow809v gEgEBSJNNXGkmHpADL+hoBGG2XBKZNQWGznDN1I4BIF7iapq0RalLIoUpHPYPZ39EIWjk0fD9VFeX sxwgUr8qiar0HEqaa0Yo79vzOX1wH+uBNaxggT26VlQbsnS7kpZ2zWrERGUkN6QNkOpvOi0afpILa XHBsEfzc+YocgA==; From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 23 May 2025 21:55:09 +0200 Message-ID: X-Mailer: git-send-email 2.49.0 In-Reply-To: References: MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * etc/teams.scm (): 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(-) 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 (%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? + 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 + keys values) + "&"))))) + + (string-append "https://codeberg.org/api/v1/" + (string-join items "/") + query)) + +(define-syntax process-url-components + (syntax-rules (&) + "Helper macro to construct a Codeberg URL." + ((_ components ... & parameters) + (codeberg-url (list components ...) + #:parameters parameters)) + ((_ components ...) + (codeberg-url (list components ...))))) + +(define-syntax define-forgejo-request + (syntax-rules (=>) + "Define a procedure that performs a Forgejo request." + ((_ (proc parameters ...) + docstring + (verb components ...) + body + => code + deserialize) + (define (proc token parameters ...) + docstring + (let* ((url (process-url-components components ...)) + (response port (http-request url + #:method 'verb + #:streaming? #t + #:headers (forgejo-http-headers token) + #:body body))) + (if (= code (response-code response)) + (let ((value (deserialize port))) + (when port (close-port port)) + value) + (begin + (when port (close-port port)) + (raise (condition (&forgejo-error (url url) + (method 'verb) + (response response))))))))) + ((_ (proc parameters ...) + docstring + (method components ...) + => code + deserialize) + (define-forgejo-request (proc parameters ...) + docstring + (method components ...) + "" + => code + deserialize)) + ((_ (proc parameters ...) + docstring + (method components ...) + => code) + (define-forgejo-request (proc parameters ...) + docstring + (method components ...) + "" + => code + (const *unspecified*))))) + +;; API documentation at . + +(define-forgejo-request (organization-teams organization) + "Return the list of teams of ORGANIZATION." + (GET "orgs" organization "teams" + & '(("limit" . "100"))) ;get up to 100 teams + => 200 + (lambda (port) + (map json->forgejo-team (vector->list (json->scm port))))) + +(define-forgejo-request (create-team organization team) + "Create TEAM, a Forgejo team, under ORGANIZATION." + (POST "orgs" organization "teams") + (forgejo-team->json team) + => 201 + json->forgejo-team) + +(define-forgejo-request (delete-team team) + "Delete TEAM, a Forgejo team." + (DELETE "teams" (number->string (forgejo-team-id team))) + => 204) + +(define-forgejo-request (add-team-member team user) + "Add USER (a string) to TEAM, a Forgejo team." + (PUT "teams" (number->string (forgejo-team-id team)) + "members" user) + => 204) + +(define (team->forgejo-team team) + "Return a Forgejo team derived from TEAM, a record." + (forgejo-team (team-id->forgejo-id (team-id team)) + #f + (or (team-description team) "") + #f ;all-repositories? + #f ;can-create-org-repository? + 'read ;permission + %default-forgejo-team-unit-map)) + +(define* (synchronize-team token team + #:key + (current-teams + (organization-teams token + %codeberg-organization)) + (log-port (current-error-port))) + "Synchronize TEAM, a 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)) + + ;; 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) + + ;; 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))) + (define-team audio @@ -1132,6 +1376,8 @@ (define (main . args) (list-teams team-names)) (("codeowners") (export-codeowners (current-output-port))) + (("sync-codeberg-teams" token) + (synchronize-teams token)) (anything (format (current-error-port) "Usage: etc/teams.scm [] @@ -1154,6 +1400,8 @@ (define (main . args) show display properties codeowners - write a 'CODEOWNERS' file suitable for Codeberg on standard output~%")))) + write a 'CODEOWNERS' file suitable for Codeberg on standard output + sync-codeberg-teams + create or update the list of teams at Codeberg~%")))) (apply main (cdr (command-line)))