From d4e82f224e2b054c0a64a18b306f418fd81f4881 Mon Sep 17 00:00:00 2001 From: Sergio Durigan Junior Date: Sun, 31 Mar 2024 20:31:33 -0400 Subject: [PATCH] Initial version of the package --- sponsor-debian.el | 312 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 312 insertions(+) create mode 100644 sponsor-debian.el diff --git a/sponsor-debian.el b/sponsor-debian.el new file mode 100644 index 0000000..8a73989 --- /dev/null +++ b/sponsor-debian.el @@ -0,0 +1,312 @@ +;;; sponsor-debian.el --- Make it easy to sponsor packages on Debian. +;;; +;;; Commentary: +;;; +;;; This is a simple package whose purpose is to: +;;; +;;; - "gbp clone" the sponsoree repository; +;;; - Create a project under a team's namespace if needed/wanted; +;;; +;;; Code: + +(require 'magit) +(require 'plz) + +(defgroup sdj/sponsor-debian-pkg () + "Helper to sponsor Debian packages.") + +(defcustom sdj/sponsor-debian-pkg-path + nil + "Path where sponsored packages will be stored." + :group 'sdj/sponsor-debian-pkg + :type 'directory) + +(defcustom sdj/sponsor-debian-pkg-salsa-api-url + "https://salsa.debian.org/api/v4/" + "The API URL for salsa.debian.org." + :group 'sdj/sponsor-debian-pkg + :type 'string) + +(defcustom sdj/sponsor-debian-pkg-salsa-api-token + nil + "The API token for salsa.debian.org." + :group 'sdj/sponsor-debian-pkg + :type 'string) + +(defun sdj/sponsor--generate-sponsoree-candidates-from-dir () + "Generate a list of sponsoree candidates from the contents of 'sdj/sponsor-debian-pkg-path'. + +The idea is that each directory name inside that path corresponds +to a salsa.d.o username." + (flatten-tree + (mapcar + (lambda (e) + (let ((dirname (car e))) + (when (and (nth 2 e) + ; Exclude "." and ".." from the list + (not (seq-contains-p '("." "..") dirname))) + dirname))) + (directory-files-and-attributes sdj/sponsor-debian-pkg-path)))) + +(defun sdj/sponsor--generate-sponsoree-candidates () + "Generate a list of sponsoree candidates from salsa.d.o. + +The idea is to query Debian Brasilia's 'docs' project, obtain a +list of the last 100 issues, and gather all the usernames that +ever commented on those issues. + +Return an alist of (user . username)." + (let* ((debian-bsb-users (plz 'get + (concat sdj/sponsor-debian-pkg-salsa-api-url + "projects/" + (url-hexify-string "debian-brasilia-team/docs") + "/issues?per_page=100&order_by=updated_at") + :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) + :timeout 60 + :connect-timeout 60 + :as #'json-read))) + (seq-uniq + (cl-map 'list + (lambda (e) + (let* ((u (alist-get 'author e)) + (name (alist-get 'name u)) + (username (alist-get 'username u))) + (cons (format "%s (%s)" name username) username))) + debian-bsb-users)))) + +(defun sdj/sponsor--parse-teams () + "Parse a JSON representation of all teams which we are subscribed to. + +Return an alist of (team . id)." + (let ((parsedteams (json-read))) + (delete + nil + (mapcar + (lambda (e) + (when (string= (alist-get 'kind e) "group") + (cons (alist-get 'full_path e) (alist-get 'id e)))) + parsedteams)))) + +(defun sdj/sponsor--api-endpoint (name) + (concat sdj/sponsor-debian-pkg-salsa-api-url name "/")) + +(defun sdj/sponsor--generate-team-candidates () + (plz 'get (sdj/sponsor--api-endpoint "namespaces") + :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) + :as #'sdj/sponsor--parse-teams)) + +(defun sdj/sponsor--team-repo-exists-p (team repo) + (condition-case err + (let ((r (plz 'get + (concat (sdj/sponsor--api-endpoint "projects") + (url-hexify-string (concat team "/" repo))) + :as 'response))) + (when (plz-response-p r) + (pcase (plz-response-status r) + (200 t) + (404 nil)))) + (plz-error nil))) + +(defun sdj/sponsor--sanitize-import-url (url) + (concat (string-replace "git@salsa.debian.org:" + "https://salsa.debian.org/" + url) + (unless (string-suffix-p ".git" url) + ".git"))) + +(defun sdj/sponsor--parse-new-repo-clone-url () + (let ((parsenewrepo (json-read))) + (alist-get 'ssh_url_to_repo parsenewrepo))) + +(defun sdj/sponsor--create-team-repo (team projname repourl) + (plz 'post (sdj/sponsor--api-endpoint "projects") + :headers `(("Content-Type" . "application/json") + ("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) + :body (json-encode + (delete nil + `(("name" . ,projname) + ("description" . ,(concat "Debian package for " projname)) + ,(when repourl + `("import_url" . ,(sdj/sponsor--sanitize-import-url repourl))) + ("namespace_id" . ,(cdr team)) + ("initialize_with_readme" . false)))) + :as #'sdj/sponsor--parse-new-repo-clone-url)) + +(defun sdj/sponsor--make-team-repo-url (team projname) + (concat "git@salsa.debian.org:" + (car team) "/" + projname ".git")) + +(defun sdj/sponsor--get-or-create-team-repo (team projname repourl &optional dontask-p) + (if (sdj/sponsor--team-repo-exists-p (car team) projname) + (sdj/sponsor--make-team-repo-url team projname) + (when (or dontask-p + (y-or-n-p "Would you like to create the repository under the team's namespace? ")) + (message "Creating the team repository (%s/%s.git)..." + (car team) projname) + (sdj/sponsor--create-team-repo team projname repourl)))) + +(defun sdj/sponsor--confirm-username (user) + (let ((u (plz 'get + (concat sdj/sponsor-debian-pkg-salsa-api-url "users?username=" (url-hexify-string user)) + :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) + :as #'json-read))) + (and (not (seq-empty-p u)) user))) + +(defun sdj/sponsor--confirm-team (team) + (condition-case err + (let ((u (plz 'get + (concat sdj/sponsor-debian-pkg-salsa-api-url "namespaces/" (url-hexify-string team)) + :headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token)) + :as #'json-read))) + (and (not (seq-empty-p u)) (cons team (alist-get 'id u)))) + (plz-error nil))) + +(defun sdj/sponsor--read-sponsoree-choice () + (let* ((sponsoreealist (sdj/sponsor--generate-sponsoree-candidates)) + (sponsoreechoice (completing-read "Sponsoree: " sponsoreealist))) + (or (alist-get sponsoreechoice sponsoreealist nil nil #'string=) + (sdj/sponsor--confirm-username sponsoreechoice)))) + +(defun sdj/sponsor--read-team-choice (&optional dontask-p) + (when (or dontask-p + (y-or-n-p "Would you like to specify a team? ")) + (let* ((teamalist (sdj/sponsor--generate-team-candidates)) + (teamchoice (completing-read "Team: " teamalist nil t))) + (cons teamchoice + (alist-get teamchoice teamalist nil nil #'string=))))) + +(defun sdj/sponsor--read-string-or-nil (prompt) + (let ((r (read-from-minibuffer prompt))) + (unless (string-empty-p r) + r))) + +(defun sdj/sponsor--read-repourl (&optional prompt) + (let ((r (sdj/sponsor--read-string-or-nil (or prompt + "Repository URL: ")))) + (when r + (string-remove-suffix "/" r)))) + +(defun sdj/sponsor--get-namespace-from-repourl (repourl) + (let ((str-no-url (or (and (string-prefix-p "git@salsa.debian.org:" repourl) + (string-remove-prefix "git@salsa.debian.org:" repourl)) + (and (string-prefix-p "https://salsa.debian.org/" repourl) + (string-remove-prefix "https://salsa.debian.org/" repourl))))) + (string-remove-suffix + "/" + (string-remove-prefix + "/" + (file-name-directory + (string-remove-suffix "/" str-no-url)))))) + + ;; (replace-regexp-in-string + ;; (rx + ;; (or "git@salsa.debian.org:" "https://salsa.debian.org/") + ;; (group (one-or-more (not "/"))) (minimal-match (one-or-more not-newline))) + ;; "\\1" repourl nil nil nil )) + +(defun sdj/sponsor--get-project-from-repourl (repourl) + (file-name-base (string-remove-suffix "/" repourl))) + +(defun sdj/sponsor--what-is-this-namespace (namespace) + (let* ((username (sdj/sponsor--confirm-username namespace)) + (team (and (not username) + (sdj/sponsor--confirm-team namespace)))) + (cond + (username + (cons 'username username)) + (team + (cons 'team team)) + (t + (error "Could not find namespace '%s'" namespace))))) + +(defun sdj/sponsor-init--read-args () + (let* ((repo (sdj/sponsor--read-repourl)) + (namespace (sdj/sponsor--get-namespace-from-repourl repo)) + (result (sdj/sponsor--what-is-this-namespace namespace)) + (team (or (and (eq (car result) 'team) + (cdr result)) + (sdj/sponsor--read-team-choice))) + (sponsoree (or (and (eq (car result) 'username) + (cdr result)) + (sdj/sponsor--read-sponsoree-choice)))) + (when (y-or-n-p (format "Sponsoree: [%s]; Team: [%s]; OK? " sponsoree (or (car team) "none"))) + (list sponsoree team repo)))) + +;;;###autoload +(defun sdj/sponsor-create-team-repo (team projname sponsoree-repourl) + (interactive + (list + (sdj/sponsor--read-team-choice t) + (sdj/sponsor--read-string-or-nil "Project name: ") + (sdj/sponsor--read-repourl "Sponsoree repository to import into the new one (optional): "))) + (when (or (not team) (not projname)) + (error "You must provide a valid team and a project name")) + (let ((team-repourl (sdj/sponsor--get-or-create-team-repo team projname sponsoree-repourl t))) + (when sponsoree-repourl + (when-let* ((sponsoree (sdj/sponsor--get-namespace-from-repourl sponsoree-repourl)) + (sponsoreedir (file-name-as-directory + (concat sdj/sponsor-debian-pkg-path sponsoree))) + (projdir (file-name-as-directory + (concat sponsoreedir projname))) + (team-gitdir (file-name-as-directory + (concat projdir projname)))) + (when (and (not (file-directory-p team-gitdir)) + (y-or-n-p + (format "Would you like to clone the team's repository inside %s's directory? " sponsoree))) + (mkdir projdir t) + (let ((default-directory projdir)) + (message "Cloning the team repository...") + (call-process "gbp" nil (get-buffer-create "*gbp output*") nil + "clone" team-repourl team-gitdir)) + (let ((default-directory team-gitdir)) + (unless (magit-remote-p sponsoree) + (message "Adding %s as a remote of the team repository..." sponsoree) + (call-process "git" nil (get-buffer-create "*gbp output*") nil + "remote" "add" sponsoree sponsoree-repourl) + (message "Fetching all remotes inside the team repository...") + (call-process "git" nil (get-buffer-create "*gbp output*") nil + "fetch" sponsoree)))))))) + +;;;###autoload +(defun sdj/sponsor-init (sponsoree team repo) + (interactive + (sdj/sponsor-init--read-args)) + (when (or (not sponsoree) (not repo)) + (error "You must provide a valid sponsoree name and a repository URL")) + (let* ((projname (sdj/sponsor--get-project-from-repourl repo)) + (sponsoreedir (file-name-as-directory + (concat sdj/sponsor-debian-pkg-path sponsoree))) + (projdir (file-name-as-directory + (concat sponsoreedir projname))) + (repo-is-private-p (string-search (concat "/" sponsoree "/") repo)) + (sponsoree-gitdir (concat projdir projname + (when repo-is-private-p + (concat "-" sponsoree))))) + (message "Creating directory %s..." projdir) + (mkdir projdir t) + (let ((default-directory projdir)) + (unless (file-directory-p sponsoree-gitdir) + (message "Invoking gbp clone %s..." repo) + (call-process "gbp" nil (get-buffer-create "*gbp output*") nil + "clone" repo sponsoree-gitdir)) + (when (and team repo-is-private-p) + (when-let ((team-repourl (sdj/sponsor--get-or-create-team-repo team projname repo)) + (team-gitdir (concat projdir projname))) + (unless (file-directory-p team-gitdir) + (message "Cloning the team repository...") + (call-process "gbp" nil (get-buffer-create "*gbp output*") nil + "clone" team-repourl)) + (let ((default-directory team-gitdir)) + (unless (magit-remote-p sponsoree) + (message "Adding %s as a remote of the team repository..." sponsoree) + (call-process "git" nil (get-buffer-create "*gbp output*") nil + "remote" "add" sponsoree repo) + (message "Fetching all remotes inside the team repository...") + (call-process "git" nil (get-buffer-create "*gbp output*") nil + "fetch" sponsoree)))))) + (dired sponsoree-gitdir))) + +(provide 'sponsor-debian) + +;;; sponsor-debian.el ends here