313 lines
11 KiB
EmacsLisp
313 lines
11 KiB
EmacsLisp
|
;;; 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
|