2022-07-05 10:21:11 +02:00
|
|
|
|
;;; my-repo-pins.el --- Keep your git repositories organized -*- lexical-binding: t -*-
|
2022-04-01 09:55:31 +02:00
|
|
|
|
|
2023-01-15 12:03:53 +01:00
|
|
|
|
;;; Copyright (C) 2022-2023 Félix Baylac Jacqué
|
2022-04-04 17:31:26 +02:00
|
|
|
|
;;; Author: Félix Baylac Jacqué <felix at alternativebit.fr>
|
|
|
|
|
;;; Maintainer: Félix Baylac Jacqué <felix at alternativebit.fr>
|
2023-01-15 12:03:53 +01:00
|
|
|
|
;;; Version: 0.4
|
2022-07-11 14:57:00 +02:00
|
|
|
|
;;; Homepage: https://alternativebit.fr/projects/my-repo-pins/
|
2022-06-09 12:35:42 +02:00
|
|
|
|
;;; Package-Requires: ((emacs "26.1"))
|
2022-04-01 09:55:31 +02:00
|
|
|
|
;;; License:
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;
|
|
|
|
|
;; This program 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 program 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 program. If not, see <https://www.gnu.org/licenses/>
|
|
|
|
|
;;
|
2022-06-24 18:50:03 +02:00
|
|
|
|
;;; Commentary:
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Open source developers often have to jump between projects, either
|
|
|
|
|
;; to read code, or to craft patches. My Repo Pins reduces the
|
|
|
|
|
;; friction so that it becomes trivial to do so.
|
|
|
|
|
|
|
|
|
|
;; The idea of the plugin is based on this idea; if the repository
|
|
|
|
|
;; URLs can be translated to a filesystem location, the local disk can
|
|
|
|
|
;; be used like a cache. My Repo Pins lazily clones the repo to the
|
|
|
|
|
;; filesystem location if needed, and then jumps into the project in
|
|
|
|
|
;; one single command. You don't have to remember where you put the
|
|
|
|
|
;; project on the local filesystem because it's always using the same
|
|
|
|
|
;; location. Something like this:
|
|
|
|
|
;;
|
|
|
|
|
;; ~/code-root
|
|
|
|
|
;; ├── codeberg.org
|
|
|
|
|
;; │ └── Freeyourgadget
|
|
|
|
|
;; │ └── Gadgetbridge
|
|
|
|
|
;; └── github.com
|
|
|
|
|
;; ├── BaseAdresseNationale
|
|
|
|
|
;; │ └── fantoir
|
|
|
|
|
;; ├── mpv-player
|
|
|
|
|
;; │ └── mpv
|
|
|
|
|
;; └── NinjaTrappeur
|
|
|
|
|
;; ├── cinny
|
2022-07-11 13:16:03 +02:00
|
|
|
|
;; └── my-repo-pins
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;
|
|
|
|
|
;; The main entry point of this package is the my-repo-pins command.
|
|
|
|
|
;; Using it, you can either:
|
|
|
|
|
;;
|
|
|
|
|
;; - Open Dired in a local project you already cloned.
|
|
|
|
|
;; - Query remote forges for a repository, clone it, and finally open
|
|
|
|
|
;; Dired in the clone directory.
|
|
|
|
|
;; - Clone a git clone URL and open Dired to the right directory.
|
|
|
|
|
;;
|
|
|
|
|
;; The minimal configuration consists in setting the directory in
|
|
|
|
|
;; which you want to clone all your git repositories via the
|
|
|
|
|
;; my-repo-pins-code-root variable.
|
|
|
|
|
;;
|
|
|
|
|
;; Let's say you'd like to store all your git repositories in the
|
|
|
|
|
;; ~/code-root directory. You'll want to add the following snippet in
|
|
|
|
|
;; your Emacs configuration file:
|
|
|
|
|
;;
|
|
|
|
|
;; (require 'my-repo-pins)
|
|
|
|
|
;; (setq my-repo-pins-code-root "~/code-root")
|
|
|
|
|
;;
|
|
|
|
|
;; You can then call the M-x my-repo-pins command to open a
|
|
|
|
|
;; project living in your ~/code-root directory or clone a new
|
|
|
|
|
;; project in your code root.
|
|
|
|
|
;;
|
|
|
|
|
;; Binding this command to a global key binding might make things a
|
|
|
|
|
;; bit more convenient. I personally like to bind it to M-h. You can
|
|
|
|
|
;; add the following snippet to your Emacs configuration to set up
|
|
|
|
|
;; this key binding:
|
|
|
|
|
;;
|
|
|
|
|
;; (global-set-key (kbd "M-h") 'my-repo-pins)
|
2022-12-31 16:36:07 +01:00
|
|
|
|
;;
|
|
|
|
|
;; The my-repo-pins-open-function variable can be customized if you
|
|
|
|
|
;; would prefer to land in some other program than Dired. Good
|
|
|
|
|
;; candidates might be the builtin 'vc-dir or 'magit-status if you use
|
|
|
|
|
;; the popular Magit package:
|
|
|
|
|
;;
|
|
|
|
|
;; (setq my-repo-pins-open-function 'vc-dir)
|
2022-04-01 09:55:31 +02:00
|
|
|
|
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
2022-04-07 12:17:40 +02:00
|
|
|
|
(require 'json)
|
2022-04-08 16:25:16 +02:00
|
|
|
|
(require 'url)
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(require 'cl-lib)
|
2022-04-05 10:07:30 +02:00
|
|
|
|
;; Required to batch eval the module: the substring functions are
|
|
|
|
|
;; loaded by default in interactive emacs, not in batch-mode emacs.
|
2022-04-04 17:28:27 +02:00
|
|
|
|
(eval-when-compile (require 'subr-x))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defgroup my-repo-pins-group nil
|
2022-07-11 13:16:03 +02:00
|
|
|
|
"Variables used to setup the my-repo-pins project manager."
|
2022-04-01 20:04:09 +02:00
|
|
|
|
:group 'Communication)
|
|
|
|
|
|
2022-04-07 11:06:34 +02:00
|
|
|
|
;; Internal: git primitives
|
2022-04-04 17:41:17 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defcustom my-repo-pins-git-bin "git"
|
2022-04-02 11:56:24 +02:00
|
|
|
|
"Path pointing to the git binary.
|
|
|
|
|
By default, it'll look for git in the current $PATH."
|
|
|
|
|
:type 'file
|
2022-06-27 14:44:51 +02:00
|
|
|
|
:group 'my-repo-pins-group)
|
2022-04-02 11:56:24 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--git-path ()
|
|
|
|
|
"Find the git binary path using ‘my-repo-pins-git-bin’.
|
2022-04-02 11:56:24 +02:00
|
|
|
|
|
|
|
|
|
Errors out if we can't find it."
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(if (file-executable-p my-repo-pins-git-bin)
|
|
|
|
|
my-repo-pins-git-bin
|
|
|
|
|
(let ((git-from-bin-path (locate-file my-repo-pins-git-bin exec-path)))
|
2022-04-02 11:56:24 +02:00
|
|
|
|
(if (file-executable-p git-from-bin-path)
|
|
|
|
|
git-from-bin-path
|
2022-07-05 10:12:56 +02:00
|
|
|
|
(user-error "Can't find git. Is my-repo-pins-git-bin correctly set?")))))
|
2022-04-02 11:56:24 +02:00
|
|
|
|
|
2022-11-27 13:42:37 +01:00
|
|
|
|
(defun my-repo-pins--call-git-in-dir-process-filter (str)
|
|
|
|
|
"Filtering the git output for ‘my-repo-pins--call-git-in-dir’ call.
|
|
|
|
|
|
|
|
|
|
By default, git seems to be terminating its stdout/stderr lines using
|
|
|
|
|
the CR; sequence instead of the traditional CR;LF; unix sequence.
|
|
|
|
|
|
|
|
|
|
This filter tries to detect these isolated CR sequences and convert
|
|
|
|
|
them in a CR;LF sequence.
|
|
|
|
|
|
|
|
|
|
STR being the string we have to process."
|
|
|
|
|
(replace-regexp-in-string "\r" "\n" str))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--call-git-in-dir (dir &optional callback &rest args)
|
|
|
|
|
"Call the git binary as pointed by ‘my-repo-pins-git-bin’ in DIR with ARGS.
|
2022-06-17 09:27:34 +02:00
|
|
|
|
|
|
|
|
|
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."
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(let* ((git-buffer (get-buffer-create "*my repo pins git log*"))
|
2022-06-17 09:27:34 +02:00
|
|
|
|
(git-window nil)
|
|
|
|
|
(current-buffer (current-buffer))
|
2022-11-27 13:42:37 +01:00
|
|
|
|
(git-filter (lambda
|
|
|
|
|
(proc str)
|
|
|
|
|
(with-current-buffer (process-buffer proc)
|
|
|
|
|
(insert (my-repo-pins--call-git-in-dir-process-filter str)))))
|
2022-06-17 09:27:34 +02:00
|
|
|
|
(git-sentinel (lambda
|
2022-06-24 18:07:05 +02:00
|
|
|
|
(process _event)
|
|
|
|
|
(let ((exit-code (process-exit-status process)))
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(if (window-valid-p git-window)
|
|
|
|
|
(delete-window git-window))
|
|
|
|
|
(if callback
|
|
|
|
|
(funcall callback exit-code))))))
|
|
|
|
|
(set-buffer git-buffer)
|
|
|
|
|
(erase-buffer)
|
|
|
|
|
(setq default-directory dir)
|
|
|
|
|
(setq git-window (display-buffer git-buffer))
|
|
|
|
|
(prog1
|
|
|
|
|
(make-process
|
|
|
|
|
:name "my-repo-pins-git-subprocess"
|
|
|
|
|
:buffer git-buffer
|
|
|
|
|
:command (seq-concatenate 'list `(,(my-repo-pins--git-path)) args)
|
2022-11-27 13:42:37 +01:00
|
|
|
|
:filter git-filter
|
2022-07-05 10:34:43 +02:00
|
|
|
|
:sentinel git-sentinel)
|
|
|
|
|
(set-buffer current-buffer))))
|
2022-06-17 09:27:34 +02:00
|
|
|
|
|
2023-01-20 11:53:30 +01:00
|
|
|
|
|
|
|
|
|
(defun my-repo-pins--is-clone-url-in-code-root (clone-url code-root)
|
|
|
|
|
"Check if CLONE-URL has been already cloned to the CODE-ROOT.
|
|
|
|
|
|
|
|
|
|
Return t if that's the case, nil if it's not."
|
|
|
|
|
(let ((clone-filepath (my-repo-pins--filepath-from-clone-url clone-url)))
|
|
|
|
|
(and
|
|
|
|
|
(not (eq nil clone-filepath))
|
|
|
|
|
(file-directory-p
|
|
|
|
|
(concat code-root
|
|
|
|
|
(my-repo-pins--filepath-from-clone-url clone-url))))))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--git-clone-in-dir (clone-url checkout-filepath &optional callback)
|
2022-06-17 09:27:34 +02:00
|
|
|
|
"Clone the CLONE-URL repo at CHECKOUT-FILEPATH.
|
|
|
|
|
|
2022-11-09 16:11:02 +01:00
|
|
|
|
Call CALLBACK with the git exit code once the git subprocess exits.
|
|
|
|
|
Checks first whether or not CLONE-URL is valid using
|
|
|
|
|
‘my-repo-pins--git-ls-remote-in-dir’ to prevent git clone from
|
|
|
|
|
creating an empty directory at CHECKOUT-FILEPATH."
|
|
|
|
|
(my-repo-pins--git-ls-remote-in-dir
|
|
|
|
|
clone-url
|
|
|
|
|
(lambda (exit-code)
|
|
|
|
|
(if (eq exit-code 0)
|
|
|
|
|
(my-repo-pins--call-git-in-dir "~/" callback "clone" clone-url checkout-filepath)
|
|
|
|
|
(funcall callback exit-code)))))
|
|
|
|
|
|
|
|
|
|
(defun my-repo-pins--git-ls-remote-in-dir (clone-url &optional callback)
|
|
|
|
|
"Check if a CLONE-URL is valid using git ls-remote.
|
|
|
|
|
|
2022-06-17 09:27:34 +02:00
|
|
|
|
Call CALLBACK with no arguments once the git subprocess exists."
|
2022-11-09 16:11:02 +01:00
|
|
|
|
(my-repo-pins--call-git-in-dir "~/" callback "ls-remote" "-q" "--exit-code" clone-url))
|
2022-04-02 11:56:24 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;===========================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
;; Internal: builtin fetchers
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;===========================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Generic fetcher infrastructure
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defvar my-repo-pins--builtins-forge-fetchers
|
2022-06-16 17:02:29 +02:00
|
|
|
|
'(("GitHub.com" .
|
2022-06-27 14:44:51 +02:00
|
|
|
|
((query-user-repo . my-repo-pins--query-github-owner-repo)))
|
2022-06-16 17:02:29 +02:00
|
|
|
|
("GitLab.com" .
|
2022-06-27 14:44:51 +02:00
|
|
|
|
((query-user-repo . (lambda (owner repo cb) (my-repo-pins--query-gitlab-owner-repo "gitlab.com" owner repo cb)))))
|
2022-06-16 17:27:56 +02:00
|
|
|
|
("git.sr.ht" .
|
2022-06-27 14:44:51 +02:00
|
|
|
|
((query-user-repo . (lambda (owner repo cb) (my-repo-pins--query-sourcehut-owner-repo "git.sr.ht" owner repo cb)))))
|
2022-06-16 19:04:05 +02:00
|
|
|
|
("Codeberg.org" .
|
2022-06-27 14:44:51 +02:00
|
|
|
|
((query-user-repo . (lambda (owner repo cb) (my-repo-pins--query-gitea-owner-repo "codeberg.org" owner repo cb))))))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
"Fetchers meant to be used in conjunction with ‘my-repo-pins-forge-fetchers’.
|
2022-05-16 18:40:42 +02:00
|
|
|
|
|
|
|
|
|
This variable contains fetchers for:
|
|
|
|
|
- github.com")
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defcustom my-repo-pins-forge-fetchers
|
|
|
|
|
my-repo-pins--builtins-forge-fetchers
|
2022-04-08 16:25:16 +02:00
|
|
|
|
"List of forges for which we want to remote fetch projects."
|
2022-05-16 18:40:42 +02:00
|
|
|
|
:type '(alist
|
|
|
|
|
:key-type symbol
|
|
|
|
|
:value-type (alist
|
|
|
|
|
:key-type symbol
|
|
|
|
|
:value-type (choice function string)))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
:group 'my-repo-pins-group)
|
2022-04-08 16:25:16 +02:00
|
|
|
|
|
2022-07-05 10:38:28 +02:00
|
|
|
|
(defvar my-repo-pins--forge-fetchers-state nil
|
2022-06-09 12:21:55 +02:00
|
|
|
|
|
|
|
|
|
"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)")
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defvar my-repo-pins--forge-fetchers-state-mutex
|
|
|
|
|
(make-mutex "my-repo-pins-ui-mutex")
|
2022-06-09 12:21:55 +02:00
|
|
|
|
"Mutex in charge of preventing several fetchers to update the state concurently.")
|
2022-04-08 16:25:16 +02:00
|
|
|
|
|
2022-07-17 15:12:46 +02:00
|
|
|
|
(defcustom my-repo-pins-max-depth
|
|
|
|
|
2
|
|
|
|
|
"Maximum search depth starting from the ‘my-repo-pins-code-root’ directory.
|
|
|
|
|
|
|
|
|
|
Set this variable to nil if you don't want any limit.
|
|
|
|
|
|
|
|
|
|
This is a performance stop gap. It'll prevent my repo pins from
|
|
|
|
|
accidentally walking too deep if it fails to detect a project
|
|
|
|
|
boundary.
|
|
|
|
|
|
|
|
|
|
By default, this limit is set to 2 to materialize the
|
|
|
|
|
<forge>/<username> directories that are supposed to contain the
|
|
|
|
|
projects.
|
|
|
|
|
|
|
|
|
|
We won't search further once we reach this limit. A warning message is
|
|
|
|
|
issued to the *Messages* buffer to warn the user the limit has been
|
|
|
|
|
reached."
|
|
|
|
|
:type 'integer
|
|
|
|
|
:group 'my-repo-pins-group)
|
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Sourcehut Fetcher
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--query-sourcehut-owner-repo (instance-url user-name repo-name callback)
|
2022-06-16 17:27:04 +02:00
|
|
|
|
"Query the INSTANCE-URL Sourcehut instance and retrieve some infos about a repo.
|
|
|
|
|
|
|
|
|
|
This function will try to determine whether or not the
|
|
|
|
|
USER-NAME/REPO-NAME repository exists in the INSTANCE-URL sourcehut
|
|
|
|
|
instance.
|
|
|
|
|
|
|
|
|
|
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.
|
|
|
|
|
|
|
|
|
|
Note: the sourcehut GraphQL API isn't currently accessible without a
|
|
|
|
|
authentication token. We can't really afford to ask the user to
|
|
|
|
|
manually generate such a token for this plugin. We want it to work out
|
|
|
|
|
of the box. Meaning, instead of using the API, we query the webapp
|
|
|
|
|
using a HEAD request and infer the clone links from there."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(setq url-request-method "HEAD")
|
|
|
|
|
(url-retrieve
|
|
|
|
|
(format "https://%s/~%s/%s" instance-url user-name repo-name)
|
|
|
|
|
(lambda (status &rest _rest)
|
|
|
|
|
(let ((repo-not-found (plist-get status :error)))
|
|
|
|
|
(if repo-not-found
|
|
|
|
|
(funcall callback nil)
|
|
|
|
|
(funcall
|
|
|
|
|
callback
|
|
|
|
|
`((ssh . ,(format "git@%s:~%s/%s" instance-url user-name repo-name))
|
|
|
|
|
(https . ,(format "https://%s/~%s/%s" instance-url user-name repo-name))))))))
|
|
|
|
|
(setq url-request-method nil))
|
2022-06-16 17:27:04 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Gitlab Fetcher
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--query-gitlab-owner-repo (instance-url user-name repo-name callback)
|
2022-06-16 16:45:45 +02:00
|
|
|
|
"Queries the INSTANCE-URL Gitlab instance and retrieve some infos about a repo.
|
|
|
|
|
|
|
|
|
|
This function will try to determine whether or not the
|
|
|
|
|
USER-NAME/REPO-NAME repository exists in the INSTANCE-URL Gitlab
|
|
|
|
|
instance.
|
|
|
|
|
|
|
|
|
|
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.
|
|
|
|
|
|
|
|
|
|
Note: the gitlab GraphQL API is not accessible without a bearing
|
|
|
|
|
token, the gitlab REST API doesn't provide a endpoint to retrieve the
|
|
|
|
|
clone URL of a repository. Meaning instead of using an API, we make a
|
|
|
|
|
HEAD request to the repository HTTP endpoint and infer by ourselves
|
|
|
|
|
the clone URLs. It might go south at some point, but that's sadly the
|
|
|
|
|
only option we have for now."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(setq url-request-method "HEAD")
|
|
|
|
|
(url-retrieve
|
|
|
|
|
(format "https://%s/%s/%s" instance-url user-name repo-name)
|
|
|
|
|
(lambda (status &rest _rest)
|
|
|
|
|
(let ((repo-not-found (plist-get status :error)))
|
|
|
|
|
(if repo-not-found
|
|
|
|
|
(funcall callback nil)
|
|
|
|
|
(funcall
|
|
|
|
|
callback
|
|
|
|
|
`((ssh . ,(format "git@%s:%s/%s.git" instance-url user-name repo-name))
|
|
|
|
|
(https . ,(format "https://%s/%s/%s.git" instance-url user-name repo-name))))))))
|
|
|
|
|
(setq url-request-method nil))
|
2022-06-16 16:45:45 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Github Fetcher
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--query-github-owner-repo (user-name repo-name callback)
|
2022-06-09 12:24:39 +02:00
|
|
|
|
"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."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(url-retrieve
|
|
|
|
|
(format "https://api.github.com/repos/%s/%s" user-name repo-name)
|
|
|
|
|
(lambda (&rest _rest) (funcall callback (my-repo-pins--fetch-github-parse-response(current-buffer))))))
|
2022-06-09 12:24:39 +02:00
|
|
|
|
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--fetch-github-parse-response (response-buffer)
|
2022-04-07 11:06:34 +02:00
|
|
|
|
"Parse the RESPONSE-BUFFER containing a GET response from the GitHub API.
|
|
|
|
|
|
2022-06-05 08:11:51 +02:00
|
|
|
|
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)
|
2022-07-11 13:41:56 +02:00
|
|
|
|
(https . HTTPS-CHECKOUT-URL))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
|
|
|
|
Returns nil if the repo does not exists."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(set-buffer response-buffer)
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(when (not(eq(re-search-forward "^HTTP/1.1 200 OK$" nil t) nil))
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(re-search-forward "^$")
|
|
|
|
|
(delete-region (point) (point-min))
|
|
|
|
|
(let* ((parsed-buffer (json-read))
|
|
|
|
|
(ssh-url (alist-get 'ssh_url parsed-buffer))
|
|
|
|
|
(https-url (alist-get 'clone_url parsed-buffer)))
|
|
|
|
|
`((ssh . ,ssh-url)
|
|
|
|
|
(https . ,https-url)))))
|
2022-04-08 16:25:16 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;; Gitea Fetcher
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--query-gitea-owner-repo (instance-url user-name repo-name callback)
|
2022-06-16 18:59:45 +02:00
|
|
|
|
"Queries the INSTANCE-URL gitea instance to retrieve a repo informations.
|
2022-07-11 13:42:41 +02:00
|
|
|
|
This function will first try to determine whether the
|
2022-06-16 18:59:45 +02:00
|
|
|
|
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://%s/api/v1/repos/%s/%s" instance-url user-name repo-name)
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(lambda (&rest _rest) (funcall callback (my-repo-pins--fetch-gitea-parse-response(current-buffer))))))
|
2022-06-16 18:59:45 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--fetch-gitea-parse-response (response-buffer)
|
2022-06-16 18:59:45 +02:00
|
|
|
|
"Parse the RESPONSE-BUFFER containing a GET response from the Gitea API.
|
|
|
|
|
|
|
|
|
|
Parsing a response from a GET https://instance/api/v1/repos/user/repo request.
|
|
|
|
|
|
|
|
|
|
If the repo does exists, returns a alist in the form of:
|
|
|
|
|
|
|
|
|
|
`(
|
|
|
|
|
(ssh . SSH-CHECKOUT-URL)
|
2022-07-11 13:41:56 +02:00
|
|
|
|
(https . HTTPS-CHECKOUT-URL))
|
2022-06-16 18:59:45 +02:00
|
|
|
|
|
|
|
|
|
Returns nil if the repo does not exists."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(set-buffer response-buffer)
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(when (not(eq(re-search-forward "^HTTP/1.1 200 OK$" nil t) nil))
|
|
|
|
|
(goto-char (point-min))
|
|
|
|
|
(re-search-forward "^$")
|
|
|
|
|
(delete-region (point) (point-min))
|
|
|
|
|
(let* ((parsed-buffer (json-read))
|
|
|
|
|
(ssh-url (alist-get 'ssh_url parsed-buffer))
|
|
|
|
|
(https-url (alist-get 'clone_url parsed-buffer)))
|
|
|
|
|
`((ssh . ,ssh-url)
|
|
|
|
|
(https . ,https-url)))))
|
2022-05-04 20:02:27 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;==========================
|
2022-05-04 20:04:20 +02:00
|
|
|
|
;; Internal: repo URI parser
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;==========================
|
2022-05-04 20:04:20 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--parse-repo-identifier (query-str)
|
2022-05-19 11:57:31 +02:00
|
|
|
|
"Do its best to figure out which repo the user meant by QUERY-STR.
|
2022-05-04 20:04:20 +02:00
|
|
|
|
|
2022-05-19 11:57:31 +02:00
|
|
|
|
A valid QUERY-STR is in one of the 4 following formats:
|
2022-05-04 20:04:20 +02:00
|
|
|
|
|
|
|
|
|
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
|
2022-05-19 11:57:31 +02:00
|
|
|
|
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\
|
2022-07-11 13:16:03 +02:00
|
|
|
|
. \"my-repo-pins\"))
|
2022-05-19 11:57:31 +02:00
|
|
|
|
or
|
2022-07-11 13:16:03 +02:00
|
|
|
|
\(('tag . 'repo) ('repo . \"my-repo-pins\"))"
|
2022-05-04 20:04:20 +02:00
|
|
|
|
(cond
|
2022-05-19 11:57:31 +02:00
|
|
|
|
;; Full-url case
|
|
|
|
|
((or (string-match "^https?://.*/.*/.*$" query-str)
|
2022-11-15 18:11:48 +01:00
|
|
|
|
(string-match "^.*/.*/.*$" query-str)
|
|
|
|
|
(string-match "^.*@.*:?.*$" query-str))
|
2022-05-19 11:57:31 +02:00
|
|
|
|
`((tag . full-url) (full-url . ,query-str)))
|
|
|
|
|
;; owner/repo case
|
|
|
|
|
((string-match "^.*/.*$" query-str)
|
|
|
|
|
(let*
|
2022-06-09 12:24:39 +02:00
|
|
|
|
((splitted-query (split-string query-str "/"))
|
2022-05-19 11:57:31 +02:00
|
|
|
|
(owner (car splitted-query))
|
|
|
|
|
(repo (cadr splitted-query)))
|
|
|
|
|
`((tag . owner-repo) (owner . ,owner) (repo . ,repo))))
|
|
|
|
|
;; repo case
|
|
|
|
|
(t `((tag . repo) (repo . ,query-str)))))
|
2022-05-04 20:04:20 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--filepath-from-clone-url (clone-url)
|
2022-05-04 20:07:00 +02:00
|
|
|
|
"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))))))
|
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=========================================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
;; Internal: code-root management functions
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=========================================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defcustom my-repo-pins-code-root nil
|
2022-04-07 11:06:34 +02:00
|
|
|
|
"Root directory containing all your projects.
|
2022-07-11 13:16:03 +02:00
|
|
|
|
my-repo-pins organise the git repos you'll checkout in a tree
|
2022-06-27 14:44:51 +02:00
|
|
|
|
fashion.
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-07-11 13:16:03 +02:00
|
|
|
|
All the code fetched using my-repo-pins will end up in this root directory. A
|
2022-04-07 11:06:34 +02:00
|
|
|
|
tree of subdirectories will be created mirroring the remote URI.
|
|
|
|
|
|
|
|
|
|
For instance, after checking out
|
|
|
|
|
https://git.savannah.gnu.org/git/emacs/org-mode.git, the source code
|
2022-06-27 14:44:51 +02:00
|
|
|
|
will live in the my-repo-pins-code-root/git.savannah.gnu.org/git/emacs/org-mode/
|
2022-04-07 11:06:34 +02:00
|
|
|
|
local directory"
|
|
|
|
|
:type 'directory
|
2022-06-27 14:44:51 +02:00
|
|
|
|
:group 'my-repo-pins-group)
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--safe-get-code-root ()
|
|
|
|
|
"Ensure ‘my-repo-pins-code-root’ is correctly set, then canonalize the path.
|
|
|
|
|
Errors out if ‘my-repo-pins-code-root’ has not been set yet."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(when (not my-repo-pins-code-root)
|
|
|
|
|
(user-error "My-Repo-Pins-code-root has not been set. Please point it to your code root"))
|
|
|
|
|
(expand-file-name (file-name-as-directory my-repo-pins-code-root)))
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
|
|
|
|
|
2022-07-17 15:12:46 +02:00
|
|
|
|
(defun my-repo-pins--find-git-dirs-recursively (dir max-depth)
|
2022-04-06 19:24:12 +02:00
|
|
|
|
"Vendored, slightly modified version of ‘directory-files-recursively’.
|
|
|
|
|
|
|
|
|
|
This library isn't available for Emacs > 25.1. Vendoring it for
|
|
|
|
|
backward compatibility.
|
|
|
|
|
|
2022-07-11 13:42:41 +02:00
|
|
|
|
We take advantage of vendoring this function to tailor it a bit more
|
2022-04-06 19:24:12 +02:00
|
|
|
|
for our needs.
|
|
|
|
|
|
|
|
|
|
Return list of all git repositories under directory DIR. This function works
|
|
|
|
|
recursively. Files are returned in \"depth first\" order, and files
|
|
|
|
|
from each directory are sorted in alphabetical order. Each file name
|
|
|
|
|
appears in the returned list in its absolute form.
|
|
|
|
|
|
2022-07-17 15:12:46 +02:00
|
|
|
|
The recursion will halt once MAX-DEPTH is reached. In that case, a
|
|
|
|
|
information message will be written to the message buffer.
|
|
|
|
|
|
|
|
|
|
If MAX-DEPTH is set to nil, do not use any recursion stop gap."
|
|
|
|
|
(cl-labels
|
|
|
|
|
((recurse-in-dir
|
|
|
|
|
(dir depth)
|
|
|
|
|
(let* ((projects nil)
|
|
|
|
|
(recur-result nil)
|
|
|
|
|
(dir (directory-file-name dir)))
|
|
|
|
|
(dolist (file (sort (file-name-all-completions "" dir)
|
|
|
|
|
'string<))
|
|
|
|
|
(unless (member file '("./" "../"))
|
|
|
|
|
(if (directory-name-p file)
|
|
|
|
|
(let ((full-file (concat dir "/" file)))
|
|
|
|
|
;; Don't follow symlinks to other directories.
|
|
|
|
|
(when (not (file-symlink-p full-file))
|
2022-07-25 20:17:02 +02:00
|
|
|
|
(if (my-repo-pins--is-git-dir full-file)
|
2022-07-17 15:12:46 +02:00
|
|
|
|
;; It's a git repo, let's stop here.
|
|
|
|
|
(setq projects (nconc projects (list full-file)))
|
|
|
|
|
;; It's not a git repo, let's recurse into it.
|
|
|
|
|
(if max-depth
|
|
|
|
|
;; if we didn't reach the max depth yet, recurse.
|
|
|
|
|
(if (not (> (+ depth 1) max-depth))
|
|
|
|
|
(setq recur-result
|
|
|
|
|
(nconc recur-result
|
|
|
|
|
(recurse-in-dir full-file (+ depth 1))))
|
|
|
|
|
;; we reached the max depth limit, issue a info message
|
|
|
|
|
(message
|
|
|
|
|
(concat
|
|
|
|
|
"my-repo-pins: max depth reached for "
|
|
|
|
|
"%s, we won't search for projects in that directory. "
|
|
|
|
|
"We might miss some projects. "
|
|
|
|
|
"Increase the my-repo-pins-max-depth variable value if "
|
|
|
|
|
"you want to look for projects in that directory.")
|
|
|
|
|
full-file))
|
|
|
|
|
;; There's no max depth, let's recurse.
|
|
|
|
|
(setq recur-result
|
|
|
|
|
(nconc recur-result
|
|
|
|
|
(recurse-in-dir full-file nil))))))))))
|
|
|
|
|
(nconc recur-result (nreverse projects)))))
|
|
|
|
|
(if max-depth
|
|
|
|
|
(recurse-in-dir dir 0)
|
|
|
|
|
(recurse-in-dir dir nil))))
|
|
|
|
|
|
2022-07-25 20:17:02 +02:00
|
|
|
|
(defun my-repo-pins--is-git-dir (dir)
|
|
|
|
|
"Return non-nil if DIR is a git directory."
|
|
|
|
|
(file-exists-p (concat (file-name-as-directory dir) ".git")))
|
|
|
|
|
|
2022-07-17 15:12:46 +02:00
|
|
|
|
(defun my-repo-pins--get-code-root-projects (code-root max-depth)
|
2022-04-01 20:04:09 +02:00
|
|
|
|
"Retrieve the projects contained in the CODE-ROOT directory.
|
2022-06-27 14:44:51 +02:00
|
|
|
|
We're going to make some hard assumptions about how the
|
|
|
|
|
‘my-repo-pins-code-root’ directory should look like. First of all, if
|
|
|
|
|
a directory seem to be a git repository, it'll automatically be
|
|
|
|
|
considered as a project root.
|
2022-04-01 20:04:09 +02:00
|
|
|
|
|
|
|
|
|
It means that after encountering a git repository, we won't recurse
|
2022-04-03 17:48:10 +02:00
|
|
|
|
any further.
|
|
|
|
|
|
2022-07-17 15:12:46 +02:00
|
|
|
|
We also won't recurse for directories nested deeper than MAX-DEPTH.
|
|
|
|
|
|
|
|
|
|
If MAX-DEPTH is set to -1, do not use any recursion stop gap.
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
If the directory pointed by ‘my-repo-pins-code-root’ does not exists
|
|
|
|
|
yet, returns an empty list."
|
2022-04-03 17:48:10 +02:00
|
|
|
|
(if (not (file-directory-p code-root))
|
2022-07-05 10:38:28 +02:00
|
|
|
|
nil
|
2022-04-03 17:48:10 +02:00
|
|
|
|
(let*
|
2022-04-06 19:48:56 +02:00
|
|
|
|
((remove-code-root-prefix-and-trailing-slash
|
|
|
|
|
(lambda (path)
|
|
|
|
|
(let ((path-without-prefix (string-remove-prefix code-root path)))
|
|
|
|
|
(substring path-without-prefix 0 (1- (length path-without-prefix))))))
|
2022-07-17 15:12:46 +02:00
|
|
|
|
(projects-absolute-path (my-repo-pins--find-git-dirs-recursively code-root max-depth))
|
2022-04-03 17:48:10 +02:00
|
|
|
|
(projects-relative-to-code-root
|
2022-04-06 19:48:56 +02:00
|
|
|
|
(mapcar remove-code-root-prefix-and-trailing-slash projects-absolute-path)))
|
2022-04-03 17:48:10 +02:00
|
|
|
|
projects-relative-to-code-root)))
|
2022-04-01 09:55:31 +02:00
|
|
|
|
|
2022-12-31 16:36:07 +01:00
|
|
|
|
(defcustom my-repo-pins-open-function 'find-file
|
|
|
|
|
"Function to call once the repository is located and available."
|
|
|
|
|
:type 'function
|
|
|
|
|
:group 'my-repo-pins-group)
|
|
|
|
|
|
|
|
|
|
(defun my-repo-pins--open (dir)
|
2023-01-02 14:05:56 +01:00
|
|
|
|
"Open the DIR directory using the ‘my-repo-pins-code-root’ function."
|
2022-12-31 16:36:07 +01:00
|
|
|
|
(funcall my-repo-pins-open-function dir))
|
|
|
|
|
|
2023-01-20 11:53:30 +01:00
|
|
|
|
|
|
|
|
|
(defun my-repo-pins--is-repo-query-cloned-in-code-root (repo-query)
|
|
|
|
|
"Check if REPO-QUERY has been already cloned to the code-root.
|
|
|
|
|
|
|
|
|
|
Return t if that's the case, nil if it's not."
|
|
|
|
|
(let* ((parsed-repo-query (my-repo-pins--parse-repo-identifier repo-query))
|
|
|
|
|
(repo-query-kind (alist-get 'tag parsed-repo-query)))
|
|
|
|
|
;; It's impossible to say whether or not a owner/repo or repo
|
|
|
|
|
;; query has been already cloned without resolving it first.
|
|
|
|
|
(if (eq repo-query-kind 'full-url)
|
|
|
|
|
(file-directory-p (concat (my-repo-pins--safe-get-code-root)
|
|
|
|
|
(my-repo-pins--filepath-from-clone-url (cdr repo-query))))
|
|
|
|
|
nil)))
|
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=============
|
2022-05-16 18:40:42 +02:00
|
|
|
|
;; Internal: UI
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=============
|
2022-05-09 15:38:21 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--evil-safe-binding (kbd action)
|
2022-06-14 10:42:06 +02:00
|
|
|
|
"Bind ACTION to the KBD keyboard key.
|
|
|
|
|
|
2022-06-24 18:50:03 +02:00
|
|
|
|
This key binding will be bound to the current buffer. If ‘evil-mode’
|
|
|
|
|
is used, the key binding will be bound to the normal mode as well."
|
2022-06-14 10:42:06 +02:00
|
|
|
|
(let ((evil-mode-enabled (member 'evil-mode minor-mode-list)))
|
|
|
|
|
(if evil-mode-enabled
|
|
|
|
|
(progn
|
|
|
|
|
(local-set-key kbd action)
|
|
|
|
|
(when (require 'evil-core nil t)
|
2022-07-05 10:08:27 +02:00
|
|
|
|
(declare-function evil-local-set-key "ext:evil-core.el" "STATE" "KEY" "DEF" t)
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(evil-local-set-key 'normal kbd action)))
|
2022-06-14 10:42:06 +02:00
|
|
|
|
(local-set-key kbd action))))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--draw-ui-buffer (forge-query-status user-query)
|
2022-06-09 12:17:16 +02:00
|
|
|
|
"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.
|
|
|
|
|
|
2022-06-14 12:02:18 +02:00
|
|
|
|
USER-QUERY being the original user query we're trying to find a repo
|
|
|
|
|
to clone for.
|
|
|
|
|
|
2022-06-09 12:17:16 +02:00
|
|
|
|
We're going to draw these forge query status results in a buffer and
|
|
|
|
|
associate each of them with a key binding.
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
, ‘my-repo-pins--draw-forge-status’ is in charge of
|
2022-07-11 13:16:03 +02:00
|
|
|
|
drawing the forge status in the my-repo-pins buffer."
|
2022-06-09 12:17:16 +02:00
|
|
|
|
(let* (
|
2022-07-05 10:02:57 +02:00
|
|
|
|
(my-repo-pins-buffer (get-buffer-create "my-repo-pins-ui-buffer"))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(my-repo-pins-window nil)
|
2022-06-09 12:17:16 +02:00
|
|
|
|
(previous-buffer (current-buffer))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(forge-status-with-keys (my-repo-pins--add-keys-to-forge-status forge-query-status)))
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(set-buffer my-repo-pins-buffer)
|
|
|
|
|
(setq buffer-read-only nil)
|
|
|
|
|
(erase-buffer)
|
|
|
|
|
(insert (format "Looking up for %s in different forges:\n\n\n" user-query))
|
|
|
|
|
(set-text-properties 1 (point) `(face (:foreground "orange" :weight bold)))
|
|
|
|
|
(seq-map
|
|
|
|
|
(lambda (e) (my-repo-pins--draw-forge-status e)) forge-status-with-keys)
|
|
|
|
|
(insert "\n\nPlease select the forge we should clone the project from.\n")
|
|
|
|
|
(insert "Press q to close this window.")
|
|
|
|
|
(setq buffer-read-only t)
|
|
|
|
|
(my-repo-pins--evil-safe-binding (kbd "q")
|
|
|
|
|
`(lambda () (interactive)
|
|
|
|
|
(delete-window)
|
|
|
|
|
(kill-buffer ,my-repo-pins-buffer)))
|
|
|
|
|
(set-buffer previous-buffer)
|
|
|
|
|
(setq my-repo-pins-window (display-buffer my-repo-pins-buffer))
|
|
|
|
|
(select-window my-repo-pins-window)))
|
2022-06-09 12:17:16 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--add-keys-to-forge-status (forge-query-status)
|
2022-06-09 12:17:16 +02:00
|
|
|
|
"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.
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
‘my-repo-pins--find-next-available-key-binding’ is in charge of generating the
|
2022-06-09 12:17:16 +02:00
|
|
|
|
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
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(if isFound (my-repo-pins--find-next-available-key-binding (car acc)) (car acc)))
|
2022-06-09 12:17:16 +02:00
|
|
|
|
(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 . ())))))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--draw-forge-status (forge-result)
|
2022-06-09 12:17:16 +02:00
|
|
|
|
"Draws FORGE-RESULT status to the current buffer.
|
|
|
|
|
|
|
|
|
|
FORGE-STATUS being a alist in the form of (FORGE-NAME . LOOKUP-STATUS).
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
2022-06-09 12:17:16 +02:00
|
|
|
|
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\"))."
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(let*
|
2022-06-05 08:11:51 +02:00
|
|
|
|
((status (alist-get 'status forge-result))
|
|
|
|
|
(key (alist-get 'key forge-result))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(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))
|
2022-06-09 12:17:16 +02:00
|
|
|
|
((listp status) (format "[✓] %s" forge-name))
|
2022-06-27 18:30:15 +02:00
|
|
|
|
(t (error "my-repo-pins--draw-forge-status: Invalid forge status %s" status))))
|
2022-06-09 12:17:16 +02:00
|
|
|
|
(text (if (null key)
|
|
|
|
|
(format "%s\n" status-text)
|
|
|
|
|
(format "%s [%s]\n" status-text (char-to-string key))))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(font-color (cond
|
|
|
|
|
((eq status 'loading) "orange")
|
|
|
|
|
((eq status 'not-found) "red")
|
2022-06-09 12:17:16 +02:00
|
|
|
|
((listp status) "green")
|
2022-06-27 18:30:15 +02:00
|
|
|
|
(t (error "my-repo-pins--draw-forge-status: Invalid forge status %s" status))))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(my-repo-pins-buffer (current-buffer))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(original-point (point)))
|
2022-06-27 18:30:15 +02:00
|
|
|
|
(if key
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(my-repo-pins--evil-safe-binding (kbd (format "%s" (char-to-string key)))
|
2022-07-05 10:34:43 +02:00
|
|
|
|
`(lambda ()
|
|
|
|
|
(interactive)
|
|
|
|
|
(delete-window)
|
|
|
|
|
(kill-buffer ,my-repo-pins-buffer)
|
|
|
|
|
(my-repo-pins--clone-from-forge-result ',forge-result))))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(insert text)
|
|
|
|
|
;; Set color for status indicator
|
|
|
|
|
(set-text-properties original-point
|
|
|
|
|
(+ original-point 4)
|
|
|
|
|
`(face (:foreground ,font-color :weight bold)))
|
2022-06-09 12:17:16 +02:00
|
|
|
|
;; Set color for key binding (if there's one)
|
2022-06-27 18:30:15 +02:00
|
|
|
|
(if key
|
2022-06-09 12:17:16 +02:00
|
|
|
|
(set-text-properties (- (point) 4) (point)
|
2022-07-05 10:34:43 +02:00
|
|
|
|
'(face (:foreground "orange" :weight bold))))))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--find-next-available-key-binding (cur-key-binding)
|
|
|
|
|
"Find a key binding starting CUR-KEY-BINDING for the my-repo-pins buffer.
|
2022-05-09 15:38:21 +02:00
|
|
|
|
|
|
|
|
|
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)
|
2022-05-16 18:40:42 +02:00
|
|
|
|
((= cur-key-binding ?z) (error "Keys exhausted, can't bind any more"))
|
2022-05-09 15:38:21 +02:00
|
|
|
|
(t (+ cur-key-binding 1))))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--clone-from-forge-result (forge-result)
|
2022-06-10 11:24:46 +02:00
|
|
|
|
"Clone a repository using the FORGE-RESULT alist.
|
|
|
|
|
|
|
|
|
|
The FORGE-RESULT alist is in the form of (status . (https .
|
|
|
|
|
HTTPS-CHECKOUT-URL) (ssh . SSH-CHECKOUT-URL))
|
|
|
|
|
|
|
|
|
|
We'll first try to clone the ssh url: it's more convenient for the
|
|
|
|
|
user auth-wise. If the ssh clone fails, we'll fallback on the HTTPS
|
|
|
|
|
url."
|
2022-06-09 16:14:31 +02:00
|
|
|
|
(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))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(code-root (my-repo-pins--safe-get-code-root))
|
|
|
|
|
(dest-dir (concat code-root (my-repo-pins--filepath-from-clone-url http-url))))
|
2023-01-20 11:53:30 +01:00
|
|
|
|
(if (my-repo-pins--is-clone-url-in-code-root http-url code-root)
|
|
|
|
|
(my-repo-pins--open dest-dir)
|
|
|
|
|
(progn
|
|
|
|
|
(message "Cloning %s to %s" ssh-url dest-dir)
|
|
|
|
|
(cl-flet*
|
|
|
|
|
((clone-http
|
|
|
|
|
()
|
|
|
|
|
(my-repo-pins--git-clone-in-dir
|
|
|
|
|
http-url
|
|
|
|
|
dest-dir
|
|
|
|
|
(lambda (exit-code)
|
|
|
|
|
(if (not (equal exit-code 0))
|
|
|
|
|
(error "Cannot clone %s nor %s" ssh-url http-url)
|
|
|
|
|
(progn
|
|
|
|
|
(message "Successfully cloned %s" dest-dir)
|
|
|
|
|
(my-repo-pins--open dest-dir))))))
|
|
|
|
|
(clone-ssh
|
|
|
|
|
()
|
|
|
|
|
(my-repo-pins--git-clone-in-dir
|
|
|
|
|
ssh-url
|
|
|
|
|
dest-dir
|
|
|
|
|
(lambda (exit-code)
|
|
|
|
|
(if (not (equal exit-code 0))
|
|
|
|
|
(progn
|
|
|
|
|
(message "Failed to clone %s" ssh-url)
|
|
|
|
|
(message "Trying again with %s" http-url)
|
|
|
|
|
(clone-http))
|
|
|
|
|
(progn
|
|
|
|
|
(message "Successfully cloned %s" dest-dir)
|
|
|
|
|
(my-repo-pins--open dest-dir)))))))
|
|
|
|
|
(clone-ssh))))))
|
2022-06-17 09:27:34 +02:00
|
|
|
|
|
2022-11-09 16:11:02 +01:00
|
|
|
|
(defun my-repo-pins--clone-from-full-url (full-url &optional callback)
|
|
|
|
|
"Clone a repository from a fully-qualified FULL-URL git URL.
|
|
|
|
|
|
|
|
|
|
CALLBACK is called once the git process exited. It takes a single
|
|
|
|
|
exit-code parameter containing the process exit code."
|
|
|
|
|
(let*
|
|
|
|
|
((code-root (my-repo-pins--safe-get-code-root))
|
|
|
|
|
(dest-dir (concat code-root (my-repo-pins--filepath-from-clone-url full-url))))
|
2023-01-20 11:53:30 +01:00
|
|
|
|
;; here
|
|
|
|
|
(if (my-repo-pins--is-clone-url-in-code-root full-url code-root)
|
|
|
|
|
(my-repo-pins--open dest-dir)
|
|
|
|
|
(my-repo-pins--git-clone-in-dir
|
|
|
|
|
full-url
|
|
|
|
|
dest-dir
|
|
|
|
|
(lambda (exit-code)
|
|
|
|
|
(if callback
|
|
|
|
|
(funcall callback exit-code))
|
|
|
|
|
(if (equal exit-code 0)
|
|
|
|
|
(my-repo-pins--open dest-dir)
|
|
|
|
|
(error "Cannot clone %s" full-url)))))))
|
2022-06-09 16:14:31 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=========================================
|
2022-06-14 09:20:53 +02:00
|
|
|
|
;; Internal: improving builtin autocomplete
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=========================================
|
2022-06-14 09:20:53 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--completing-read-or-custom (prompt collection)
|
2022-07-05 10:39:34 +02:00
|
|
|
|
"Behaves similarly to ‘completing-read’.
|
2022-06-14 09:20:53 +02:00
|
|
|
|
|
2022-07-05 10:39:34 +02:00
|
|
|
|
See the ‘completing-read’ documentation for more details about PROMPT
|
2022-06-14 09:20:53 +02:00
|
|
|
|
and COLLECTION.
|
|
|
|
|
|
2022-07-05 10:39:34 +02:00
|
|
|
|
Behaves similarly to ‘completing-read’ with REQUIRE-MATCH set to nil
|
2022-06-14 09:20:53 +02:00
|
|
|
|
except it'll return an extra element specifying whether the input was
|
|
|
|
|
found in COLLECTION or if the result is a custom user-provided input.
|
|
|
|
|
|
|
|
|
|
Returns either ('in-collection . READ-RESULT) or ('user-provided .
|
|
|
|
|
READ-RESULT)"
|
|
|
|
|
(let ((read-result (completing-read prompt collection nil nil "")))
|
|
|
|
|
(if (member read-result collection)
|
|
|
|
|
`(in-collection . ,read-result)
|
|
|
|
|
`(user-provided . ,read-result))))
|
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;====================================
|
2022-06-09 16:14:31 +02:00
|
|
|
|
;; Internal: Internal state management
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;====================================
|
2022-05-09 15:38:21 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--init-forges-state (forge-fetchers)
|
|
|
|
|
"Initialize ‘my-repo-pins--forge-fetchers-state’.
|
2022-06-21 08:55:26 +02:00
|
|
|
|
|
|
|
|
|
We iterate through the forges set in FORGE-FETCHERS and associate
|
|
|
|
|
each of them with a pending status. We then return this new state
|
|
|
|
|
alist."
|
|
|
|
|
(seq-map (lambda (e) `(,(car e) . loading)) forge-fetchers))
|
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--update-forges-state (forge-name new-state user-query)
|
|
|
|
|
"Update ‘my-repo-pins--forge-fetchers-state’ for FORGE-NAME with NEW-STATE.
|
2022-06-14 12:02:18 +02:00
|
|
|
|
|
|
|
|
|
USER-QUERY was the original query for this state update."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(mutex-lock my-repo-pins--forge-fetchers-state-mutex)
|
|
|
|
|
(setq my-repo-pins--forge-fetchers-state (assq-delete-all forge-name my-repo-pins--forge-fetchers-state))
|
|
|
|
|
(setq my-repo-pins--forge-fetchers-state (cons `(,forge-name . ,new-state) my-repo-pins--forge-fetchers-state))
|
|
|
|
|
(my-repo-pins--draw-ui-buffer my-repo-pins--forge-fetchers-state user-query)
|
|
|
|
|
(mutex-unlock my-repo-pins--forge-fetchers-state-mutex))
|
2022-06-09 12:21:55 +02:00
|
|
|
|
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--query-forge-fetchers (repo-query)
|
2022-11-09 16:11:02 +01:00
|
|
|
|
"Find repo matches to the relevant forges for REPO-QUERY then query forge."
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(let* ((parsed-repo-query (my-repo-pins--parse-repo-identifier repo-query))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
(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))
|
2022-06-09 12:21:55 +02:00
|
|
|
|
(forge-str (car forge)))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
(apply `(,fetch-func
|
|
|
|
|
,owner
|
|
|
|
|
,repo
|
2022-06-09 12:21:55 +02:00
|
|
|
|
(lambda (result)
|
|
|
|
|
(let ((new-state
|
|
|
|
|
(if (null result) 'not-found result)))
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(my-repo-pins--update-forges-state ,forge-str new-state ,repo-query)))))))
|
2022-06-27 14:44:51 +02:00
|
|
|
|
my-repo-pins-forge-fetchers))
|
2022-07-05 10:12:56 +02:00
|
|
|
|
((equal repo-query-kind 'repo) (user-error "Can't checkout %s (for now), please specify a owner" repo-query))
|
2022-11-09 16:11:02 +01:00
|
|
|
|
((equal repo-query-kind 'full-url) (my-repo-pins--clone-from-full-url repo-query))
|
2022-07-17 16:01:57 +02:00
|
|
|
|
(t (error repo-query-kind)))))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=====================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
;; Interactive Commands
|
2022-07-05 10:21:11 +02:00
|
|
|
|
;;=====================
|
2022-04-07 11:06:34 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins--clone-project (user-query)
|
|
|
|
|
"Clone USER-QUERY in its appropriate directory in ‘my-repo-pins-code-root’."
|
2022-07-05 10:34:43 +02:00
|
|
|
|
(setq my-repo-pins--forge-fetchers-state (my-repo-pins--init-forges-state my-repo-pins-forge-fetchers))
|
|
|
|
|
(my-repo-pins--query-forge-fetchers user-query))
|
2022-06-05 08:11:51 +02:00
|
|
|
|
|
2022-06-14 09:20:53 +02:00
|
|
|
|
;;;###autoload
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(defun my-repo-pins ()
|
|
|
|
|
"Open a project contained in the ‘my-repo-pins-code-root’ directory.
|
|
|
|
|
If the project is not in the ‘my-repo-pins-code-root’ yet, check it out from the
|
2022-06-16 09:06:53 +02:00
|
|
|
|
available forge sources."
|
2022-04-04 17:41:17 +02:00
|
|
|
|
(interactive)
|
2023-01-15 11:50:51 +01:00
|
|
|
|
(let* ((user-query
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(my-repo-pins--completing-read-or-custom
|
2022-06-16 09:06:53 +02:00
|
|
|
|
"Jump to project: "
|
2023-01-20 11:53:30 +01:00
|
|
|
|
(my-repo-pins--get-code-root-projects (my-repo-pins--safe-get-code-root) my-repo-pins-max-depth))))
|
2022-06-14 09:20:53 +02:00
|
|
|
|
(cond
|
|
|
|
|
((equal (car user-query) 'in-collection)
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(let ((selected-project-absolute-path (concat (my-repo-pins--safe-get-code-root) (cdr user-query))))
|
2022-12-31 16:36:07 +01:00
|
|
|
|
(my-repo-pins--open selected-project-absolute-path)))
|
2022-06-14 09:20:53 +02:00
|
|
|
|
((equal (car user-query) 'user-provided)
|
2023-01-20 11:53:30 +01:00
|
|
|
|
(my-repo-pins--clone-project (cdr user-query))))))
|
2022-06-14 09:20:53 +02:00
|
|
|
|
|
2022-04-04 17:41:17 +02:00
|
|
|
|
|
2022-06-27 14:44:51 +02:00
|
|
|
|
(provide 'my-repo-pins)
|
|
|
|
|
;;; my-repo-pins.el ends here
|