forge-repo.el (15841B)
1 ;;; forge-repo.el --- Repository 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 'eieio) 28 29 ;;; Classes 30 31 (defclass forge-repository (forge-object) 32 ((closql-class-prefix :initform "forge-") 33 (closql-class-suffix :initform "-repository") 34 (closql-table :initform 'repository) 35 (closql-primary-key :initform 'id) 36 (issues-url-format :initform nil :allocation :class) 37 (issue-url-format :initform nil :allocation :class) 38 (issue-post-url-format :initform nil :allocation :class) 39 (pullreqs-url-format :initform nil :allocation :class) 40 (pullreq-url-format :initform nil :allocation :class) 41 (pullreq-post-url-format :initform nil :allocation :class) 42 (commit-url-format :initform nil :allocation :class) 43 (branch-url-format :initform nil :allocation :class) 44 (remote-url-format :initform nil :allocation :class) 45 (create-issue-url-format :initform nil :allocation :class) 46 (create-pullreq-url-format :initform nil :allocation :class) 47 (pullreq-refspec :initform nil :allocation :class) 48 (id :initform nil :initarg :id) 49 (forge-id :initform nil :initarg :forge-id) 50 (forge :initform nil :initarg :forge) 51 (owner :initform nil :initarg :owner) 52 (name :initform nil :initarg :name) 53 (apihost :initform nil :initarg :apihost) 54 (githost :initform nil :initarg :githost) 55 (remote :initform nil :initarg :remote) 56 (sparse-p :initform t) 57 (created :initform nil) 58 (updated :initform nil) 59 (pushed :initform nil) 60 (parent :initform nil) 61 (description :initform nil) 62 (homepage :initform nil) 63 (default-branch :initform nil) 64 (archived-p :initform nil) 65 (fork-p :initform nil) 66 (locked-p :initform nil) 67 (mirror-p :initform nil) 68 (private-p :initform nil) 69 (issues-p :initform t) 70 (wiki-p :initform nil) 71 (stars :initform nil) 72 (watchers :initform nil) 73 (assignees :closql-table assignee) 74 (forks :closql-table fork) 75 (issues :closql-class forge-issue) 76 (labels :closql-table label) 77 (pullreqs :closql-class forge-pullreq) 78 (revnotes :closql-class forge-revnote) 79 (selective-p :initform nil) 80 (worktree :initform nil) 81 (milestones :closql-table milestone)) 82 :abstract t) 83 84 (defclass forge-unusedapi-repository (forge-repository) () :abstract t) 85 86 (defclass forge-noapi-repository (forge-repository) () :abstract t) 87 88 ;;; Core 89 90 (cl-defmethod forge--repository-ids ((class (subclass forge-repository)) 91 host owner name &optional stub) 92 "Return (OUR-ID . THEIR-ID) of the specified repository. 93 If optional STUB is non-nil, then the IDs are not guaranteed to 94 be unique. Otherwise this method has to make an API request to 95 retrieve THEIR-ID, the repository's ID on the forge. In that 96 case OUR-ID derives from THEIR-ID and is unique across all 97 forges and hosts." 98 (pcase-let* ((`(,_githost ,apihost ,id ,_class) 99 (or (assoc host forge-alist) 100 (error "No entry for %S in forge-alist" host))) 101 (path (format "%s/%s" owner name)) 102 (their-id (and (not stub) 103 (ghub-repository-id 104 owner name 105 :host apihost 106 :auth 'forge 107 :forge (forge--ghub-type-symbol class))))) 108 (cons (base64-encode-string 109 (format "%s:%s" id 110 (cond (stub path) 111 ((eq class 'forge-github-repository) 112 ;; This is base64 encoded, according to 113 ;; https://docs.github.com/en/graphql/reference/scalars#id. 114 ;; Unfortunately that is not always true. 115 ;; E.g. https://github.com/dit7ya/roamex. 116 (condition-case nil 117 (base64-decode-string their-id) 118 (error their-id))) 119 (t their-id))) 120 t) 121 (or their-id path)))) 122 123 (cl-defmethod forge--repository-ids ((_class (subclass forge-noapi-repository)) 124 host owner name &optional _stub) 125 (let ((their-id (if owner (concat owner "/" name) name))) 126 (cons (base64-encode-string 127 (format "%s:%s" 128 (nth 3 (or (assoc host forge-alist) 129 (error "No entry for %S in forge-alist" host))) 130 their-id) 131 t) 132 their-id))) 133 134 (defvar-local forge-buffer-repository nil) 135 (put 'forge-buffer-repository 'permanent-local t) 136 137 (defconst forge--signal-no-entry '(t stub create)) 138 139 (cl-defmethod forge-get-repository (((_ id) (head :id))) 140 (closql-get (forge-db) id 'forge-repository)) 141 142 (cl-defmethod forge-get-repository ((demand symbol) &optional remote) 143 "Return the current forge repository. 144 145 If the `forge-buffer-repository' is non-nil, then return that. 146 Otherwise if `forge-buffer-topic' is non-nil, then return the 147 repository for that. Finally if both variables are nil, then 148 return the forge repository corresponding to the current Git 149 repository, if any." 150 (or forge-buffer-repository 151 (and forge-buffer-topic 152 (forge-get-repository forge-buffer-topic)) 153 (magit--with-refresh-cache 154 (list default-directory 'forge-get-repository demand) 155 (let* ((remotes (magit-list-remotes)) 156 (remote (or remote 157 (if (cdr remotes) 158 (car (member (forge--get-remote) remotes)) 159 (car remotes))))) 160 (if-let ((url (and remote 161 (magit-git-string "remote" "get-url" remote)))) 162 (when-let ((repo (forge-get-repository url remote demand))) 163 (oset repo worktree (magit-toplevel)) 164 repo) 165 (when (memq demand forge--signal-no-entry) 166 (error 167 "Cannot determine forge repository. %s\n%s %s" 168 (cond (remote (format "No url configured for %S." remote)) 169 (remotes "Cannot decide on remote to use.") 170 (t "No remote configured.")) 171 "You might have to set `forge.remote'." 172 "See https://magit.vc/manual/forge/Repository-Detection.html." 173 ))))))) 174 175 (cl-defmethod forge-get-repository ((url string) &optional remote demand) 176 "Return the repository at URL." 177 (if-let ((parts (forge--split-url url))) 178 (forge-get-repository parts remote demand) 179 (when (memq demand forge--signal-no-entry) 180 (error "Cannot determine forge repository. %s isn't a forge url" url)))) 181 182 (cl-defmethod forge-get-repository (((host owner name) list) 183 &optional remote demand) 184 "((host owner name) &optional remote demand) 185 186 Return the repository identified by HOST, OWNER and NAME." 187 (if-let ((spec (assoc host forge-alist))) 188 (pcase-let ((`(,githost ,apihost ,forge ,class) spec)) 189 (let* ((row (car (forge-sql [:select * :from repository 190 :where (and (= forge $s1) 191 (= owner $s2) 192 (= name $s3))] 193 forge owner name))) 194 (obj (and row (closql--remake-instance class (forge-db) row)))) 195 (when obj 196 (oset obj apihost apihost) 197 (oset obj githost githost) 198 (oset obj remote remote)) 199 (cond ((and (eq demand t) 200 (or (not obj) 201 (oref obj sparse-p))) 202 (error "Cannot use `%s' in %S yet.\n%s" 203 this-command (magit-toplevel) 204 "Use `M-x forge-add-repository' before trying again.")) 205 ((and (eq demand 'full) obj 206 (oref obj sparse-p)) 207 (setq obj nil))) 208 (when (and (memq demand '(stub create)) 209 (not obj)) 210 (pcase-let ((`(,id . ,forge-id) 211 (forge--repository-ids class host owner name 212 (eq demand 'stub)))) 213 ;; The repo might have been renamed on the forge. #188 214 (unless (setq obj (forge-get-repository (list :id id))) 215 (setq obj (funcall class 216 :id id 217 :forge-id forge-id 218 :forge forge 219 :owner owner 220 :name name 221 :apihost apihost 222 :githost githost 223 :remote remote)) 224 (when (eq demand 'create) 225 (closql-insert (forge-db) obj))))) 226 obj)) 227 (when (memq demand forge--signal-no-entry) 228 (error "Cannot determine forge repository. No entry for %S in %s" 229 host 'forge-alist)))) 230 231 (cl-defmethod forge-get-repository ((repo forge-repository)) 232 repo) 233 234 ;;; Utilities 235 236 (defun forge-repository-at-point () 237 (magit-section-value-if 'forge-repo)) 238 239 (defun forge-current-repository () 240 (or (forge-repository-at-point) 241 (and (derived-mode-p 'forge-repository-list-mode) 242 (forge-get-repository (list :id (tabulated-list-get-id)))))) 243 244 (cl-defmethod forge-visit ((repo forge-repository)) 245 (let ((worktree (oref repo worktree))) 246 (if (and worktree (file-directory-p worktree)) 247 (magit-status-setup-buffer worktree) 248 (forge-list-issues (oref repo id))))) 249 250 (defun forge--get-remote () 251 (or (magit-get "forge.remote") "origin")) 252 253 (defun forge-read-repository (prompt) 254 (let ((choice (magit-completing-read 255 prompt 256 (mapcar (pcase-lambda (`(,host ,owner ,name)) 257 (format "%s/%s @%s" owner name host)) 258 (forge-sql [:select [githost owner name] 259 :from repository])) 260 nil t nil nil 261 (when-let ((default (or (forge-current-repository) 262 (forge-get-repository nil)))) 263 (format "%s/%s @%s" 264 (oref default owner) 265 (oref default name) 266 (oref default githost)))))) 267 (save-match-data 268 (if (string-match "\\`\\(.+\\)/\\([^/]+\\) @\\(.+\\)\\'" choice) 269 (list (match-string 3 choice) 270 (match-string 1 choice) 271 (match-string 2 choice)) 272 (error "BUG"))))) 273 274 (defun forge-read-host (prompt &optional class) 275 (magit-completing-read 276 prompt 277 (if class 278 (-keep (pcase-lambda (`(,githost ,_apihost ,_id ,c)) 279 (and (child-of-class-p c class) githost)) 280 forge-alist) 281 (mapcar #'car forge-alist)) 282 nil t)) 283 284 (defun forge--as-githost (host) 285 (or (car (car (cl-member host forge-alist :test #'equal :key #'car))) 286 (car (car (cl-member host forge-alist :test #'equal :key #'cadr))) 287 (car (car (cl-member host forge-alist :test #'equal :key #'caddr))) 288 (user-error "Cannot determine githost for %S" host))) 289 290 (defun forge--as-apihost (host) 291 (or (cadr (car (cl-member host forge-alist :test #'equal :key #'cadr))) 292 (cadr (car (cl-member host forge-alist :test #'equal :key #'car))) 293 (cadr (car (cl-member host forge-alist :test #'equal :key #'caddr))) 294 (user-error "Cannot determine githost for %S" host))) 295 296 (cl-defmethod forge--topics-until ((repo forge-repository) until table) 297 (if (oref repo sparse-p) 298 until 299 (caar (forge-sql [:select [updated] :from $i1 300 :where (= repository $s2) 301 :order-by [(desc updated)] 302 :limit 1] 303 table (oref repo id))))) 304 305 (cl-defmethod forge--format ((repo forge-repository) format-or-slot &optional spec) 306 (format-spec 307 (if (symbolp format-or-slot) 308 (eieio-oref repo format-or-slot) 309 format-or-slot) 310 (with-slots (githost owner name) repo 311 (let ((path (if owner (concat owner "/" name) name))) 312 `(,@spec 313 (?h . ,githost) 314 (?o . ,owner) 315 (?n . ,name) 316 (?p . ,path) 317 (?P . ,(replace-regexp-in-string "/" "%2F" path))))))) 318 319 (cl-defmethod forge-get-url ((repo forge-repository)) 320 (forge--format (oref repo remote) 'remote-url-format)) 321 322 (defun forge--set-field-callback () 323 (let ((buf (current-buffer))) 324 (lambda (&rest _) 325 (with-current-buffer 326 (or buf (current-buffer)) 327 (forge-pull))))) 328 329 (defvar forge--mode-line-buffer nil) 330 331 (defun forge--msg (repo echo done format &rest args) 332 (let ((msg (apply #'format format args))) 333 (when repo 334 (setq msg (replace-regexp-in-string 335 "REPO" 336 (concat (oref repo owner) "/" (oref repo name)) 337 msg t))) 338 (when (and echo msg) 339 (message "%s%s" msg (if done "...done" "..."))) 340 (when (buffer-live-p forge--mode-line-buffer) 341 (with-current-buffer forge--mode-line-buffer 342 (setq mode-line-process 343 (if done 344 nil 345 (concat " " (propertize msg 'font-lock-face 346 'magit-mode-line-process))))) 347 (force-mode-line-update t)))) 348 349 (cl-defmethod ghub--host ((repo forge-repository)) 350 (cl-call-next-method (forge--ghub-type-symbol (eieio-object-class repo)))) 351 352 (cl-defmethod ghub--username ((repo forge-repository)) 353 (let ((sym (forge--ghub-type-symbol (eieio-object-class repo)))) 354 (cl-call-next-method (ghub--host sym) sym))) 355 356 (defun forge--ghub-type-symbol (class) 357 (cl-ecase class 358 ;; This package does not define a `forge-gitlab-http-repository' 359 ;; class, but we suggest at #9 that users define such a class if 360 ;; they must connect to a Gitlab instance that uses http instead 361 ;; of https. 362 ((forge-gitlab-repository forge-gitlab-http-repository) 'gitlab) 363 (forge-github-repository 'github) 364 (forge-gitea-repository 'gitea) 365 (forge-gogs-repository 'gogs) 366 (forge-bitbucket-repository 'bitbucket))) 367 368 ;;; _ 369 (provide 'forge-repo) 370 ;;; forge-repo.el ends here