forge-core.el (12780B)
1 ;;; forge-core.el --- Core functionality -*- 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 'magit) 27 28 (require 'cl-lib) 29 (require 'dash) 30 (require 'eieio) 31 (require 'subr-x) 32 33 (require 'transient) 34 35 (require 'forge-db) 36 37 (eval-when-compile 38 (cl-pushnew 'id eieio--known-slot-names) 39 (cl-pushnew 'name eieio--known-slot-names) 40 (cl-pushnew 'owner eieio--known-slot-names) 41 (cl-pushnew 'number eieio--known-slot-names)) 42 43 ;;; Options 44 45 (defgroup forge nil 46 "Options concerning Git forges." 47 :group 'magit) 48 49 (defgroup forge-faces nil 50 "Faces concerning Git forges." 51 :group 'forge 52 :group 'magit-faces) 53 54 (defcustom forge-alist 55 '(;; Forges 56 ("github.com" "api.github.com" 57 "github.com" forge-github-repository) 58 ("gitlab.com" "gitlab.com/api/v4" 59 "gitlab.com" forge-gitlab-repository) 60 ("salsa.debian.org" "salsa.debian.org/api/v4" 61 "salsa.debian.org" forge-gitlab-repository) 62 ("framagit.org" "framagit.org/api/v4" 63 "framagit.org" forge-gitlab-repository) 64 ("gitlab.gnome.org" "gitlab.gnome.org/api/v4" 65 "gitlab.gnome.org" forge-gitlab-repository) 66 ;; Forges (API unsupported) 67 ("codeberg.org" "codeberg.org/api/v1" 68 "codeberg.org" forge-gitea-repository) 69 ("code.orgmode.org" "code.orgmode.org/api/v1" 70 "code.orgmode.org" forge-gogs-repository) 71 ("bitbucket.org" "api.bitbucket.org/2.0" 72 "bitbucket.org" forge-bitbucket-repository) 73 ;; Semi-Forges 74 ("git.savannah.gnu.org" nil 75 "git.savannah.gnu.org" forge-cgit**-repository) 76 ("git.kernel.org" nil 77 "git.kernel.org" forge-cgit-repository) 78 ("repo.or.cz" nil 79 "repo.or.cz" forge-repoorcz-repository) 80 ("git.suckless.org" nil 81 "git.suckless.org" forge-stagit-repository) 82 ("git.sr.ht" nil 83 "git.sr.ht" forge-srht-repository)) 84 "List of Git forges. 85 86 Each entry has the form (GITHOST APIHOST ID CLASS). 87 88 GITHOST is matched against the host part of Git remote urls 89 using `forge--url-regexp' to identify the forge. 90 APIHOST is the api endpoint of the forge's api. 91 ID is used to identify the forge in the local database. 92 CLASS is the class to be used for repository from the forge. 93 94 GITHOST and APIHOST can be changed, but ID and CLASS are final. 95 If you change ID, then the identity of every repository from 96 that forge changes. If you change CLASS, then things start 97 falling apart. 98 99 There can be multiple elements that only differ in GITHOST. 100 Among those, the canonical element should come first. Any 101 elements that have the same APIHOST must also have the same 102 ID, and vice-versa. 103 104 Complications: 105 106 * When connecting to a Github Enterprise edition whose REST 107 API's end point is \"<host>/v3\" and whose GraphQL API's 108 end point is \"<host>/graphql\", then use \"<host>/v3\" as 109 APIHOST. This is a historic accident. See issue #174." 110 :package-version '(forge . "0.1.0") 111 :group 'forge 112 :type '(repeat (list (string :tag "Git host") 113 (choice (string :tag "API endpoint") 114 (const :tag "No API" nil)) 115 (string :tag "ID") 116 (symbol :tag "Repository class")))) 117 118 (defcustom forge-pull-notifications nil 119 "Whether `forge-pull' also fetches notifications. 120 If this is nil, then `forge-pull-notifications' has to be used." 121 :package-version '(forge . "0.2.0") 122 :group 'forge 123 :type 'boolean) 124 125 ;;; Core 126 127 (defclass forge-object (closql-object) () :abstract t) 128 129 (cl-defgeneric forge-get-parent (object) 130 "Return the parent object of OBJECT. 131 The hierarchy is repository > topic > post. 132 For other objects return nil.") 133 134 (cl-defgeneric forge-get-repository (demand) 135 "Return a forge repository object or nil, or signal an error. 136 137 The DEMAND argument controls what to do when the object isn't 138 stored in the database yet, or if it is marked as sparse. The 139 valid values are: 140 141 * `nil' If the repository is stored in the database then return 142 it, even if it is sparse. Otherwise return nil. 143 144 * `t' If the repository isn't stored in the database or if the 145 object is sparse, then signal an error, informing the user 146 that `this-command' cannot be run until the repository has 147 been pulled. 148 149 * `full' If the repository is stored in the database and the 150 object isn't sparse, then return it. Otherwise return nil. 151 152 * `stub' If the repository is stored in the database, then return 153 it, regardless of whether it is sparse or not. Otherwise create 154 a new object and return it, but do not store it in the database. 155 In the latter case it is assumed that the caller does not need 156 the `id' and `forge-id' slots whose value differ from what they 157 would be if the object were retrieved from the database. 158 159 * `create' This value is only intended to be used by commands 160 that fetch data from the API. If the repository is stored in 161 the database, then return that, regardless of whether the 162 object is sparse or not. If the repository is not stored in the 163 database, then make an API request to determine the ID used on 164 the forge, derive our own ID from that, and store a new sparse 165 object in the database and return it. 166 167 If DEMAND is t, `stub' or `create', then also signal an error if 168 the repository cannot be determined because there is no matching 169 entry in `forge-alist'. 170 171 Also update the object's `apihost', `githost' and `remote' slots 172 according to the respective entry in `forge-alist' and the REMOTE 173 argument.") 174 175 (cl-defgeneric forge-get-topic () 176 "Return a forge issue or pullreq object.") 177 178 (cl-defgeneric forge-get-issue () 179 "Return a forge issue object.") 180 181 (cl-defgeneric forge-get-pullreq () 182 "Return a forge pullreq object.") 183 184 (cl-defgeneric forge-get-url (obj) 185 "Return the URL for a forge object.") 186 187 (cl-defgeneric forge-browse (obj) 188 "Visit the URL corresponding to a forge object in a browser." 189 (browse-url (forge-get-url obj))) 190 191 (cl-defgeneric forge-visit (obj) 192 "View a forge object in a separate buffer.") 193 194 (cl-defgeneric forge--object-id (class &rest args) 195 "Return the database id for the CLASS object specified by ARGS.") 196 197 (cl-defgeneric forge--repository-ids (class host owner name &optional stub) 198 "Return the database and forge ids for the specified CLASS object.") 199 200 (cl-defmethod magit-section-ident-value ((obj forge-object)) 201 (oref obj id)) 202 203 ;;; Utilities 204 205 (defmacro forge--childp (obj type) 206 "Somewhat similar to `cl-typep' but only for (possibly unknown) classes. 207 TYPE is evaluated at macro-expansion time but unlike with 208 `cl-typep' the respective class does not have to be defined 209 at that time." 210 (let ((fn (intern (concat (symbol-name (eval type)) "--eieio-childp")))) 211 `(and (fboundp ',fn) (,fn ,obj)))) 212 213 (defun forge--set-id-slot (repo object slot rows) 214 (let ((repo-id (oref repo id))) 215 (closql-oset 216 object slot 217 (mapcar (lambda (val) 218 (forge--object-id repo-id 219 (if (atom val) val (alist-get 'id val)))) 220 rows)))) 221 222 (cl-defgeneric forge--format (object slot &optional spec)) 223 224 (cl-defmethod forge--format ((remote string) slot &optional spec) 225 (if-let ((parts (forge--split-remote-url remote))) 226 (forge--format 227 (forge-get-repository 'stub remote) slot 228 (pcase-let* ((`(,host ,owner ,name) parts) 229 (path (if owner (concat owner "/" name) name))) 230 `(,@spec 231 (?h . ,host) 232 (?o . ,owner) 233 (?n . ,name) 234 (?p . ,path) 235 (?P . ,(replace-regexp-in-string "/" "%2F" path))))) 236 (user-error "Cannot browse non-forge remote %s" remote))) 237 238 (defun forge--url-regexp () 239 (concat "\\`\\(?:git://\\|" 240 "[^/@]+@\\|" 241 "\\(?:ssh\\|ssh\\+git\\|git\\+ssh\\)://\\(?:[^/@]+@\\)?\\|" 242 "https?://\\(?:[^/@]+@\\)?\\)?" 243 (regexp-opt (mapcar #'car forge-alist) t) 244 "\\(?::[0-9]+\\)?" 245 "\\(?:/\\|:/?\\)" 246 "\\(.+?\\)" 247 "\\(?:\\.git\\|/\\)?\\'")) 248 249 (defun forge--split-remote-url (remote) 250 (when-let ((url (magit-git-string "remote" "get-url" remote))) 251 (forge--split-url url))) 252 253 (defun forge--split-url (url) 254 (and (string-match (forge--url-regexp) url) 255 (when-let ((host (match-string 1 url)) 256 (path (match-string 2 url)) 257 (path (forge--split-url-path 258 (nth 3 (assoc host forge-alist)) 259 path))) 260 (cons host path)))) 261 262 (cl-defmethod forge--split-url-path 263 ((_class (subclass forge-repository)) path) 264 (and (string-match "\\`\\([^/]+\\)/\\([^/]+?\\)\\'" path) 265 (list (match-string 1 path) 266 (match-string 2 path)))) 267 268 (cl-defmethod forge--split-url-path 269 ((_class (subclass forge-noapi-repository)) path) 270 (and (string-match "\\`\\(?:~?\\(.+\\)/\\)?\\([^/]+?\\)\\'" path) 271 (list (match-string 1 path) 272 (match-string 2 path)))) 273 274 (defun forge--url-p (url) 275 (save-match-data 276 (and (string-match (forge--url-regexp) url) 277 (nth 2 (assoc (match-string 1 url) forge-alist))))) 278 279 (defun forge--forge-remote-p (remote) 280 (when-let ((url (magit-git-string "remote" "get-url" remote))) 281 (forge--url-p url))) 282 283 (defun forge--url-equal (urlA urlB) 284 (or (equal urlA urlB) 285 (save-match-data 286 (let ((re (forge--url-regexp)) 287 hostA repoA hostB repoB) 288 (and (when (string-match re urlA) 289 (setq hostA (match-string 1 urlA)) 290 (setq repoA (match-string 2 urlA))) 291 (when (string-match re urlB) 292 (setq hostB (match-string 1 urlB)) 293 (setq repoB (match-string 2 urlB))) 294 (equal repoA repoB) 295 (equal (cl-caddr (assoc hostA forge-alist)) 296 (cl-caddr (assoc hostB forge-alist)))))))) 297 298 (cl-defmethod forge--format-resource ((object forge-object) resource) 299 (save-match-data 300 (setq resource 301 (replace-regexp-in-string 302 ":\\([^/]+\\)" 303 (lambda (str) 304 (let ((slot (intern (substring str 1)))) 305 (or (when-let 306 ((v (ignore-errors 307 (cl-case slot 308 (repo (oref object name)) 309 (project (concat (replace-regexp-in-string 310 "/" "%2F" (oref object owner)) 311 "%2F" 312 (oref object name))) 313 (topic (and (forge--childp object 'forge-topic) 314 (oref object number))) 315 (t (eieio-oref object slot)))))) 316 (format "%s" v)) 317 str))) 318 resource t t)) 319 (if (string-match ":[^/]*" resource) 320 (if-let ((parent (ignore-errors (forge-get-parent object)))) 321 (forge--format-resource parent resource) 322 (error "Cannot resolve %s for a %s" 323 (match-string 0 resource) 324 (eieio-object-class object))) 325 resource))) 326 327 ;; This is a copy of `org-id-uuid'. 328 (defun forge--uuid () 329 "Return string with random (version 4) UUID." 330 (let ((rnd (md5 (format "%s%s%s%s%s%s%s" 331 (random) 332 (current-time) 333 (user-uid) 334 (emacs-pid) 335 (user-full-name) 336 user-mail-address 337 (recent-keys))))) 338 (format "%s-%s-4%s-%s%s-%s" 339 (substring rnd 0 8) 340 (substring rnd 8 12) 341 (substring rnd 13 16) 342 (format "%x" 343 (logior 344 #b10000000 345 (logand 346 #b10111111 347 (string-to-number 348 (substring rnd 16 18) 16)))) 349 (substring rnd 18 20) 350 (substring rnd 20 32)))) 351 352 ;;; _ 353 (provide 'forge-core) 354 ;;; forge-core.el ends here