picnoir/my-repo-pins
1
0
Fork 0
mirror of https://github.com/NinjaTrappeur/my-repo-pins.git synced 2024-06-02 03:24:09 +02:00
Code Issues Projects Releases Wiki Activity

Make git subprocess async

Browse source 
The synchronous git process call was freezing the whole UI for a
*pretty long* time when checking out a big git repository.

We move into using a asynchronous process. This change required quite
a lot of sync-related changes. Both in the h.el codebase as well as in
the test suite.

On top of making the git call asynchronous, we also take advantage of
not freezing the UI anymore to open a window displaying the git clone
progress.
This commit is contained in:
Félix Baylac-Jacqué 2022-06-17 09:27:34 +02:00
parent 57eb402850
commit af0940261c
2 changed files with 102 additions and 40 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

46
h-tests.el
View file

@ -46,10 +46,20 @@ The directory gets deleted once we exit FUNC."
"Create a dummy git repo at DIR.
If DIR doesn't exists, we create it first."
(let ((d (file-name-as-directory dir)))
(let* ((d (file-name-as-directory dir))
(exit-code 0)
(git-process
(progn
(make-directory d t)
(h--call-git-in-dir d
(lambda (ec) (setq exit-code ec))
"init"))))
(progn
(unless (file-directory-p d) (make-directory d t))
(h--call-git-in-dir d "init"))))
(unless (file-directory-p d) (make-directory d t))
;; ERT does not handle async processes gracefully for the time
;; being. Blocking and waiting for the git process to exit
;; before moving on.
(while (accept-process-output git-process)))))
;; Test Dirs Setup
;;;;;;;;;;;;;;;;;
@ -73,10 +83,10 @@ For reference: test-root-1 looks like this:
(h--tests-with-temp-dir
(lambda (temp-dir)
(progn
(h--tests-init-fake-git-repo (concat temp-dir "/example1.tld/user1/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "/example1.tld/user1/proj2"))
(h--tests-init-fake-git-repo (concat temp-dir "/example1.tld/user2/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "/example2.tld/user1/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "example1.tld/user1/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "example1.tld/user1/proj2"))
(h--tests-init-fake-git-repo (concat temp-dir "example1.tld/user2/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "example2.tld/user1/proj1"))
(funcall func temp-dir)
))))
@ -99,10 +109,10 @@ For reference: test-root-2 looks like this:
(h--tests-with-temp-dir
(lambda (temp-dir)
(progn
(h--tests-init-fake-git-repo (concat temp-dir "/example1.tld/user1/proj1"))
(make-directory (concat (file-name-as-directory temp-dir) "/example1.tld/user1/proj2"))
(h--tests-init-fake-git-repo (concat temp-dir "/example1.tld/user2/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "/example2.tld/user1/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "example1.tld/user1/proj1"))
(make-directory (concat (file-name-as-directory temp-dir) "example1.tld/user1/proj2"))
(h--tests-init-fake-git-repo (concat temp-dir "example1.tld/user2/proj1"))
(h--tests-init-fake-git-repo (concat temp-dir "example2.tld/user1/proj1"))
(funcall func temp-dir)))))
@ -269,12 +279,13 @@ For reference: a empty test root looks like this:
"Test the h--git-clone-in-dir function."
(h--tests-run-on-testroot-1
(lambda (dir)
(let
((tmpdir (make-temp-file "h-test-" t)))
(let*
((tmpdir (make-temp-file "h-test-" t))
(git-process (h--git-clone-in-dir
(format "file://%s" (concat dir "example1.tld/user1/proj1/"))
tmpdir)))
(progn
(h--git-clone-in-dir
(format "file://%s" (concat dir "example1.tld/user1/proj1/"))
tmpdir)
(while (accept-process-output git-process))
(should (file-exists-p (format "%s/.git" tmpdir)))
(delete-directory tmpdir t))))))
@ -321,8 +332,7 @@ For reference: a empty test root looks like this:
(h--add-keys-to-forge-status dummy-forge-query-status-one-result)))
(should (equal
expected-forge-query-status-with-keys-two-results
(h--add-keys-to-forge-status dummy-forge-query-status-two-results)))
))
(h--add-keys-to-forge-status dummy-forge-query-status-two-results)))))
(provide 'h-tests)
;;; h-tests.el ends here

96
h.el
View file

@ -60,14 +60,49 @@ Errors out if we can't find it."
git-from-bin-path
(error "Can't find git. Is h-git-bin correctly set?")))))
(defun h--call-git-in-dir (dir &rest args)
"Call the git binary as pointed by ‘h-git-bin’ in DIR with ARGS."
(let ((default-directory dir))
(apply 'process-file (seq-concatenate 'list `(,(h--git-path) nil "*h git log*" nil) args))))
(defun h--call-git-in-dir (dir &optional callback &rest args)
"Call the git binary as pointed by ‘h-git-bin’ in DIR with ARGS.
(defun h--git-clone-in-dir (clone-url checkout-filepath)
"Clone the CLONE-URL repo at CHECKOUT-FILEPATH."
(h--call-git-in-dir "~/" "clone" clone-url checkout-filepath))
Once the git subprocess exists, call CALLBACK with a the process exit
code as single argument. If CALLBACK is set to nil, don't call any
callback.
Returns the git PROCESS object."
(let* ((git-buffer (get-buffer-create "*h git log*"))
(git-window nil)
(current-buffer (current-buffer))
(git-sentinel (lambda
(process event)
(if (and
(equal event "finished\n")
(not (eq callback nil)))
(let ((exit-code (process-exit-status process)))
(progn
(if (window-valid-p git-window)
(delete-window git-window))
(funcall callback exit-code)))
(if (or (equal event "deleted\n") (equal event "killed\n"))
(progn
(delete-window git-window))
(message event))))))
(progn
(set-buffer git-buffer)
(erase-buffer)
(setq default-directory dir)
(setq git-window (display-buffer git-buffer))
(prog1
(make-process
:name "h-git-subprocess"
:buffer git-buffer
:command (seq-concatenate 'list `(,(h--git-path)) args)
:sentinel git-sentinel)
(set-buffer current-buffer)))))
(defun h--git-clone-in-dir (clone-url checkout-filepath &optional callback)
"Clone the CLONE-URL repo at CHECKOUT-FILEPATH.
Call CALLBACK with no arguments once the git subprocess exists."
(h--call-git-in-dir "~/" callback "clone" clone-url checkout-filepath))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal: builtin fetchers
@ -588,21 +623,33 @@ url."
(ssh-url (alist-get 'ssh forge-result-status))
(http-url (alist-get 'https forge-result-status))
(code-root (h--safe-get-code-root))
(dest-dir (concat code-root (h--filepath-from-clone-url http-url)))
(clone-exit-code 1))
(dest-dir (concat code-root (h--filepath-from-clone-url http-url))))
(progn
(message (format "Cloning %s to %s" ssh-url dest-dir))
(setq clone-exit-code (h--git-clone-in-dir ssh-url dest-dir))
(if (not (equal clone-exit-code 0))
(progn
(message (format "Failed to clone %s" ssh-url))
(message (format "Trying again with %s" http-url))
(setq clone-exit-code(h--git-clone-in-dir http-url dest-dir))))
(if (equal clone-exit-code 0)
(progn
(message (format "Successfully cloned %s" dest-dir))
(find-file dest-dir))
(error (format "Cannot clone %s nor %s." ssh-url http-url))))))
(cl-flet*
((clone-http
()
(h--git-clone-in-dir
http-url
dest-dir
(lambda (exit-code)
(if (not (equal exit-code 0))
(error (format "Cannot clone %s nor %s." ssh-url http-url))
(message (format "Successfully cloned %s" dest-dir))))))
(clone-ssh
()
(h--git-clone-in-dir
ssh-url
dest-dir
(lambda (exit-code)
(if (not (equal exit-code 0))
(progn
(message (format "Failed to clone %s" ssh-url))
(message (format "Trying again with %s" http-url))
(clone-http))
(message (format "Successfully cloned %s" dest-dir)))))))
(clone-ssh)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Internal: improving builtin autocomplete
@ -670,8 +717,13 @@ TODO: split that mess before release. We shouldn't query here."
((code-root (h--safe-get-code-root))
(dest-dir (concat code-root (h--filepath-from-clone-url repo-query))))
(progn
(h--git-clone-in-dir repo-query dest-dir)
(find-file dest-dir))))
(h--git-clone-in-dir
repo-query
dest-dir
(lambda (exit-code)
(if (equal exit-code 0)
(find-file dest-dir)
(error (format "Cannot clone %s." repo-query))))))))
(t (error repo-query-kind)))))
;;;;;;;;;;;;;;;;;;;;;;;;