dotfiles/emacs/.emacs.d/elpa/forge-20260815.1911/forge-db.el

680 lines
21 KiB
EmacsLisp

;;; forge-db.el --- Database implementation -*- lexical-binding:t -*-
;; Copyright (C) 2018-2026 Jonas Bernoulli
;; Author: Jonas Bernoulli <emacs.forge@jonas.bernoulli.dev>
;; Maintainer: Jonas Bernoulli <emacs.forge@jonas.bernoulli.dev>
;; SPDX-License-Identifier: GPL-3.0-or-later
;; This file is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; This file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this file. If not, see <https://www.gnu.org/licenses/>.
;;; Code:
(require 'closql)
(require 'compat)
(require 'eieio)
(require 'emacsql)
;; For `closql--db-update-schema':
(declare-function forge--object-id "forge-core")
(declare-function forge-get-issue "forge-core")
(declare-function forge-get-pullreq "forge-core")
(declare-function forge-get-repository "forge-core" (demand))
(eval-when-compile
(cl-pushnew 'milestone eieio--known-slot-names) ; forge-{issue,pullreq}
(cl-pushnew 'number eieio--known-slot-names)) ; forge-{issue,pullreq,...}
;;; Options
(defcustom forge-database-file
(expand-file-name "forge-database.sqlite" user-emacs-directory)
"The file used to store the forge database."
:package-version '(forge . "0.1.0")
:group 'forge
:type 'file)
;;; Core
(defclass forge-database (closql-database)
((name :initform "Forge")
(object-class :initform 'forge-repository)
(file :initform 'forge-database-file)
(schemata :initform 'forge--db-table-schemata)
(version :initform 15)))
(defvar forge--override-connection-class nil)
(defun forge-db (&optional livep)
(closql-db 'forge-database livep forge--override-connection-class))
(defun forge-sql (sql &rest args)
(if (stringp sql)
(emacsql (forge-db) (apply #'format sql args))
(apply #'emacsql (forge-db) sql args)))
(defun forge-sql1 (sql &rest args)
(caar (apply #'forge-sql sql args)))
(defun forge-sql-car (sql &rest args)
(mapcar #'car (apply #'forge-sql sql args)))
(defun forge-sql-cdr (sql &rest args)
(mapcar #'cdr (apply #'forge-sql sql args)))
(defun forge-connect-database-once ()
"Try to connect Forge database on first use of `magit-status' only."
(remove-hook 'magit-status-mode-hook #'forge-connect-database-once)
(forge-db))
(add-hook 'magit-status-mode-hook #'forge-connect-database-once)
(defun forge-enable-sql-logging ()
"Enable logging Forge's SQL queries."
(interactive)
(let ((conn (oref (forge-db) connection)))
(emacsql-enable-debugging conn)
(switch-to-buffer-other-window (oref conn log-buffer))))
;;; Schemata
(defconst forge--db-table-schemata
'((repository
[(class :not-null)
(id :not-null :primary-key)
forge-id
forge
owner
name
apihost
githost
remote
condition
created
updated
pushed
parent
description
homepage
default-branch
archived-p
fork-p
locked-p
mirror-p
private-p
issues-p
wiki-p
stars
watchers
(assignees :default eieio-unbound)
(forks :default eieio-unbound)
(issues :default eieio-unbound)
(labels :default eieio-unbound)
(revnotes :default eieio-unbound)
(pullreqs :default eieio-unbound)
selective-p
worktree
(milestones :default eieio-unbound)
issues-until
pullreqs-until
teams
(discussion-categories :default eieio-unbound)
(discussions :default eieio-unbound)
discussions-p
discussions-until
])
(assignee
[(repository :not-null)
(id :not-null :primary-key)
login
name
forge-id]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(discussion
[(class :not-null)
(id :not-null :primary-key)
repository
number
answer
state
author
title
created
updated
closed
status
locked-p
category
body
(cards :default eieio-unbound)
(edits :default eieio-unbound)
(labels :default eieio-unbound)
(participants :default eieio-unbound)
(posts :default eieio-unbound)
(reactions :default eieio-unbound)
(timeline :default eieio-unbound)
(marks :default eieio-unbound)
note
their-id
slug
saved-p]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(discussion-category
[(repository :not-null)
(id :not-null :primary-key)
their-id
name
emoji
answerable-p
description]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(discussion-label
[(discussion :not-null)
(id :not-null)]
(:foreign-key
[discussion] :references discussion [id]
:on-delete :cascade)
(:foreign-key
[id] :references label [id]
:on-delete :cascade))
(discussion-mark
[(discussion :not-null)
(id :not-null)]
(:foreign-key
[discussion] :references discussion [id]
:on-delete :cascade)
(:foreign-key
[id] :references mark [id]
:on-delete :cascade))
(discussion-post ; aka top-level answer
[(class :not-null)
(id :not-null :primary-key)
their-id
number
discussion
author
created
updated
body
(edits :default eieio-unbound)
(reactions :default eieio-unbound)
(replies :default eieio-unbound)]
(:foreign-key
[discussion] :references discussion [id]
:on-delete :cascade))
(discussion-reply ; aka nested reply to top-level answer
[(class :not-null)
(id :not-null :primary-key)
their-id
number
post
discussion
author
created
updated
body
(edits :default eieio-unbound)
(reactions :default eieio-unbound)]
(:foreign-key
[post] :references discussion-post [id]
:on-delete :cascade)
(:foreign-key
[discussion] :references discussion [id]
:on-delete :cascade))
(fork
[(parent :not-null)
(id :not-null :primary-key)
owner
name]
(:foreign-key
[parent] :references repository [id]
:on-delete :cascade))
(issue
[(class :not-null)
(id :not-null :primary-key)
repository
number
state
author
title
created
updated
closed
status
locked-p
milestone
body
(assignees :default eieio-unbound)
(cards :default eieio-unbound)
(edits :default eieio-unbound)
(labels :default eieio-unbound)
(participants :default eieio-unbound)
(posts :default eieio-unbound)
(reactions :default eieio-unbound)
(timeline :default eieio-unbound)
(marks :default eieio-unbound)
note
their-id
slug
saved-p]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(issue-assignee
[(issue :not-null)
(id :not-null)]
(:foreign-key
[issue] :references issue [id]
:on-delete :cascade))
(issue-label
[(issue :not-null)
(id :not-null)]
(:foreign-key
[issue] :references issue [id]
:on-delete :cascade)
(:foreign-key
[id] :references label [id]
:on-delete :cascade))
(issue-mark
[(issue :not-null)
(id :not-null)]
(:foreign-key
[issue] :references issue [id]
:on-delete :cascade)
(:foreign-key
[id] :references mark [id]
:on-delete :cascade))
(issue-post
[(class :not-null)
(id :not-null :primary-key)
issue
number
author
created
updated
body
(edits :default eieio-unbound)
(reactions :default eieio-unbound)]
(:foreign-key
[issue] :references issue [id]
:on-delete :cascade))
(label
[(repository :not-null)
(id :not-null :primary-key)
name
color
description]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(mark
[;; For now this is always nil because it seems more useful to
;; share marks between repositories. We cannot omit this slot
;; though because `closql--iref' expects `id' to be the second
;; slot.
repository
(id :not-null :primary-key)
name
face
description])
(milestone
[(repository :not-null)
(id :not-null :primary-key)
number
title
created
updated
due
closed
description]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(notification
[(class :not-null)
(id :not-null :primary-key)
thread-id
repository
type
topic
url
title
reason
last-read
updated]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(pullreq
[(class :not-null)
(id :not-null :primary-key)
repository
number
state
author
title
created
updated
closed
merged
status
locked-p
editable-p
cross-repo-p
base-ref
base-repo
head-ref
head-user
head-repo
milestone
body
(assignees :default eieio-unbound)
(cards :default eieio-unbound)
(commits :default eieio-unbound)
(edits :default eieio-unbound)
(labels :default eieio-unbound)
(participants :default eieio-unbound)
(posts :default eieio-unbound)
(reactions :default eieio-unbound)
(review-requests :default eieio-unbound)
(reviews :default eieio-unbound)
(timeline :default eieio-unbound)
(marks :default eieio-unbound)
note
base-rev
head-rev
draft-p
their-id
slug
saved-p]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))
(pullreq-assignee
[(pullreq :not-null)
(id :not-null)]
(:foreign-key
[pullreq] :references pullreq [id]
:on-delete :cascade))
(pullreq-label
[(pullreq :not-null)
(id :not-null)]
(:foreign-key
[pullreq] :references pullreq [id]
:on-delete :cascade)
(:foreign-key
[id] :references label [id]
:on-delete :cascade))
(pullreq-mark
[(pullreq :not-null)
(id :not-null)]
(:foreign-key
[pullreq] :references pullreq [id]
:on-delete :cascade)
(:foreign-key
[id] :references mark [id]
:on-delete :cascade))
(pullreq-post
[(class :not-null)
(id :not-null :primary-key)
pullreq
number
author
created
updated
body
(edits :default eieio-unbound)
(reactions :default eieio-unbound)]
(:foreign-key
[pullreq] :references pullreq [id]
:on-delete :cascade))
(pullreq-review-request
[(pullreq :not-null)
(id :not-null)]
(:foreign-key
[pullreq] :references pullreq [id]
:on-delete :cascade))
(revnote
[(class :not-null)
(id :not-null :primary-key)
repository
commit
file
line
author
body]
(:foreign-key
[repository] :references repository [id]
:on-delete :cascade))))
(cl-defmethod closql--db-update-schema ((db forge-database))
(let ((version (closql--db-get-version db)))
(when (< version (oref-default 'forge-database version))
(forge--backup-database db)
(closql-with-transaction db
(forge--db-update-schema db version)))
(cl-call-next-method)))
(defun forge--db-update-schema (db version)
(cl-macrolet
((up (to &rest body)
`(when (= (1+ version) ,to)
(message "Upgrading Forge database from version %s to %s..."
version ,to)
,@body
(closql--db-set-version db ,to)
(message "Upgrading Forge database from version %s to %s...done"
version ,to)
(setq version ,to))))
(up 3
(emacsql db [:create-table pullreq-review-request $S1]
(cdr (assq 'pullreq-review-request forge--db-table-schemata))))
(up 4
(emacsql db [:drop-table notification])
(pcase-dolist (`(,table . ,schema) forge--db-table-schemata)
(when (memq table '(notification
mark issue-mark pullreq-mark))
(emacsql db [:create-table $i1 $S2] table schema)))
(emacsql db [:alter-table issue :add-column marks :default $s1] 'eieio-unbound)
(emacsql db [:alter-table pullreq :add-column marks :default $s1] 'eieio-unbound))
(up 5
(emacsql db [:alter-table repository :add-column selective-p :default nil]))
(up 6
(emacsql db [:alter-table repository :add-column worktree :default nil]))
(up 7
(emacsql db [:alter-table issue :add-column note :default nil])
(emacsql db [:alter-table pullreq :add-column note :default nil])
(emacsql db [:create-table milestone $S1]
(cdr (assq 'milestone forge--db-table-schemata)))
(emacsql db [:alter-table repository :add-column milestones :default $s1]
'eieio-unbound)
(pcase-dolist (`(,repo-id ,issue-id ,milestone)
(emacsql db [:select [repository id milestone]
:from issue
:where (notnull milestone)]))
(unless (stringp milestone)
(oset (forge-get-issue issue-id) milestone
(forge--object-id repo-id (cdar milestone)))))
(pcase-dolist (`(,repo-id ,pullreq-id ,milestone)
(emacsql db [:select [repository id milestone]
:from pullreq
:where (notnull milestone)]))
(unless (stringp milestone)
(oset (forge-get-pullreq pullreq-id) milestone
(forge--object-id repo-id (cdar milestone))))))
(up 8
(emacsql db [:alter-table pullreq :add-column base-rev :default nil])
(emacsql db [:alter-table pullreq :add-column head-rev :default nil])
(emacsql db [:alter-table pullreq :add-column draft-p :default nil]))
(up 9
(emacsql db [:alter-table pullreq :add-column their-id :default nil])
(emacsql db [:alter-table issue :add-column their-id :default nil]))
(up 10
(emacsql db [:alter-table pullreq :add-column slug :default nil])
(emacsql db [:alter-table issue :add-column slug :default nil])
(pcase-dolist (`(,id ,number ,type)
(emacsql
db
[:select [pullreq:id pullreq:number repository:class]
:from pullreq
:join repository
:on (= pullreq:repository repository:id)]))
(let ((gitlabp (memq type
(append (closql-where-class-in
'forge-gitlab-repository--eieio-childp)
nil))))
(emacsql db [:update pullreq :set (= slug $s1) :where (= id $s2)]
(format "%s%s" (if gitlabp "!" "#") number)
id)))
(pcase-dolist (`(,id ,number)
(emacsql db [:select [id number] :from issue]))
(emacsql db [:update issue :set (= slug $s1) :where (= id $s2)]
(format "#%s" number)
id)))
(up 11
(emacsql db [:drop-table notification])
(emacsql db [:create-table notification $S1]
(cdr (assq 'notification forge--db-table-schemata)))
(emacsql db [:alter-table pullreq :rename-column unread-p :to status])
(emacsql db [:alter-table issue :rename-column unread-p :to status])
(emacsql db [:alter-table pullreq :add-column saved-p :default nil])
(emacsql db [:alter-table issue :add-column saved-p :default nil]))
(up 12
(emacsql db [:drop-table notification])
(emacsql db [:create-table notification $S1]
(cdr (assq 'notification forge--db-table-schemata)))
(dolist (id (emacsql db [:select id :from issue :where (= state 'closed)]))
(emacsql db [:update issue :set (= state 'completed) :where (= id $s1)]
id))
(dolist (id (emacsql db [:select id :from issue :where (isnull status)]))
(emacsql db [:update issue :set (= state 'done) :where (= id $s1)]
id))
(dolist (id (emacsql db [:select id :from pullreq :where (= state 'closed)]))
(emacsql db [:update pullreq :set (= state 'rejected) :where (= id $s1)]
id))
(dolist (id (emacsql db [:select id :from pullreq :where (isnull status)]))
(emacsql db [:update pullreq :set (= state 'done) :where (= id $s1)]
id))
(emacsql db [:alter-table repository :add-column issues-until :default nil])
(emacsql db [:alter-table repository :add-column pullreqs-until :default nil]))
(up 13
(dolist (id (emacsql db [:select id :from repository
:where (isnull issues-until)]))
(emacsql
db [:update repository :set (= issues-until $s1) :where (= id $s2)]
(forge-sql1 [:select [updated] :from issue
:where (= repository $s1)
:order-by [(desc updated)]
:limit 1]
id)
id))
(dolist (id (emacsql db [:select id :from repository
:where (isnull pullreqs-until)]))
(emacsql
db [:update repository :set (= pullreqs-until $s1) :where (= id $s2)]
(forge-sql1 [:select [updated] :from pullreq
:where (= repository $s1)
:order-by [(desc updated)]
:limit 1]
id)
id))
(emacsql db [:alter-table repository :rename-column sparse-p :to condition])
(pcase-dolist (`(,id ,not-tracked)
(emacsql db [:select [id condition] :from repository]))
(emacsql
db [:update repository :set (= condition $s1) :where (= id $s2)]
(if not-tracked :known :tracked)
id)))
(up 14
(emacsql db [:alter-table repository :add-column teams :default nil]))
(up 15
(emacsql db [:create-table discussion $S1]
(cdr (assq 'discussion forge--db-table-schemata)))
(emacsql db [:create-table discussion-category $S1]
(cdr (assq 'discussion-category forge--db-table-schemata)))
(emacsql db [:create-table discussion-label $S1]
(cdr (assq 'discussion-label forge--db-table-schemata)))
(emacsql db [:create-table discussion-mark $S1]
(cdr (assq 'discussion-mark forge--db-table-schemata)))
(emacsql db [:create-table discussion-post $S1]
(cdr (assq 'discussion-post forge--db-table-schemata)))
(emacsql db [:create-table discussion-reply $S1]
(cdr (assq 'discussion-reply forge--db-table-schemata)))
(emacsql db [:alter-table repository :add-column discussion-categories
:default 'eieio-unbound])
(emacsql db [:alter-table repository :add-column discussions
:default 'eieio-unbound])
(emacsql db [:alter-table repository :add-column discussions-p
:default nil])
(emacsql db [:alter-table repository :add-column discussions-until
:default nil]))
))
(defun forge--backup-database (db)
(let ((dst (concat (file-name-sans-extension forge-database-file)
(format "-v%s" (caar (emacsql (oref db connection)
[:pragma user-version])))
(format-time-string "-%Y%m%d-%H%M")
".sqlite")))
(message "Copying Forge database to %s..." dst)
(copy-file forge-database-file dst)
(message "Copying Forge database to %s...done" dst)))
;;; _
;; Local Variables:
;; read-symbol-shorthands: (
;; ("and$" . "cond-let--and$")
;; ("thread$" . "cond-let--thread$")
;; ("when$" . "cond-let--when$")
;; ("and-let*" . "cond-let--and-let*")
;; ("and-let" . "cond-let--and-let")
;; ("if-let*" . "cond-let--if-let*")
;; ("if-let" . "cond-let--if-let")
;; ("when-let*" . "cond-let--when-let*")
;; ("when-let" . "cond-let--when-let")
;; ("while-let*" . "cond-let--while-let*")
;; ("while-let" . "cond-let--while-let"))
;; End:
(provide 'forge-db)
;;; forge-db.el ends here