Rewrite 'doom update'
- Is now much more fault tolerant (produces better errors) - Now handles async.el process errors as well - Standardizes data structure of thread responses
This commit is contained in:
Henrik Lissner
parent
da954aa361
commit
87fd81281f
1 changed files with 88 additions and 68 deletions
|
|
@ -131,6 +131,64 @@ a list of packages that will be installed."
|
||||||
t))))
|
t))))
|
||||||
|
|
||||||
|
|
||||||
|
(defun doom--packages-remove-outdated-f (packages)
|
||||||
|
(async-start
|
||||||
|
`(lambda ()
|
||||||
|
(setq load-path ',load-path
|
||||||
|
doom-modules ',doom-modules)
|
||||||
|
(condition-case e
|
||||||
|
(let (packages errors)
|
||||||
|
(load ,(concat doom-core-dir "core.el"))
|
||||||
|
(dolist (recipe ',group)
|
||||||
|
(condition-case e
|
||||||
|
(straight--with-plist recipe
|
||||||
|
(package local-repo remote upstream-repo upstream-host)
|
||||||
|
;; HACK There's a contingency of `straight-fetch-package'
|
||||||
|
;; where it will pop up a window for confirmation, but this
|
||||||
|
;; window is invisible because a) this command runs in a
|
||||||
|
;; headless session and b) this code runs in an async child
|
||||||
|
;; process, so we ensure the remotes are correctly set up to
|
||||||
|
;; prevent that contingency.
|
||||||
|
(when (and local-repo (straight--repository-is-available-p recipe))
|
||||||
|
(when-let*
|
||||||
|
((url (ignore-errors (straight--get-call "git" "remote" "get-url" remote)))
|
||||||
|
(desired-url (straight-vc-git--encode-url upstream-repo upstream-host)))
|
||||||
|
(unless (straight-vc-git--urls-compatible-p url desired-url)
|
||||||
|
(straight--get-call "git" "remote" "remove" remote)
|
||||||
|
(straight--get-call "git" "remote" "add" remote desired-url)
|
||||||
|
(straight--get-call "git" "fetch" remote)))
|
||||||
|
(straight-fetch-package package)
|
||||||
|
;; REVIEW Is there no better way to get this information?
|
||||||
|
(let* ((default-directory (straight--repos-dir local-repo))
|
||||||
|
(n (string-to-number
|
||||||
|
(straight--get-call "git" "rev-list" "--right-only" "--count" "HEAD..@{u}")))
|
||||||
|
(pretime
|
||||||
|
(string-to-number
|
||||||
|
(shell-command-to-string "git log -1 --format=%at HEAD")))
|
||||||
|
(time
|
||||||
|
(string-to-number
|
||||||
|
;; HACK `straight--get-call' has a higher
|
||||||
|
;; failure rate when querying FETCH_HEAD; not
|
||||||
|
;; sure why. Doing this manually, with
|
||||||
|
;; `shell-command-to-string' works fine.
|
||||||
|
(shell-command-to-string "git log -1 --format=%at FETCH_HEAD"))))
|
||||||
|
(with-current-buffer (straight--process-get-buffer)
|
||||||
|
(with-silent-modifications
|
||||||
|
(print! (debug (autofill "%s") (indent 2 (buffer-string))))
|
||||||
|
(erase-buffer)))
|
||||||
|
(when (> n 0)
|
||||||
|
(push (list n pretime time recipe)
|
||||||
|
packages)))))
|
||||||
|
(error
|
||||||
|
(push (list package e (string-trim (or (straight--process-get-output) "")))
|
||||||
|
errors))))
|
||||||
|
(if errors
|
||||||
|
(cons 'error errors)
|
||||||
|
(cons 'ok (nreverse packages))))
|
||||||
|
(error
|
||||||
|
(cons 'error e))))))
|
||||||
|
|
||||||
|
|
||||||
(defun doom-packages-update (&optional auto-accept-p)
|
(defun doom-packages-update (&optional auto-accept-p)
|
||||||
"Updates packages.
|
"Updates packages.
|
||||||
|
|
||||||
|
|
@ -141,64 +199,16 @@ a list of packages that will be updated."
|
||||||
;; REVIEW Does this fail gracefully enough? Is it error tolerant?
|
;; REVIEW Does this fail gracefully enough? Is it error tolerant?
|
||||||
;; TODO Add version-lock checks; don't want to spend all this effort on
|
;; TODO Add version-lock checks; don't want to spend all this effort on
|
||||||
;; packages that shouldn't be updated
|
;; packages that shouldn't be updated
|
||||||
(let (futures)
|
(let ((futures
|
||||||
(dolist (group (seq-partition (hash-table-values straight--repo-cache) 8))
|
(or (cl-loop for group
|
||||||
(push
|
in (seq-partition (hash-table-values straight--repo-cache)
|
||||||
(async-start
|
8)
|
||||||
`(lambda ()
|
if (doom--packages-remove-outdated-f group)
|
||||||
(setq load-path ',load-path
|
collect it)
|
||||||
doom-modules ',doom-modules)
|
(error! "Failed to create any threads"))))
|
||||||
(load ,(concat doom-core-dir "core.el"))
|
(condition-case-unless-debug e
|
||||||
(let (packages errors)
|
|
||||||
(dolist (recipe ',group)
|
|
||||||
(straight--with-plist recipe
|
|
||||||
(package local-repo remote upstream-repo upstream-host)
|
|
||||||
;; HACK There's a contingency of `straight-fetch-package'
|
|
||||||
;; where it will pop up a window for confirmation, but this
|
|
||||||
;; window is invisible because a) this command runs in a
|
|
||||||
;; headless session and b) this code runs in an async child
|
|
||||||
;; process, so we ensure the remotes are correctly set up to
|
|
||||||
;; prevent that contingency.
|
|
||||||
(when (and local-repo (straight--repository-is-available-p recipe))
|
|
||||||
(when-let*
|
|
||||||
((url (ignore-errors (straight--get-call "git" "remote" "get-url" remote)))
|
|
||||||
(desired-url (straight-vc-git--encode-url upstream-repo upstream-host)))
|
|
||||||
(unless (straight-vc-git--urls-compatible-p url desired-url)
|
|
||||||
(straight--get-call "git" "remote" "remove" remote)
|
|
||||||
(straight--get-call "git" "remote" "add" remote desired-url)
|
|
||||||
(straight--get-call "git" "fetch" remote)))
|
|
||||||
(straight-fetch-package package)
|
|
||||||
;; REVIEW Is there no better way to get this information?
|
|
||||||
(condition-case e
|
|
||||||
(let* ((default-directory (straight--repos-dir local-repo))
|
|
||||||
(n (string-to-number
|
|
||||||
(straight--get-call "git" "rev-list" "--right-only" "--count" "HEAD..@{u}")))
|
|
||||||
(pretime
|
|
||||||
(string-to-number
|
|
||||||
(shell-command-to-string "git log -1 --format=%at HEAD")))
|
|
||||||
(time
|
|
||||||
(string-to-number
|
|
||||||
;; HACK `straight--get-call' has a higher
|
|
||||||
;; failure rate when querying FETCH_HEAD; not
|
|
||||||
;; sure why. Doing this manually, with
|
|
||||||
;; `shell-command-to-string' works fine.
|
|
||||||
(shell-command-to-string "git log -1 --format=%at FETCH_HEAD"))))
|
|
||||||
(with-current-buffer (straight--process-get-buffer)
|
|
||||||
(with-silent-modifications
|
|
||||||
(print! (debug (autofill "%s") (indent 2 (buffer-string))))
|
|
||||||
(erase-buffer)))
|
|
||||||
(when (> n 0)
|
|
||||||
(push (list n pretime time recipe)
|
|
||||||
packages)))
|
|
||||||
(error
|
|
||||||
(push (cons package (string-trim (straight--process-get-output)))
|
|
||||||
errors))))))
|
|
||||||
(cons errors (nreverse packages)))))
|
|
||||||
futures))
|
|
||||||
(condition-case e
|
|
||||||
(let ((total (length futures))
|
(let ((total (length futures))
|
||||||
(futures (nreverse futures))
|
specs)
|
||||||
(specs '(t)))
|
|
||||||
(while futures
|
(while futures
|
||||||
(print! ". %.0f%%" (* (/ (- total (length futures))
|
(print! ". %.0f%%" (* (/ (- total (length futures))
|
||||||
(float total))
|
(float total))
|
||||||
|
|
@ -206,18 +216,28 @@ a list of packages that will be updated."
|
||||||
(while (not (async-ready (car futures)))
|
(while (not (async-ready (car futures)))
|
||||||
(sleep-for 2)
|
(sleep-for 2)
|
||||||
(print! "."))
|
(print! "."))
|
||||||
(cl-destructuring-bind (errors . packages)
|
(cl-destructuring-bind (status . result)
|
||||||
(async-get (pop futures))
|
(or (async-get (pop futures))
|
||||||
(if errors
|
(cons nil nil))
|
||||||
(error "There were errors:\n\n%s"
|
(cond ((null status)
|
||||||
(mapconcat (lambda (e)
|
(error "Thread returned an invalid result: %S" errors result))
|
||||||
(format! " - %s: %s" (yellow (car e)) (cdr e)))
|
((eq status 'error)
|
||||||
errors
|
(error "There were errors:\n\n%s"
|
||||||
"\n")
|
(if (and (listp result)
|
||||||
errors)
|
(symbolp (car result)))
|
||||||
(nconc specs packages))))
|
(prin1-to-string result)
|
||||||
|
(mapconcat (lambda (e)
|
||||||
|
(format! " - %s: %s" (yellow (car e)) (cdr e)))
|
||||||
|
result
|
||||||
|
"\n"))))
|
||||||
|
((eq status 'ok)
|
||||||
|
(print! (debug "Appended %S to package list") (or result "nothing"))
|
||||||
|
(appendq! specs result))
|
||||||
|
((error "Thread returned a non-standard status: %s\n\n%s"
|
||||||
|
status result)))))
|
||||||
|
(print! ". 100%%")
|
||||||
(terpri)
|
(terpri)
|
||||||
(if-let (specs (delq nil (cdr specs)))
|
(if-let (specs (delq nil specs))
|
||||||
(if (not
|
(if (not
|
||||||
(or auto-accept-p
|
(or auto-accept-p
|
||||||
(y-or-n-p
|
(y-or-n-p
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue