sponsor-debian-pkg/sponsor-debian-pkg.el

;;; sponsor-debian-pkg.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-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
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-debian-pkg--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-debian-pkg--api-endpoint (name)
  "Return the full URL for an API endpoint ending with 'NAME'.

The endpoint will always end with a slash."
  (concat sdj/sponsor-debian-pkg-salsa-api-url name "/"))

(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-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-debian-pkg--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-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-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-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))
    :body (json-encode
	   (delete nil
		   `(("name" . ,projname)
		     ("description" . ,(concat "Debian package for " projname))
		     ,(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-debian-pkg--parse-new-repo-clone-url))

(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-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-debian-pkg--create-team-repo team projname import-repourl))))

(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))
	     :as #'json-read)))
    (and (not (seq-empty-p u)) user)))

(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))
		 :as #'json-read)))
	(and (not (seq-empty-p u)) (cons team (alist-get 'id u))))
    (plz-error nil)))

(defun sdj/sponsor-debian-pkg--read-sponsoree-choice (&optional optional)
  "Read the sponsoree."
  (let* ((sponsoreealist (sdj/sponsor-debian-pkg--generate-sponsoree-candidates))
	 (sponsoreechoice (completing-read (concat (when optional "(optional) ")
						   "Sponsoree: ") sponsoreealist)))
    (if sponsoreechoice
	(or (alist-get sponsoreechoice sponsoreealist nil nil #'string=)
	    (sdj/sponsor-debian-pkg--confirm-username sponsoreechoice))
      (unless optional
	(error "You must specify a sponsoree")))))

(defun sdj/sponsor-debian-pkg--read-team-choice (&optional dontask-p optional)
  "Read the team."
  (when (or dontask-p
	    (y-or-n-p (concat (when optional "(optional) ")
				    "Would you like to specify a team? " )))
    (let* ((teamalist (sdj/sponsor-debian-pkg--generate-team-candidates))
	   (teamchoice (completing-read "Team: " teamalist nil t)))
      (if teamchoice
	  (cons teamchoice
		(alist-get teamchoice teamalist nil nil #'string=))
	(unless optional
	  (error "You must specify a team"))))))

(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-debian-pkg--read-repourl (&optional prompt optional)
  "Read a repository URL."
  (let ((r (sdj/sponsor-debian-pkg--read-string-or-nil
	    (concat (when optional "(optional) ")
		    (or prompt
			"Repository URL: ")))))
    (if r
	(string-remove-suffix "/" r)
      (unless optional
	(error "You must specify a repository URL")))))

(defun sdj/sponsor-debian-pkg--get-namespace-from-repourl (repourl)
  "Given a repository URL 'REPOURL', return its namespace."
  (when-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))))))

(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-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-debian-pkg--confirm-team namespace))))
    (cond
     (username
      (cons 'username username))
     (team
      (cons 'team team))
     (t
      (error "Could not find namespace '%s'" 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-debian-pkg--read-team-choice nil t)))
	 (sponsoree (or (and (eq (car result) 'username)
			     (cdr result))
			(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-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-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-debian-pkg--get-or-create-team-repo team projname sponsoree-repourl t)))
    (when 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)))
		  (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-debian-pkg (sponsoree team repo)
  (interactive
   (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-debian-pkg--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-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...")
	    (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-pkg)

;;; sponsor-debian-pkg.el ends here