changeset 698: |
96958d3eb5b0 |
parent: |
35a579313b80
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
3 ;; Mercurial is our primary VCS - but we blur the lines by mirroring 4 ;; our code to Git. In a few years mirroring will probably be 5 ;; unnecessary but it's a really useful hack FTTB. 7 ;; Our forge is based on an instance of Heptapod https://heptapod.net/ 8 ;; which is a GitLab fork. Most of the public repos are Mercurial, but 9 ;; there are a few 'reverse-mirrors' which I maintain exclusively as 10 ;; Git repos. Same goes for any fork I maintain - for example, Lust is 11 ;; my fork of rustlang/rust and is just a Git repository. 13 ;; HACK 2023-09-15: hgcmd interface, parsers, metadata object protocols 15 ;; https://wiki.mercurial-scm.org/Design 17 ;; https://wiki.mercurial-scm.org/CommandServer 19 ;; the cmdserver is the obvious solution for Skel to interact with 20 ;; Mercurial so we'll be leaning into it right away without bothering 21 ;; with the standard CLI. I'm unfamiliar with how this is done with 22 ;; Git, or if it's done at all. In Mercurial's case it seems they 23 ;; built it out of licensing issues and to avoid Python cold-start 24 ;; penalty which aren't issues for me ATM anyway. Git is written in C 25 ;; so doesn't suffer a cold-start hit, but it would be nice to 26 ;; interact with repos via a similar lightweight, local, wire 29 ;; BTW It was hard to find the command to start the command server - 30 ;; it's 'hg serve'. Here's the base shell command invoked by chg: 32 ;; hg serve --no-profile --cmdserver chgunix --address @INITSOCKNAME --daemon-postexec chdir:/ @DIR 37 (deferror hg-error (vc-error) () (:auto t)) 39 (defvar *default-hg-client-buffer-size* 4096) 40 (defvar *hg-program* (or (cli:find-exe "rhg") (cli:find-exe "hg"))) 42 (defun run-hg-command (cmd &optional args output (wait t)) 44 (unless (listp args) (setf args (list args))) 45 (setf args (mapcar 'vc/proto::namestring-or args)) ;; TODO 2024-05-10: slow 46 (sb-ext:run-program *hg-program* (push cmd args) :output output :wait wait)) 49 "Return nil if URL does not look like a URL to a hg valid remote." 50 (let ((url-str (if (typep url 'pathname) 53 (ppcre:scan '(:alternation 56 (:regex "^https://hg\\.") 60 (defun hgignore (&optional (path ".hgignore")) 61 (vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'ppcre:create-scanner path))) 63 ;; https://www.mercurial-scm.org/doc/hgrc.5.html 64 (defclass hg-config (vc-config) ()) 66 ;; (describe (make-instance 'hg-repo)) 67 ;; https://repo.mercurial-scm.org/hg/file/tip/mercurial/interfaces/repository.py 68 (defclass hg-repo (vc-repo) 69 ((dirstate :accessor vc-dirstate) ;; working-directory 70 (bookmarks :accessor vc-bookmarks) 71 (requires :accessor vc-requires))) 73 (defmethod vc-run ((self hg-repo) (cmd string) &rest args) 74 (uiop:with-current-directory ((vc-path self)) 75 (let ((proc (run-hg-command cmd args :stream nil))) 76 (with-open-stream (s (sb-ext:process-output proc)) 77 (loop for l = (read-line s nil nil) 80 (if (eq 0 (sb-ext:process-exit-code proc)) nil (error 'hg-error :message (format nil "hg command failed: ~A" cmd)))))) 82 (defmethod vc-init ((self (eql :hg))) 83 (make-instance 'hg-repo :path (pathname *default-pathname-defaults*))) 85 ;; (defmethod vc-init ((self list)) 86 ;; (when-let ((form self)) 87 ;; (make-instance 'hg-repo 88 ;; :path (pathname (pop form)) 89 ;; :remotes (or (getf form :remotes) #())))) 91 (defmethod vc-init ((self hg-repo)) 92 (let ((path (vc-path self))) 93 (if (zerop (sb-ext:process-exit-code (run-hg-command "init" (list path)))) 95 (hg-error "hg init failed:" path)))) 97 (defmethod vc-clone ((self hg-repo) remote &key &allow-other-keys) 98 (with-slots (path) self 99 (sb-ext:process-exit-code (run-hg-command "clone" (list remote path))))) 101 (defmethod vc-pull ((self hg-repo) &optional (remote "default")) 102 (vc-run self "pull" remote)) 104 (defmethod vc-update ((self hg-repo) &optional branch) 105 (vc-run self "update" branch)) 107 (defmethod vc-push ((self hg-repo) &optional (remote "default")) 108 (vc-run self "push" remote)) 110 (defmethod vc-commit ((self hg-repo) msg &key &allow-other-keys) 111 (vc-run self "commit" "-m" msg)) 113 (defmethod vc-add ((self hg-repo) &rest files) 114 (vc-run self "add" files)) 116 (defmethod vc-remove ((self hg-repo) &rest files) 117 (vc-run self "remove" files)) 119 (defmethod vc-addremove ((self hg-repo) &rest files) 120 (vc-run self "addremove" files)) 122 (defmethod vc-status ((self hg-repo) &key &allow-other-keys) (vc-run self "status")) 124 (defmethod vc-branch ((self hg-repo)) (vc-run self "branch")) 126 (defmethod vc-diff ((a hg-repo) (b hg-repo) &key &allow-other-keys) 127 (vc-run a "diff" (vc-head a) (vc-head b))) 129 (defmethod vc-log ((self hg-repo)) 132 (defmethod vc-bundle ((self hg-repo) (output pathname) &key rev branch base type) 135 (appendf args `("--rev" ,rev))) 137 (appendf args `("--branch" ,branch))) 139 (appendf args `("--base" ,base))) 141 (appendf args `("--type" ,type))) 142 (unless (or rev branch) 144 (apply #'vc-run self (push "bundle" args)))) 146 (defmethod vc-unbundle ((self hg-repo) (input pathname) &key) 147 (vc-run self "unbundle" (namestring input))) 149 (defmethod vc-id ((self hg-repo)) 150 (uiop:with-current-directory ((vc-path self)) 151 (let ((proc (run-hg-command "id" nil :stream))) 152 (with-open-stream (s (sb-ext:process-output proc)) 153 (with-output-to-string (str) 154 (loop for c = (read-char s nil) 155 until (char= c #\space) 156 do (write-char c str)) 157 (if (eq 0 (sb-ext:process-exit-code proc)) 160 :message "hg command failed: id"))))))) 163 ;; ref: https://wiki.mercurial-scm.org/CommandServer 164 (declaim (inline %make-hg-client)) 165 (defstruct (hg-client (:constructor %make-hg-client)) 166 "hg-client structures contain the client connection state 167 machinery and a handle to the unix socket running Mercurial command 169 (pid 0 :type fixnum :read-only t) 170 (pgid 0 :type fixnum) 171 (cwd (sb-posix:getcwd) :type string) 172 (buffer (make-array *default-hg-client-buffer-size* :element-type 'unsigned-byte :adjustable nil)) 173 (socket nil :type (or local-socket null)) 174 (caps 0 :type fixnum)) 176 (defun make-hg-client (&optional bufsize) 178 :buffer (make-array (or bufsize *default-hg-client-buffer-size*) 179 :element-type 'unsigned-byte 183 ;; all communication with the mercurial cmdserver is done over a 184 ;; socket. byte order is big-endian. 186 ;; data from server is channel-based - (channel length pair sent 187 ;; before data) - 5 byte header total 189 ;; on init, the server will send hello message on channel #\o. the 190 ;; message is a signel chunk consisting of a #\Newline-separated list 191 ;; of lines of the form: 193 <field name>: <field data> 196 ;; fields include: capabilities, encoding, pid 204 (defmethod vc-init ((self hg-client)) 205 "Initialize the hg commandserver client. This method initializes the 206 appropriate process IDs and a socket for communicating with the 208 (with-slots (pid pgid socket caps) self 209 (format nil "pid: ~A, pgid: ~A, socket: ~A, caps: ~A" pid pgid socket caps))) 212 (defmethod vc-run ((self hg-client) cmd &rest args) 213 (declare (ignorable args))) 216 (defstruct hg-nodeid id) 218 (defstruct hg-revlog) 220 (defstruct hg-manifest) 222 (defstruct hg-changeset id) 226 ;; see also: https://wiki.mercurial-scm.org/DirstateFormatImprovementsPlan 230 <p1 binhash><p2 binhash> 231 <list of dirstate entries> 240 variable length entry (length given by the previous length field) with: 241 "<filename>" followed if it's a copy by: "\0<source if copy>" 244 (defstruct dirstate-entry status mode size mtime length filename) 246 ;; (defmethod read-dirstate-file ((self hg-repo))) 249 (entries (make-array 0 :element-type 'dirstate-entry :fill-pointer 0 :adjustable t) :type (vector dirstate-entry)))