Compare commits
2 commits
d4e82f224e
...
ca697024fd
| Author | SHA1 | Date | |
|---|---|---|---|
ca697024fd
|
|||
|
e93990d325
|
1 changed files with 110 additions and 86 deletions
|
|
@ -1,4 +1,4 @@
|
|||
;;; sponsor-debian.el --- Make it easy to sponsor packages on Debian.
|
||||
;;; sponsor-debian-pkg.el --- Make it easy to sponsor packages on Debian.
|
||||
;;;
|
||||
;;; Commentary:
|
||||
;;;
|
||||
|
|
@ -33,22 +33,7 @@
|
|||
: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 ()
|
||||
(defun sdj/sponsor-debian-pkg--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
|
||||
|
|
@ -57,11 +42,11 @@ 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
|
||||
(concat sdj/sponsor-debian-pkg-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))
|
||||
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
|
||||
:timeout 60
|
||||
:connect-timeout 60
|
||||
:as #'json-read)))
|
||||
|
|
@ -74,7 +59,7 @@ Return an alist of (user . username)."
|
|||
(cons (format "%s (%s)" name username) username)))
|
||||
debian-bsb-users))))
|
||||
|
||||
(defun sdj/sponsor--parse-teams ()
|
||||
(defun sdj/sponsor-debian-pkg--parse-teams ()
|
||||
"Parse a JSON representation of all teams which we are subscribed to.
|
||||
|
||||
Return an alist of (team . id)."
|
||||
|
|
@ -87,18 +72,25 @@ Return an alist of (team . id)."
|
|||
(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-debian-pkg--api-endpoint (name)
|
||||
"Return the full URL for an API endpoint ending with '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))
|
||||
The endpoint will always end with a slash."
|
||||
(concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url name "/"))
|
||||
|
||||
(defun sdj/sponsor--team-repo-exists-p (team repo)
|
||||
(defun sdj/sponsor-debian-pkg--generate-team-candidates ()
|
||||
"Generate a list of candidates for team names.
|
||||
|
||||
The generated list is actually a list of namespaces the user is a member of."
|
||||
(plz 'get (sdj/sponsor-debian-pkg--api-endpoint "namespaces")
|
||||
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
|
||||
:as #'sdj/sponsor-debian-pkg--parse-teams))
|
||||
|
||||
(defun sdj/sponsor-debian-pkg--team-repo-exists-p (team repo)
|
||||
"Check if 'REPO' (under 'TEAM' namespace) exists."
|
||||
(condition-case err
|
||||
(let ((r (plz 'get
|
||||
(concat (sdj/sponsor--api-endpoint "projects")
|
||||
(concat (sdj/sponsor-debian-pkg--api-endpoint "projects")
|
||||
(url-hexify-string (concat team "/" repo)))
|
||||
:as 'response)))
|
||||
(when (plz-response-p r)
|
||||
|
|
@ -107,87 +99,115 @@ Return an alist of (team . id)."
|
|||
(404 nil))))
|
||||
(plz-error nil)))
|
||||
|
||||
(defun sdj/sponsor--sanitize-import-url (url)
|
||||
(defun sdj/sponsor-debian-pkg--sanitize-import-url (url)
|
||||
"Sanitize the git import URL to be used when creating a new project.
|
||||
|
||||
This will always make sure to replace 'git@salsa.debian.org:'
|
||||
with 'https://salsa.debian.org/', and append a '.git' suffix if
|
||||
needed."
|
||||
(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 ()
|
||||
(defun sdj/sponsor-debian-pkg--parse-new-repo-clone-url ()
|
||||
"Parse the JSON returned when creating a new project, returning its 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")
|
||||
(defun sdj/sponsor-debian-pkg--create-team-repo (team projname &optional import-repourl)
|
||||
"Create a repository named 'PROJNAME' under 'TEAM' namespace.
|
||||
|
||||
If 'IMPORT-REPOURL' is provided, use it as the initial import."
|
||||
(plz 'post (sdj/sponsor-debian-pkg--api-endpoint "projects")
|
||||
:headers `(("Content-Type" . "application/json")
|
||||
("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-salsa-api-token))
|
||||
("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-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)))
|
||||
,(when import-repourl
|
||||
`("import_url" . ,(sdj/sponsor-debian-pkg--sanitize-import-url import-repourl)))
|
||||
("namespace_id" . ,(cdr team))
|
||||
("initialize_with_readme" . false))))
|
||||
:as #'sdj/sponsor--parse-new-repo-clone-url))
|
||||
:as #'sdj/sponsor-debian-pkg--parse-new-repo-clone-url))
|
||||
|
||||
(defun sdj/sponsor--make-team-repo-url (team projname)
|
||||
(defun sdj/sponsor-debian-pkg--make-team-repo-url (team projname)
|
||||
"Given 'TEAM' and 'PROJNAME', return the repository URL.
|
||||
|
||||
This URL is used for cloning purposes, and therefore starts with
|
||||
'git@salsa.debian.org:'."
|
||||
(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)
|
||||
(defun sdj/sponsor-debian-pkg--get-or-create-team-repo (team projname &options import-repourl dontask-p)
|
||||
"Get or create a new repository under 'TEAM'.
|
||||
|
||||
If 'IMPORT-REPOURL' is provided, use it as the initial repository content.
|
||||
|
||||
If 'DONTASK-P' is t, don't ask whether the user would like to
|
||||
create the repository."
|
||||
(if (sdj/sponsor-debian-pkg--team-repo-exists-p (car team) projname)
|
||||
(sdj/sponsor-debian-pkg--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))))
|
||||
(sdj/sponsor-debian-pkg--create-team-repo team projname import-repourl))))
|
||||
|
||||
(defun sdj/sponsor--confirm-username (user)
|
||||
(defun sdj/sponsor-debian-pkg--confirm-username (user)
|
||||
"Confirm if 'USER' exists."
|
||||
(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))
|
||||
(concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url "users?username=" (url-hexify-string user))
|
||||
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-debian-pkg-salsa-api-token))
|
||||
:as #'json-read)))
|
||||
(and (not (seq-empty-p u)) user)))
|
||||
|
||||
(defun sdj/sponsor--confirm-team (team)
|
||||
(defun sdj/sponsor-debian-pkg--confirm-team (team)
|
||||
"Confirm if 'TEAM' exists.
|
||||
|
||||
Note that internally teams are actually treated as namespaces."
|
||||
(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))
|
||||
(concat sdj/sponsor-debian-pkg-debian-pkg-salsa-api-url "namespaces/" (url-hexify-string team))
|
||||
:headers `(("PRIVATE-TOKEN" . ,sdj/sponsor-debian-pkg-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))
|
||||
(defun sdj/sponsor-debian-pkg--read-sponsoree-choice ()
|
||||
"Read the sponsoree."
|
||||
(let* ((sponsoreealist (sdj/sponsor-debian-pkg--generate-sponsoree-candidates))
|
||||
(sponsoreechoice (completing-read "Sponsoree: " sponsoreealist)))
|
||||
(or (alist-get sponsoreechoice sponsoreealist nil nil #'string=)
|
||||
(sdj/sponsor--confirm-username sponsoreechoice))))
|
||||
(sdj/sponsor-debian-pkg--confirm-username sponsoreechoice))))
|
||||
|
||||
(defun sdj/sponsor--read-team-choice (&optional dontask-p)
|
||||
(defun sdj/sponsor-debian-pkg--read-team-choice (&optional dontask-p)
|
||||
"Read the team."
|
||||
(when (or dontask-p
|
||||
(y-or-n-p "Would you like to specify a team? "))
|
||||
(let* ((teamalist (sdj/sponsor--generate-team-candidates))
|
||||
(let* ((teamalist (sdj/sponsor-debian-pkg--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)
|
||||
(defun sdj/sponsor-debian-pkg--read-string-or-nil (prompt)
|
||||
"Read a string from the minibuffer or nil."
|
||||
(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
|
||||
(defun sdj/sponsor-debian-pkg--read-repourl (&optional prompt)
|
||||
"Read a repository URL."
|
||||
(let ((r (sdj/sponsor-debian-pkg--read-string-or-nil (or prompt
|
||||
"Repository URL: "))))
|
||||
(when r
|
||||
(string-remove-suffix "/" r))))
|
||||
|
||||
(defun sdj/sponsor--get-namespace-from-repourl (repourl)
|
||||
(defun sdj/sponsor-debian-pkg--get-namespace-from-repourl (repourl)
|
||||
"Given a repository URL 'REPOURL', return its namespace."
|
||||
(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)
|
||||
|
|
@ -199,19 +219,18 @@ Return an alist of (team . id)."
|
|||
(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)
|
||||
(defun sdj/sponsor-debian-pkg--get-project-from-repourl (repourl)
|
||||
"Given a repository URL 'REPOURL', return its project name."
|
||||
(file-name-base (string-remove-suffix "/" repourl)))
|
||||
|
||||
(defun sdj/sponsor--what-is-this-namespace (namespace)
|
||||
(let* ((username (sdj/sponsor--confirm-username namespace))
|
||||
(defun sdj/sponsor-debian-pkg--what-is-this-namespace (namespace)
|
||||
"Given a namespace 'NAMESPACE', identify it.
|
||||
|
||||
Return an alist of (ID . DATA), where 'ID' is either 'username or
|
||||
'team, and 'DATA' is information about the namespace."
|
||||
(let* ((username (sdj/sponsor-debian-pkg--confirm-username namespace))
|
||||
(team (and (not username)
|
||||
(sdj/sponsor--confirm-team namespace))))
|
||||
(sdj/sponsor-debian-pkg--confirm-team namespace))))
|
||||
(cond
|
||||
(username
|
||||
(cons 'username username))
|
||||
|
|
@ -220,33 +239,38 @@ Return an alist of (team . id)."
|
|||
(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))
|
||||
(defun sdj/sponsor-debian-pkg--read-args ()
|
||||
"Read arguments from the minibuffer."
|
||||
(let* ((repo (sdj/sponsor-debian-pkg--read-repourl))
|
||||
(namespace (sdj/sponsor-debian-pkg--get-namespace-from-repourl repo))
|
||||
(result (sdj/sponsor-debian-pkg--what-is-this-namespace namespace))
|
||||
(team (or (and (eq (car result) 'team)
|
||||
(cdr result))
|
||||
(sdj/sponsor--read-team-choice)))
|
||||
(sdj/sponsor-debian-pkg--read-team-choice)))
|
||||
(sponsoree (or (and (eq (car result) 'username)
|
||||
(cdr result))
|
||||
(sdj/sponsor--read-sponsoree-choice))))
|
||||
(sdj/sponsor-debian-pkg--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)
|
||||
(defun sdj/sponsor-debian-pkg-create-team-repo (team projname sponsoree-repourl)
|
||||
"Create a team repository.
|
||||
|
||||
If 'SPONSOREE-REPOURL' is provided, use it as a base for the
|
||||
initial repository."
|
||||
(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): ")))
|
||||
(sdj/sponsor-debian-pkg--read-team-choice t)
|
||||
(sdj/sponsor-debian-pkg--read-string-or-nil "Project name: ")
|
||||
(sdj/sponsor-debian-pkg--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)))
|
||||
(let ((team-repourl (sdj/sponsor-debian-pkg--get-or-create-team-repo team projname sponsoree-repourl t)))
|
||||
(when sponsoree-repourl
|
||||
(when-let* ((sponsoree (sdj/sponsor--get-namespace-from-repourl sponsoree-repourl))
|
||||
(when-let* ((sponsoree (sdj/sponsor-debian-pkg--get-namespace-from-repourl sponsoree-repourl))
|
||||
(sponsoreedir (file-name-as-directory
|
||||
(concat sdj/sponsor-debian-pkg-path sponsoree)))
|
||||
(concat sdj/sponsor-debian-pkg-debian-pkg-path sponsoree)))
|
||||
(projdir (file-name-as-directory
|
||||
(concat sponsoreedir projname)))
|
||||
(team-gitdir (file-name-as-directory
|
||||
|
|
@ -269,14 +293,14 @@ Return an alist of (team . id)."
|
|||
"fetch" sponsoree))))))))
|
||||
|
||||
;;;###autoload
|
||||
(defun sdj/sponsor-init (sponsoree team repo)
|
||||
(defun sdj/sponsor-debian-pkg (sponsoree team repo)
|
||||
(interactive
|
||||
(sdj/sponsor-init--read-args))
|
||||
(sdj/sponsor-debian-pkg--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))
|
||||
(let* ((projname (sdj/sponsor-debian-pkg--get-project-from-repourl repo))
|
||||
(sponsoreedir (file-name-as-directory
|
||||
(concat sdj/sponsor-debian-pkg-path sponsoree)))
|
||||
(concat sdj/sponsor-debian-pkg-debian-pkg-path sponsoree)))
|
||||
(projdir (file-name-as-directory
|
||||
(concat sponsoreedir projname)))
|
||||
(repo-is-private-p (string-search (concat "/" sponsoree "/") repo))
|
||||
|
|
@ -291,7 +315,7 @@ Return an alist of (team . id)."
|
|||
(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))
|
||||
(when-let ((team-repourl (sdj/sponsor-debian-pkg--get-or-create-team-repo team projname repo))
|
||||
(team-gitdir (concat projdir projname)))
|
||||
(unless (file-directory-p team-gitdir)
|
||||
(message "Cloning the team repository...")
|
||||
|
|
@ -307,6 +331,6 @@ Return an alist of (team . id)."
|
|||
"fetch" sponsoree))))))
|
||||
(dired sponsoree-gitdir)))
|
||||
|
||||
(provide 'sponsor-debian)
|
||||
(provide 'sponsor-debian-pkg)
|
||||
|
||||
;;; sponsor-debian.el ends here
|
||||
;;; sponsor-debian-pkg.el ends here
|
||||
Loading…
Reference in a new issue