forge-pullreq.el (14465B)
1 ;;; forge-pullreq.el --- Pullreq support -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2018-2022 Jonas Bernoulli 4 5 ;; Author: Jonas Bernoulli <jonas@bernoul.li> 6 ;; Maintainer: Jonas Bernoulli <jonas@bernoul.li> 7 ;; SPDX-License-Identifier: GPL-3.0-or-later 8 9 ;; This file is not part of GNU Emacs. 10 11 ;; Forge is free software; you can redistribute it and/or modify it 12 ;; under the terms of the GNU General Public License as published by 13 ;; the Free Software Foundation; either version 3, or (at your option) 14 ;; any later version. 15 ;; 16 ;; Forge is distributed in the hope that it will be useful, but WITHOUT 17 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 18 ;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public 19 ;; License for more details. 20 ;; 21 ;; You should have received a copy of the GNU General Public License 22 ;; along with Forge. If not, see http://www.gnu.org/licenses. 23 24 ;;; Code: 25 26 (require 'forge) 27 (require 'forge-post) 28 (require 'forge-topic) 29 30 ;;; Classes 31 32 (defclass forge-pullreq (forge-topic) 33 ((closql-table :initform 'pullreq) 34 (closql-primary-key :initform 'id) 35 (closql-order-by :initform [(desc number)]) 36 (closql-foreign-key :initform 'repository) 37 (closql-class-prefix :initform "forge-") 38 (id :initarg :id) 39 (repository :initarg :repository) 40 (number :initarg :number) 41 (state :initarg :state) 42 (author :initarg :author) 43 (title :initarg :title) 44 (created :initarg :created) 45 (updated :initarg :updated) 46 (closed :initarg :closed) 47 (merged :initarg :merged) 48 (unread-p :initarg :unread-p :initform nil) 49 (locked-p :initarg :locked-p) 50 (editable-p :initarg :editable-p) 51 (cross-repo-p :initarg :cross-repo-p) 52 (base-ref :initarg :base-ref) 53 (base-repo :initarg :base-repo) 54 (head-ref :initarg :head-ref) 55 (head-user :initarg :head-user) 56 (head-repo :initarg :head-repo) 57 (milestone :initarg :milestone) 58 (body :initarg :body) 59 (assignees :closql-table (pullreq-assignee assignee)) 60 (project-cards) ; projectsCards 61 (commits) 62 (edits) ; userContentEdits 63 (labels :closql-table (pullreq-label label)) 64 (participants) 65 (posts :closql-class forge-pullreq-post) 66 (reactions) 67 (review-requests :closql-table (pullreq-review-request assignee)) 68 (reviews) 69 (timeline) 70 (marks :closql-table (pullreq-mark mark)) 71 (note :initarg :note :initform nil) 72 ;; We don't use these fields: 73 ;; includesCreatedEdit (huh?), 74 ;; lastEditedAt (same as updatedAt?), 75 ;; publishedAt (same as createdAt?), 76 ;; activeLockReason, additions, authorAssociation, (baseRefName), baseRefOid, 77 ;; bodyHTML, bodyText, canBeRebased, changedFiles, closed, createdViaEmail, 78 ;; databaseId, deletions, editor, (headRefName), headRefOid, mergeCommit, 79 ;; mergeStateStatus, mergeable, merged, mergedBy, permalink, 80 ;; potentialMergeCommit,, reactionGroups, resourcePath, revertResourcePath, 81 ;; revertUrl, url, viewer{*} 82 )) 83 84 (defclass forge-pullreq-post (forge-post) 85 ((closql-table :initform 'pullreq-post) 86 (closql-primary-key :initform 'id) 87 (closql-order-by :initform [(asc number)]) 88 (closql-foreign-key :initform 'pullreq) 89 (closql-class-prefix :initform "forge-pullreq-") 90 (id :initarg :id) 91 (pullreq :initarg :pullreq) 92 (number :initarg :number) 93 (author :initarg :author) 94 (created :initarg :created) 95 (updated :initarg :updated) 96 (body :initarg :body) 97 (edits) 98 (reactions) 99 ;; We don't use these fields: 100 ;; includesCreatedEdit (huh?), 101 ;; lastEditedAt (same as updatedAt?), 102 ;; publishedAt (same as createdAt?), 103 ;; pullRequest (same as issue), 104 ;; repository (use .pullreq.project), 105 ;; authorAssociation, bodyHTML, bodyText, createdViaEmail, 106 ;; editor, id, reactionGroups, resourcePath, url, viewer{*} 107 )) 108 109 ;;; Query 110 111 (cl-defmethod forge-get-repository ((post forge-pullreq-post)) 112 (forge-get-repository (forge-get-pullreq post))) 113 114 (cl-defmethod forge-get-topic ((post forge-pullreq-post)) 115 (forge-get-pullreq post)) 116 117 (cl-defmethod forge-get-pullreq ((pullreq forge-pullreq)) 118 pullreq) 119 120 (cl-defmethod forge-get-pullreq ((repo forge-repository) number) 121 (closql-get (forge-db) 122 (forge--object-id 'forge-pullreq repo number) 123 'forge-pullreq)) 124 125 (cl-defmethod forge-get-pullreq ((number integer)) 126 (when-let ((repo (forge-get-repository t))) 127 (forge-get-pullreq repo number))) 128 129 (cl-defmethod forge-get-pullreq ((id string)) 130 (closql-get (forge-db) id 'forge-pullreq)) 131 132 (cl-defmethod forge-get-pullreq ((post forge-pullreq-post)) 133 (closql-get (forge-db) 134 (oref post pullreq) 135 'forge-pullreq)) 136 137 (cl-defmethod forge-ls-pullreqs ((repo forge-repository) &optional type select) 138 (forge-ls-topics repo 'forge-pullreq type select)) 139 140 ;;; Utilities 141 142 (defun forge-read-pullreq (prompt &optional type) 143 (when (eq type t) 144 (setq type (if current-prefix-arg nil 'open))) 145 (let* ((default (forge-current-pullreq)) 146 (repo (forge-get-repository (or default t))) 147 (choices (mapcar 148 (apply-partially #'forge--topic-format-choice repo) 149 (forge-ls-pullreqs repo type [number title id class])))) 150 (cdr (assoc (magit-completing-read 151 prompt choices nil nil nil nil 152 (and default 153 (setq default (forge--topic-format-choice default)) 154 (member default choices) 155 (car default))) 156 choices)))) 157 158 (defun forge--pullreq-branch-internal (pullreq) 159 (let ((branch (oref pullreq head-ref))) 160 ;; It is invalid for a branch name to begin with a colon, yet 161 ;; that is what Gitlab uses when a pull-request's source branch 162 ;; has been deleted. On Github this is simply nil in the same 163 ;; situation. 164 (and branch (not (string-prefix-p ":" branch)) branch))) 165 166 (defun forge--pullreq-branch-active (pullreq) 167 (let* ((number (number-to-string (oref pullreq number))) 168 (branch-n (format "pr-%s" number)) 169 (branch (forge--pullreq-branch-internal pullreq))) 170 (or (and (magit-branch-p branch) 171 (equal (magit-get "branch" branch "pullRequest") number) 172 branch) 173 (and (magit-branch-p branch-n) 174 (equal (magit-get "branch" branch-n "pullRequest") number) 175 branch-n)))) 176 177 (defun forge--pullreq-branch-select (pullreq) 178 (let* ((number (oref pullreq number)) 179 (branch-n (format "pr-%s" number)) 180 (branch (or (forge--pullreq-branch-internal pullreq) 181 branch-n))) 182 (when (member branch '("master" "next" "maint")) 183 (setq branch branch-n)) 184 (when (magit-branch-p branch) 185 (if (equal branch branch-n) 186 (unless (y-or-n-p (format "Reset existing branch %S? " branch)) 187 (user-error "Abort")) 188 (pcase (read-char-choice 189 (format "A branch named %S already exists. 190 191 This could be because you checked out this pull-request before, 192 in which case resetting might be the appropriate thing to do. 193 194 Or the contributor worked directly on their version of a branch 195 that also exists on the upstream, in which case you probably 196 should not reset because you would end up resetting your version. 197 198 Or you are trying to checkout a pull-request that you created 199 yourself, in which case you probably should not reset either. 200 201 [r]eset existing %S branch 202 [c]reate new \"pr-%s\" branch instead 203 [a]bort" branch branch number) '(?r ?c ?a)) 204 (?r) 205 (?c (setq branch branch-n) 206 (when (magit-branch-p branch) 207 (error "Oh no! %S already exists too" branch))) 208 (?a (user-error "Abort")))) 209 (message "")) 210 branch)) 211 212 (defun forge--pullreq-ref (pullreq) 213 (let ((ref (format "refs/pullreqs/%s" (oref pullreq number)))) 214 (and (magit-rev-verify ref) ref))) 215 216 (defun forge--pullreq-range (pullreq &optional endpoints) 217 (when-let ((head (forge--pullreq-ref pullreq))) 218 (concat (forge--get-remote) "/" (oref pullreq base-ref) 219 (if endpoints "..." "..") 220 head))) 221 222 (cl-defmethod forge-get-url ((pullreq forge-pullreq)) 223 (forge--format pullreq 'pullreq-url-format)) 224 225 ;;; Sections 226 227 (defun forge-current-pullreq () 228 (or (forge-pullreq-at-point) 229 (and (derived-mode-p 'forge-topic-mode) 230 (forge-pullreq-p forge-buffer-topic) 231 forge-buffer-topic) 232 (and (derived-mode-p 'forge-topic-list-mode) 233 (let ((topic (forge-get-topic (tabulated-list-get-id)))) 234 (and (forge-pullreq-p topic) 235 topic))))) 236 237 (defun forge-pullreq-at-point () 238 (or (magit-section-value-if 'pullreq) 239 (when-let ((post (magit-section-value-if 'post))) 240 (cond ((forge-pullreq-p post) 241 post) 242 ((forge-pullreq-post-p post) 243 (forge-get-pullreq post)))))) 244 245 (defvar forge-pullreqs-section-map 246 (let ((map (make-sparse-keymap))) 247 (define-key map [remap magit-browse-thing] 'forge-browse-pullreqs) 248 (define-key map [remap magit-visit-thing] 'forge-list-pullreqs) 249 (define-key map (kbd "C-c C-n") 'forge-create-pullreq) 250 map)) 251 252 (defvar forge-pullreq-section-map 253 (let ((map (make-sparse-keymap))) 254 (define-key map [remap magit-browse-thing] 'forge-browse-pullreq) 255 (define-key map [remap magit-visit-thing] 'forge-visit-pullreq) 256 map)) 257 258 (defun forge-insert-pullreqs () 259 "Insert a list of mostly recent and/or open pull-requests. 260 Also see option `forge-topic-list-limit'." 261 (when forge-display-in-status-buffer 262 (when-let ((repo (forge-get-repository nil))) 263 (unless (oref repo sparse-p) 264 (forge-insert-topics "Pull requests" 265 (forge-ls-recent-topics repo 'pullreq) 266 (forge--topic-type-prefix repo 'pullreq)))))) 267 268 (defun forge--insert-pullreq-commits (pullreq) 269 (when-let ((range (forge--pullreq-range pullreq))) 270 (magit-insert-section-body 271 (cl-letf (((symbol-function #'magit-cancel-section) (lambda ()))) 272 (magit-insert-log range magit-buffer-log-args) 273 (magit-make-margin-overlay nil t))))) 274 275 (cl-defmethod forge--insert-topic-contents :after ((pullreq forge-pullreq) 276 _width _prefix) 277 (unless (oref pullreq merged) 278 (magit-insert-heading) 279 (forge--insert-pullreq-commits pullreq))) 280 281 (cl-defmethod forge--format-topic-id ((pullreq forge-pullreq) &optional prefix) 282 (propertize (format "%s%s" 283 (or prefix (forge--topic-type-prefix pullreq)) 284 (oref pullreq number)) 285 'font-lock-face (if (oref pullreq merged) 286 'forge-topic-merged 287 'forge-topic-unmerged))) 288 289 (cl-defmethod forge--topic-type-prefix ((pullreq forge-pullreq)) 290 (if (forge--childp (forge-get-repository pullreq) 'forge-gitlab-repository) 291 "!" 292 "#")) 293 294 (defun forge-insert-assigned-pullreqs () 295 "Insert a list of open pull-requests that are assigned to you." 296 (when forge-display-in-status-buffer 297 (when-let ((repo (forge-get-repository nil))) 298 (unless (oref repo sparse-p) 299 (forge-insert-topics "Assigned pull requests" 300 (forge--ls-assigned-pullreqs repo) 301 (forge--topic-type-prefix repo 'pullreq)))))) 302 303 (defun forge--ls-assigned-pullreqs (repo) 304 (mapcar (lambda (row) 305 (closql--remake-instance 'forge-pullreq (forge-db) row)) 306 (forge-sql 307 [:select $i1 :from pullreq 308 :join pullreq_assignee :on (= pullreq_assignee:pullreq pullreq:id) 309 :join assignee :on (= pullreq_assignee:id assignee:id) 310 :where (and (= pullreq:repository $s2) 311 (= assignee:login $s3) 312 (isnull pullreq:closed)) 313 :order-by [(desc updated)]] 314 (vconcat (closql--table-columns (forge-db) 'pullreq t)) 315 (oref repo id) 316 (ghub--username repo)))) 317 318 (defun forge-insert-requested-reviews () 319 "Insert a list of pull-requests that are awaiting your review." 320 (when-let ((repo (forge-get-repository nil))) 321 (unless (oref repo sparse-p) 322 (forge-insert-topics "Pull requests awaiting review" 323 (forge--ls-requested-reviews repo) 324 (forge--topic-type-prefix repo 'pullreq))))) 325 326 (defun forge--ls-requested-reviews (repo) 327 (mapcar 328 (lambda (row) 329 (closql--remake-instance 'forge-pullreq (forge-db) row)) 330 (forge-sql 331 [:select $i1 :from pullreq 332 :join pullreq_review_request :on (= pullreq_review_request:pullreq pullreq:id) 333 :join assignee :on (= pullreq_review_request:id assignee:id) 334 :where (and (= pullreq:repository $s2) 335 (= assignee:login $s3) 336 (isnull pullreq:closed)) 337 :order-by [(desc updated)]] 338 (vconcat (closql--table-columns (forge-db) 'pullreq t)) 339 (oref repo id) 340 (ghub--username repo)))) 341 342 (defun forge-insert-authored-pullreqs () 343 "Insert a list of open pullreqs that are authored to you." 344 (when forge-display-in-status-buffer 345 (when-let ((repo (forge-get-repository nil))) 346 (unless (oref repo sparse-p) 347 (forge-insert-topics "Authored pullreqs" 348 (forge--ls-authored-pullreqs repo) 349 (forge--topic-type-prefix repo 'pullreq)))))) 350 351 (defun forge--ls-authored-pullreqs (repo) 352 (mapcar (lambda (row) 353 (closql--remake-instance 'forge-pullreq (forge-db) row)) 354 (forge-sql 355 [:select $i1 :from [pullreq] 356 :where (and (= pullreq:repository $s2) 357 (= pullreq:author $s3) 358 (isnull pullreq:closed)) 359 :order-by [(desc updated)]] 360 (vconcat (closql--table-columns (forge-db) 'pullreq t)) 361 (oref repo id) 362 (ghub--username repo)))) 363 364 ;;; _ 365 (provide 'forge-pullreq) 366 ;;; forge-pullreq.el ends here