mirror of
https://github.com/NinjaTrappeur/my-repo-pins.git
synced 2024-06-01 19:14:07 +02:00
Merge pull request #1 from NinjaTrappeur/nin/fetchers
This commit is contained in:
Ninjatrappeur
GitHub
commit
83fd82d62f
3
.github/workflows/test.yml
vendored
3
.github/workflows/test.yml
vendored
|
|
@ -11,9 +11,6 @@ jobs:
|
|||
strategy:
|
||||
matrix:
|
||||
emacs_version:
|
||||
- 25.1
|
||||
- 25.2
|
||||
- 25.3
|
||||
- 26.1
|
||||
- 26.2
|
||||
- 26.3
|
||||
|
|
|
|||
|
|
@ -6,10 +6,10 @@ Project checkout and navigation Emacs package heavily inspired by [zimbatm/h](ht
|
|||
TODO before first release:
|
||||
|
||||
- [x] Replace `directory-files-recursively` with custom implemention. Support 'till Emacs 24.
|
||||
- [ ] Implement GitHub fetcher.
|
||||
- [x] Implement GitHub fetcher.
|
||||
- [ ] Implement GitLab fetcher.
|
||||
- [ ] Implement sr.ht fetcher.
|
||||
- [ ] Implement codeberg fetcher.
|
||||
- [ ] ~~Implement sr.ht fetcher~~: GraphQL, no doc, playground behind loginwall. I won't bother after all. PR welcome.
|
||||
- [ ] Document how to implement a new fetcher.
|
||||
- [ ] Explain what the hell this thing is about in readme.
|
||||
|
||||
|
|
|
|||
107
h-tests.el
107
h-tests.el
|
|
@ -49,7 +49,7 @@ If DIR doesn't exists, we create it first."
|
|||
(let ((d (file-name-as-directory dir)))
|
||||
(progn
|
||||
(unless (file-directory-p d) (make-directory d t))
|
||||
(h--call-git-in-dir d "init" ))))
|
||||
(h--call-git-in-dir d "init"))))
|
||||
|
||||
;; Test Dirs Setup
|
||||
;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -216,5 +216,110 @@ For reference: a empty test root looks like this:
|
|||
(insert-file-contents "./tests/fixtures/github-get-request-ko.txt")
|
||||
(should (equal (h--fetch-github-parse-response (current-buffer)) nil))))
|
||||
|
||||
;; Test repo URI parser
|
||||
;;;;;;;;;;;;;;;;;
|
||||
|
||||
(ert-deftest h--test-parse-repo-identifier ()
|
||||
"Test h--parse-repo-identifier."
|
||||
(should (equal
|
||||
(h--parse-repo-identifier "https://github.com/Ninjatrappeur/h.el")
|
||||
'((tag . full-url) (full-url . "https://github.com/Ninjatrappeur/h.el"))))
|
||||
(should (equal
|
||||
(h--parse-repo-identifier "github.com/Ninjatrappeur/h.el")
|
||||
'((tag . full-url) (full-url . "github.com/Ninjatrappeur/h.el"))))
|
||||
(should (equal
|
||||
(h--parse-repo-identifier "Ninjatrappeur/h.el")
|
||||
'((tag . owner-repo) (owner . "Ninjatrappeur") (repo . "h.el"))))
|
||||
(should (equal
|
||||
(h--parse-repo-identifier "h.el")
|
||||
'((tag . repo) (repo . "h.el")))))
|
||||
|
||||
(ert-deftest h--test-filepath-from-clone-url ()
|
||||
"Test h--filepath-from-clone-url."
|
||||
;; HTTP/HTTPS
|
||||
(should (equal (h--filepath-from-clone-url "http://github.com/NinjaTrappeur/h.el.git") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "http://github.com/NinjaTrappeur/h.el") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "https://github.com/NinjaTrappeur/h.el.git") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "https://github.com/NinjaTrappeur/h.el") "github.com/NinjaTrappeur/h.el"))
|
||||
;; SSH
|
||||
(should (equal (h--filepath-from-clone-url "ssh://git@github.com:NinjaTrappeur/h.el.git") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "ssh://git@github.com:NinjaTrappeur/h.el") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "git@github.com:NinjaTrappeur/h.el.git") "github.com/NinjaTrappeur/h.el"))
|
||||
(should (equal (h--filepath-from-clone-url "git@github.com:NinjaTrappeur/h.el") "github.com/NinjaTrappeur/h.el")))
|
||||
|
||||
(ert-deftest h--test-git-clone-in-dir ()
|
||||
"Test the h--git-clone-in-dir function."
|
||||
(h--tests-run-on-testroot-1
|
||||
(lambda (dir)
|
||||
(let
|
||||
((tmpdir (make-temp-file "h-test-" t)))
|
||||
(progn
|
||||
(h--git-clone-in-dir
|
||||
(format "file://%s" (concat dir "example1.tld/user1/proj1/"))
|
||||
tmpdir)
|
||||
(should (file-exists-p (format "%s/.git" tmpdir)))
|
||||
(delete-directory tmpdir t))))))
|
||||
|
||||
(ert-deftest h--test-pick-relevant-forges ()
|
||||
"Test the h--pick-relevant-forges function."
|
||||
(let
|
||||
((forge-list
|
||||
'((forge1 . ((query-user-repo . h--query-github)
|
||||
(url . "https://forge1.com/.*/.*")))
|
||||
(forge2 . ((query-user-repo . h--query-github)
|
||||
(url . "https://forge2.com/.*/.*"))))))
|
||||
(should (equal (h--pick-relevant-forges "owner/repo" forge-list) forge-list))
|
||||
(should (equal (h--pick-relevant-forges "repo" forge-list) forge-list))
|
||||
(should (equal
|
||||
(h--pick-relevant-forges "https://forge1.com/owner/repo" forge-list)
|
||||
'((forge1 . ((query-user-repo . h--query-github)
|
||||
(url . "https://forge1.com/.*/.*"))))))))
|
||||
|
||||
;;; UI-related tests
|
||||
|
||||
(ert-deftest h--test-add-keys-to-forge-status ()
|
||||
"Test the h--add-keys-to-forge-status function."
|
||||
(let
|
||||
((dummy-forge-query-status-one-result
|
||||
'(("GitHub"
|
||||
(ssh . "git@github.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://github.com/NinjaTrappeur/h.el.git"))
|
||||
("GitLab" . not-found)))
|
||||
(expected-forge-query-status-with-keys-one-result
|
||||
`(("GitHub"
|
||||
(status
|
||||
(ssh . "git@github.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://github.com/NinjaTrappeur/h.el.git"))
|
||||
(key . ,?1))
|
||||
("GitLab" (status . not-found))))
|
||||
(dummy-forge-query-status-two-results
|
||||
'(("GitHub"
|
||||
(ssh . "git@github.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://github.com/NinjaTrappeur/h.el.git"))
|
||||
("Codeberg" . not-found)
|
||||
("GitLab"
|
||||
(ssh . "git@gitlab.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://gitlab.com/NinjaTrappeur/h.el.git"))))
|
||||
(expected-forge-query-status-with-keys-two-results
|
||||
`(("GitHub"
|
||||
(status
|
||||
(ssh . "git@github.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://github.com/NinjaTrappeur/h.el.git"))
|
||||
(key . ,'?1))
|
||||
("Codeberg" (status . not-found))
|
||||
("GitLab"
|
||||
(status
|
||||
(ssh . "git@gitlab.com:NinjaTrappeur/h.el.git")
|
||||
(https . "https://gitlab.com/NinjaTrappeur/h.el.git"))
|
||||
(key . ,'?2)))))
|
||||
|
||||
(should (equal
|
||||
expected-forge-query-status-with-keys-one-result
|
||||
(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)))
|
||||
))
|
||||
|
||||
(provide 'h-tests)
|
||||
;;; h-tests.el ends here
|
||||
|
|
|
|||
394
h.el
394
h.el
|
|
@ -5,7 +5,7 @@
|
|||
;;; Maintainer: Félix Baylac Jacqué <felix at alternativebit.fr>
|
||||
;;; Version: 1.14.0
|
||||
;;; Homepage: https://alternativebit.fr/TODO
|
||||
;;; Package-Requires: ((emacs "25.1"))
|
||||
;;; Package-Requires: ((emacs "26.1"))
|
||||
|
||||
;;; License:
|
||||
|
||||
|
|
@ -30,6 +30,7 @@
|
|||
|
||||
(require 'json)
|
||||
(require 'url)
|
||||
(require 'cl-lib)
|
||||
;; Required to batch eval the module: the substring functions are
|
||||
;; loaded by default in interactive emacs, not in batch-mode emacs.
|
||||
(eval-when-compile (require 'subr-x))
|
||||
|
|
@ -59,30 +60,90 @@ 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 args)
|
||||
(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))
|
||||
(process-file (h--git-path) nil nil nil args)))
|
||||
(apply 'process-file (seq-concatenate 'list `(,(h--git-path) nil "*h git log*" nil) 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))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal: builtin fetchers
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;;; Generic fetcher infrastructure
|
||||
(defvar h--builtins-forge-fetchers
|
||||
'(("GitHub" .
|
||||
((query-user-repo . h--query-github-owner-repo)
|
||||
(url . "https?://github.com/.*"))))
|
||||
|
||||
"Fetchers meant to be used in conjunction with ‘h-forge-fetchers’.
|
||||
|
||||
This variable contains fetchers for:
|
||||
- github.com")
|
||||
|
||||
(defcustom h-forge-fetchers
|
||||
'((github . h--query-github))
|
||||
h--builtins-forge-fetchers
|
||||
"List of forges for which we want to remote fetch projects."
|
||||
:type '(alist :key-type 'symbol :value-type 'function)
|
||||
:type '(alist
|
||||
:key-type symbol
|
||||
:value-type (alist
|
||||
:key-type symbol
|
||||
:value-type (choice function string)))
|
||||
:group 'h-group)
|
||||
|
||||
(defvar h--forge-fetchers-state '()
|
||||
|
||||
"Internal state where we keep a forge request status.
|
||||
|
||||
We use that state to populate the UI buffer.
|
||||
|
||||
This state is reprensented by a alist and looks something like that:
|
||||
|
||||
\((\"FORGE-NAME1\"
|
||||
(ssh . SSH-CHECKOUT-URL)
|
||||
(https . HTTPS-CHECKOUT-URL)))
|
||||
|
||||
A ongoing/failed lookup will also be represented by an entry in this alist:
|
||||
|
||||
\(\"FORGE-NAME1\" . 'loading)
|
||||
\(\"FORGE-NAME1\" . 'not-found)")
|
||||
|
||||
(defvar h--forge-fetchers-state-mutex
|
||||
(make-mutex "h-ui-mutex")
|
||||
"Mutex in charge of preventing several fetchers to update the state concurently.")
|
||||
|
||||
;;; Github Fetcher
|
||||
(defun h--query-github-owner-repo (user-name repo-name callback)
|
||||
"Queries the GitHub API to retrieve some infos about a GitHub repo.
|
||||
This function will first try to determine whether
|
||||
github.com/USER-NAME/REPO-NAME exists.
|
||||
|
||||
If so, calls the CALLBACK function with a alist containing the ssh and
|
||||
https clone URLs. If the repo does not exists, calls the callback with
|
||||
nil as parameter."
|
||||
(progn
|
||||
(url-retrieve
|
||||
(format "https://api.github.com/repos/%s/%s" user-name repo-name)
|
||||
(lambda (&rest _rest) (funcall callback (h--fetch-github-parse-response(current-buffer)))))))
|
||||
|
||||
|
||||
(defun h--fetch-github-parse-response (response-buffer)
|
||||
"Parse the RESPONSE-BUFFER containing a GET response from the GitHub API.
|
||||
|
||||
Parsing a response from a GET https://api.github.com/repos/user/repo request."
|
||||
Parsing a response from a GET https://api.github.com/repos/user/repo request.
|
||||
|
||||
If the repo does exists, returns a alist in the form of:
|
||||
|
||||
`(
|
||||
(ssh . SSH-CHECKOUT-URL)
|
||||
(https . HTTPS-CHECKOUT-URL)
|
||||
(forge-str . \"Github\")
|
||||
)
|
||||
|
||||
Returns nil if the repo does not exists."
|
||||
(progn (set-buffer response-buffer)
|
||||
(goto-char (point-min))
|
||||
(if (not(eq(re-search-forward "^HTTP/1.1 200 OK$" nil t) nil))
|
||||
|
|
@ -91,22 +152,137 @@ Parsing a response from a GET https://api.github.com/repos/user/repo request."
|
|||
(re-search-forward "^$")
|
||||
(delete-region (point) (point-min))
|
||||
(let* ((parsed-buffer (json-read))
|
||||
(ssh-url (cdr(assoc 'ssh_url parsed-buffer)))
|
||||
(https-url (cdr(assoc 'clone_url parsed-buffer))))
|
||||
`((ssh . ,ssh-url) (https . ,https-url))))
|
||||
(ssh-url (alist-get 'ssh_url parsed-buffer))
|
||||
(https-url (alist-get 'clone_url parsed-buffer)))
|
||||
`((ssh . ,ssh-url)
|
||||
(https . ,https-url))))
|
||||
nil)))
|
||||
|
||||
(defun h--query-github (user-name repo-name callback)
|
||||
"Queries the GitHub API to retrieve some infos about a GitHub repo.
|
||||
This function will first try to determine whether
|
||||
github.com/USER-NAME/REPO-NAME exists.
|
||||
;;; Gitea Fetcher
|
||||
;; (defun h--query-gitea (instance-url user-name repo-name callback)
|
||||
;; "Queries the INSTANCE-URL gitea instance to retrieve a repo informations.
|
||||
;; This function will first try to dertermine whether the
|
||||
;; USER-NAME/REPO-NAME exists.
|
||||
|
||||
If so, calls the CALLBACK function with a alist containing the ssh and
|
||||
https clone URLs. If the repo does not exists, calls the callback with
|
||||
nil as parameter."
|
||||
(url-retrieve
|
||||
(format "https://api.github.com/repos/%s/%s" user-name repo-name)
|
||||
(lambda (&rest _rest) (funcall callback (h--fetch-github-parse-response(current-buffer))))))
|
||||
;; If so, calls the CALLBACK function with a alist containing the ssh and
|
||||
;; https clone URLs. If the repo does not exists, calls the callback with
|
||||
;; nil as parameter."
|
||||
;; (url-retrieve
|
||||
;; (format "%s/api/v1/repos/%s/%s" instance-url user-name repo-name)
|
||||
;; (lambda (&rest _rest) (funcall callback (h--fetch-gitea-parse-response(current-buffer))))))
|
||||
;; ; Get /repos/owner/repo
|
||||
|
||||
|
||||
;;; Gitlab Fetcher
|
||||
|
||||
;; (defun h--query-gitlab (instance-url user-name repo-name callback)
|
||||
;; "Queries the INSTANCE-URL gitlab instance to retrieve a repo informations.
|
||||
;; This function will first try to dertermine whether the
|
||||
;; USER-NAME/REPO-NAME exists.
|
||||
|
||||
;; If so, calls the CALLBACK function with a alist containing the ssh and
|
||||
;; https clone URLs. If the repo does not exists, calls the callback with
|
||||
;; nil as parameter."
|
||||
;; (url-retrieve
|
||||
;; (format "%s/api/v4/users/%s/projects" instance-url user-name)
|
||||
;; (lambda (&rest _rest) (funcall callback nil))))
|
||||
;; ;1. Find project in
|
||||
;https://gitlab.com/api/v4/users/ninjatrappeur/projects
|
||||
|
||||
;;; Generic fetcher infrastructure
|
||||
|
||||
;; (defun h--dispatch-fetcher (query-string)
|
||||
;; "Try to download QUERY-STRING via the fetchers registered in ‘h-forge-fetchers’."
|
||||
;; (cond ((string-match-p "github.com" query-string)
|
||||
;; (apply 'h--query-github (h--parse-query-string-for-forge query-string)))
|
||||
;; ;; ((string-match-p "gitlab.com" query-string)
|
||||
;; ;; (apply 'h--query-gitlab (h--parse-query-string-for-forge query-string)))
|
||||
;; (t (error (format "No fetcher for %s" query-string)))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal: repo URI parser
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun h--parse-repo-identifier (query-str)
|
||||
"Do its best to figure out which repo the user meant by QUERY-STR.
|
||||
|
||||
A valid QUERY-STR is in one of the 4 following formats:
|
||||
|
||||
1. project
|
||||
Jump to the project if available, do not fetch a remote forge
|
||||
project.
|
||||
2. owner/project
|
||||
Open a promp with available projects + fetch all the remote
|
||||
forges.
|
||||
3. forge.tld/owner/project
|
||||
Open the project is available, fetch it if not.
|
||||
4. https://forge.tld/owner/project
|
||||
Open the project is available, fetch it if not.
|
||||
|
||||
This function will return a tagged union in the form of a alist. For
|
||||
each kind of format, it'll return something along the line of:
|
||||
|
||||
\(('tag . 'full-url) ('full-url .\
|
||||
\"https://full-url.org/path/to/git/repo/checkout\"))
|
||||
or
|
||||
\(('tag . 'owner-repo) ('owner . \"NinjaTrappeur\") ('repo\
|
||||
. \"h.el\"))
|
||||
or
|
||||
\(('tag . 'repo) ('repo . \"h.el\"))"
|
||||
(cond
|
||||
;; Full-url case
|
||||
((or (string-match "^https?://.*/.*/.*$" query-str)
|
||||
(string-match "^.*/.*/.*$" query-str))
|
||||
`((tag . full-url) (full-url . ,query-str)))
|
||||
;; owner/repo case
|
||||
((string-match "^.*/.*$" query-str)
|
||||
(let*
|
||||
((splitted-query (split-string query-str "/"))
|
||||
(owner (car splitted-query))
|
||||
(repo (cadr splitted-query)))
|
||||
`((tag . owner-repo) (owner . ,owner) (repo . ,repo))))
|
||||
;; repo case
|
||||
(t `((tag . repo) (repo . ,query-str)))))
|
||||
|
||||
(defun h--filepath-from-clone-url (clone-url)
|
||||
"Return the relative path relative to the coderoot for CLONE-URL.
|
||||
|
||||
CLONE-STR being the git clone URL we want to find the local path for."
|
||||
(let*
|
||||
((is-http (string-match-p "^https?://.*$" clone-url))
|
||||
(is-ssh (string-match-p "^\\(ssh://\\)?.*@.*:.*$" clone-url)))
|
||||
(cond (is-http
|
||||
(string-remove-suffix
|
||||
".git"
|
||||
(cadr(split-string clone-url "//"))))
|
||||
(is-ssh
|
||||
(let*
|
||||
((url-without-user (cadr(split-string clone-url "@")))
|
||||
(colon-split (split-string url-without-user ":"))
|
||||
(fqdn (car colon-split))
|
||||
(repo-url (string-remove-suffix ".git" (cadr colon-split))))
|
||||
(format "%s/%s" fqdn repo-url))))))
|
||||
|
||||
(defun h--pick-relevant-forges (query-string forges-alist)
|
||||
"Filters out relevant FORGES-ALIST entries for QUERY-STRING.
|
||||
|
||||
If QUERY-STRING is in the form of owner/repo or just a repo name, do
|
||||
not filter anything.
|
||||
|
||||
If QUERY-STRING is a fully qualified URL, exclusively use the relevant forge."
|
||||
(let*
|
||||
((query-string-type
|
||||
(alist-get 'tag (h--parse-repo-identifier query-string))))
|
||||
(cond
|
||||
;; query-string is a full URL. Let's filter out the irrelevant forges.
|
||||
((eq query-string-type 'full-url)
|
||||
(seq-filter
|
||||
(lambda (e)
|
||||
(let* ((forge-url-regex (alist-get 'url e)))
|
||||
(string-match-p forge-url-regex query-string)))
|
||||
forges-alist))
|
||||
((eq query-string-type 'owner-repo) forges-alist)
|
||||
((eq query-string-type 'repo) forges-alist))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal: code-root management functions
|
||||
|
|
@ -131,7 +307,7 @@ local directory"
|
|||
Errors out if ‘h-code-root’ has not been set yet."
|
||||
(progn (when (not h-code-root)
|
||||
(error "h-code-root has not been set. Please point it to your code root"))
|
||||
(file-name-as-directory h-code-root)))
|
||||
(expand-file-name (file-name-as-directory h-code-root))))
|
||||
|
||||
|
||||
(defun h--find-git-dirs-recursively (dir)
|
||||
|
|
@ -194,10 +370,188 @@ an empty list."
|
|||
(mapcar remove-code-root-prefix-and-trailing-slash projects-absolute-path)))
|
||||
projects-relative-to-code-root)))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Internal: UI
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun h--draw-ui-buffer (forge-query-status)
|
||||
"Draws the UI depending on the app state.
|
||||
|
||||
FORGE-QUERY-STATUS being a alist in the form of (FORGE-NAME . LOOKUP-STATUS)
|
||||
where FORGE-NAME is a string representing the name of a forge,
|
||||
LOOKUP-STATUS an atom that is either 'loading, 'not-found or a list
|
||||
containing the lookup result.
|
||||
|
||||
We're going to draw these forge query status results in a buffer and
|
||||
associate each of them with a key binding.
|
||||
|
||||
, ‘h--draw-forge-status’ is in charge of
|
||||
drawing the forge status in the h.el buffer."
|
||||
(let* (
|
||||
(h-buffer (get-buffer-create "h.el"))
|
||||
(previous-buffer (current-buffer))
|
||||
(forge-status-with-keys (h--add-keys-to-forge-status forge-query-status)))
|
||||
(progn
|
||||
(set-buffer h-buffer)
|
||||
(setq buffer-read-only nil)
|
||||
(erase-buffer)
|
||||
(local-set-key (kbd "q") 'delete-window)
|
||||
(seq-map
|
||||
(lambda (e) (h--draw-forge-status e)) forge-status-with-keys)
|
||||
(setq buffer-read-only t)
|
||||
(set-buffer previous-buffer)
|
||||
(display-buffer h-buffer))))
|
||||
|
||||
(defun h--add-keys-to-forge-status (forge-query-status)
|
||||
"Add key bindings to relevant FORGE-QUERY-STATUS entries.
|
||||
|
||||
FORGE-QUERY-STATUS is list of alists in the form of ((FORGE-NAME .
|
||||
LOOKUP-STATUS)) where LOOKUP-STATUS is either a list containing the
|
||||
lookup results or the 'not-found atom when no results could be found.
|
||||
This function adds a key binding alist to the LOOKUP-STATUS list when
|
||||
results have been found, nothing if the repo couldn't be found.
|
||||
|
||||
‘h--find-next-available-key-binding’ is in charge of generating the
|
||||
key bindings."
|
||||
(reverse
|
||||
(cdr
|
||||
(cl-reduce
|
||||
(lambda
|
||||
;; In this fold, car of acc is the next key binding to
|
||||
;; associate, cdr the new forge-query-status.
|
||||
(acc e)
|
||||
(let* ((status (cdr e))
|
||||
(key (car acc))
|
||||
(isFound (listp status))
|
||||
(nextKeybinding
|
||||
(if isFound (h--find-next-available-key-binding (car acc)) (car acc)))
|
||||
(forge-status-with-key
|
||||
(if isFound
|
||||
`((status . ,status)
|
||||
(key . ,key))
|
||||
`((status . ,status)))))
|
||||
(append `(,nextKeybinding
|
||||
(,(car e) . ,forge-status-with-key))
|
||||
(cdr acc))))
|
||||
forge-query-status
|
||||
:initial-value '(?1 . ())))))
|
||||
|
||||
(defun h--draw-forge-status (forge-result)
|
||||
"Draws FORGE-RESULT status to the current buffer.
|
||||
|
||||
FORGE-STATUS being a alist in the form of (FORGE-NAME . LOOKUP-STATUS).
|
||||
|
||||
LOOKUP-STATUS being either in the form of ('status . 'not-found),
|
||||
\('status . 'loading) or (('status . (ssh . ssh-checkout-url) (https .
|
||||
https-checkout-url)) ('key . \"1\"))."
|
||||
(let*
|
||||
((status (alist-get 'status forge-result))
|
||||
(key (alist-get 'key forge-result))
|
||||
(forge-name (car forge-result))
|
||||
(status-text (cond
|
||||
((eq status 'loading) (format "[?] %s (loading...)" forge-name))
|
||||
((eq status 'not-found) (format "[X] %s" forge-name))
|
||||
((listp status) (format "[✓] %s" forge-name))
|
||||
(t (error (format "h--draw-forge-status: Invalid forge status %s" status)))))
|
||||
(text (if (null key)
|
||||
(format "%s\n" status-text)
|
||||
(format "%s [%s]\n" status-text (char-to-string key))))
|
||||
(font-color (cond
|
||||
((eq status 'loading) "orange")
|
||||
((eq status 'not-found) "red")
|
||||
((listp status) "green")
|
||||
(t (error (format "h--draw-forge-status: Invalid forge status %s" status)))))
|
||||
(original-point (point)))
|
||||
(progn
|
||||
(if (not (null key))
|
||||
(local-set-key (kbd (format "%s" (char-to-string key)))
|
||||
(lambda ()
|
||||
(interactive)
|
||||
(progn
|
||||
(delete-window)
|
||||
(h--clone-from-forge-result forge-result)))))
|
||||
(insert text)
|
||||
;; Set color for status indicator
|
||||
(set-text-properties original-point
|
||||
(+ original-point 4)
|
||||
`(face (:foreground ,font-color :weight bold)))
|
||||
;; Set color for key binding (if there's one)
|
||||
(if (not (null key))
|
||||
(set-text-properties (- (point) 4) (point)
|
||||
'(face (:foreground "orange" :weight bold)))))))
|
||||
|
||||
(defun h--find-next-available-key-binding (cur-key-binding)
|
||||
"Find a key binding starting CUR-KEY-BINDING for the h buffer.
|
||||
|
||||
We're using the 1-9 numbers, then, once all the numbers are already in
|
||||
use, we start allocating the a-Z letters."
|
||||
(cond ((= cur-key-binding ?9) ?a)
|
||||
((= cur-key-binding ?z) (error "Keys exhausted, can't bind any more"))
|
||||
(t (+ cur-key-binding 1))))
|
||||
|
||||
(defun h--clone-from-forge-result (forge-result)
|
||||
(let*
|
||||
((forge-result-status (alist-get 'status (cdr forge-result)))
|
||||
(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))))
|
||||
(progn
|
||||
(message (format "Cloning %s to %s" ssh-url dest-dir)
|
||||
(h--git-clone-in-dir ssh-url dest-dir)
|
||||
(message (format "Successfully cloned %s" dest-dir))
|
||||
(find-file dest-dir)))))
|
||||
|
||||
;; Internal: Internal state management
|
||||
|
||||
(defun h--update-forges-state (forge-name new-state)
|
||||
"Update ‘h--forge-fetchers-state’ for FORGE-NAME with NEW-STATE."
|
||||
(progn
|
||||
(mutex-lock h--forge-fetchers-state-mutex)
|
||||
(setq h--forge-fetchers-state (assq-delete-all forge-name h--forge-fetchers-state))
|
||||
(setq h--forge-fetchers-state (cons `(,forge-name . ,new-state) h--forge-fetchers-state))
|
||||
(h--draw-ui-buffer h--forge-fetchers-state)
|
||||
(mutex-unlock h--forge-fetchers-state-mutex)))
|
||||
|
||||
|
||||
(defun h--query-forge-fetchers (repo-query)
|
||||
"Find repo matches to the relevant forges for REPO-QUERY then query forge.
|
||||
|
||||
TODO: split that mess before release. We shouldn't query here."
|
||||
(let* ((relevant-forges (h--pick-relevant-forges repo-query h-forge-fetchers))
|
||||
(parsed-repo-query (h--parse-repo-identifier repo-query))
|
||||
(repo-query-kind (alist-get 'tag parsed-repo-query)))
|
||||
(cond
|
||||
((equal repo-query-kind 'owner-repo)
|
||||
(seq-map
|
||||
(lambda (forge)
|
||||
(let* ((owner (alist-get 'owner parsed-repo-query))
|
||||
(repo (alist-get 'repo parsed-repo-query))
|
||||
(fetch-func (alist-get 'query-user-repo forge))
|
||||
(forge-str (car forge)))
|
||||
(apply `(,fetch-func
|
||||
,owner
|
||||
,repo
|
||||
(lambda (result)
|
||||
(let ((new-state
|
||||
(if (null result) 'not-found result)))
|
||||
(progn
|
||||
(h--update-forges-state ,forge-str new-state))))))))
|
||||
relevant-forges))
|
||||
((equal repo-query-kind 'repo) (error (format "Can't checkout %s (for now), please specify a owner" repo-query)))
|
||||
((equal repo-query-kind 'full-url) (error "TODO: Can't checkout a full URL (for now)"))
|
||||
(t (error repo-query-kind)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Interactive Commands
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(defun h-checkout-project (user-query)
|
||||
(interactive "sGit repository to checkout: ")
|
||||
(progn
|
||||
(setq h--forge-fetchers-state nil)
|
||||
(h--query-forge-fetchers user-query)))
|
||||
|
||||
(defun h-jump-to-project ()
|
||||
"Open a project contained in the ‘h-code-root’ directory.
|
||||
If the project is not here yet, check it out from the available sources."
|
||||
|
|
|
|||
Loading…
Reference in a new issue