Initial version of the package

2024-03-31 20:31:33 -04:00 · 2024-03-31 20:31:33 -04:00 · d4e82f224e
commit d4e82f224e
1 changed files with 312 additions and 0 deletions
--- a/sponsor-debian.el
+++ 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