Coverage report: /home/ellis/comp/core/lib/vc/hg.lisp

Kind	Covered	All	%
expression	128	545	23.5
branch	7	32	21.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; Commentary:

2

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.

6

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.

12

13

;; HACK 2023-09-15: hgcmd interface, parsers, metadata object protocols

14

15

;; https://wiki.mercurial-scm.org/Design

16

17

;; https://wiki.mercurial-scm.org/CommandServer

18

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

27

;; protocol.

28

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:

31

32

;; hg serve --no-profile --cmdserver chgunix --address @INITSOCKNAME --daemon-postexec chdir:/ @DIR

33

34

;;; Code:

35

(in-package :vc/hg)

36

37

(deferror hg-error (vc-error) () (:auto t))

38

39

(defvar *default-hg-client-buffer-size* 4096)

40

(defvar *hg-program* (or (cli:find-exe "rhg") (cli:find-exe "hg")))

41

42

(defun run-hg-command (cmd &optional args (output t) (wait t))

43

"Run an hg command."

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))

47

48

(defun hg-url-p (url)

49

"Return nil if URL does not look like a URL to a hg valid remote."

50

(let ((url-str (if (typep url 'pathname)

51

(namestring url)

52

url)))

53

(ppcre:scan '(:alternation

54

(:regex "\\.hg$")

55

(:regex "^hg://")

56

(:regex "^https://hg\\.")

57

(:regex "^hg@"))

58

url-str)))

59

60

(defun hgignore (&optional (path ".hgignore"))

61

(vc/proto::make-vc-ignore :path path :patterns (vc/proto::map-lines #'ppcre:create-scanner path)))

62

63

;;; Bundles

64

(deftype hg-bundle-type () `(member :v1 :v2))

65

(deftype hg-compression-engine () `(member :bzip2 :gzip :zstd))

66

67

(defvar *hg-bundlespec-options*

68

'("changegroup" "cg.version" "obsolescence" "phases" "recbranchcache" "tagsfnodescache"))

69

70

;; https://hg.guido-berhoerster.org/projects/xwrited/help/bundlespec

71

(defun hg-bundlespec-string-p (str)

72

"A hg-bundlespec string has the following formats:

73

74

<type> : The literal bundle format string is used.

75

76

<compression>-<type> : The compression engine and format are delimited by a

77

hyphen (\"-\").

78

79

Optional parameters follow the \"<type>\". Parameters are URI escaped

80

\"key=value\" pairs. Each pair is delimited by a semicolon (\";\"). The first

81

parameter begins after a \";\" immediately following the \"<type>\" value."

82

(destructuring-bind (ct cv) (mapcar (lambda (x) (keywordicate (string-upcase x)))

83

(ssplit #\- (car (ssplit #\; str))))

84

(when (and (typep (keywordicate (string-upcase ct)) 'hg-compression-engine)

85

(typep (keywordicate (string-upcase cv)) 'hg-bundle-type))

86

(values ct cv))))

87

88

;;; Config

89

;; https://www.mercurial-scm.org/doc/hgrc.5.html

90

(config:defconfig hg-config (vc-config)

91

((paths :initarg :paths)

92

(ui :initarg :ui)))

93

94

(defmethod make-config ((self (eql :hg)) &key paths)

95

(declare (ignore self))

96

(make-instance 'hg-config :paths paths))

97

98

(defun parse-hg-uri (obj)

99

"Parse a URI which may be prefixed with '[stuff]' - the uri is returned as the

100

first value and 'stuff' as the second."

101

(etypecase obj

102

(uri (values obj :hg))

103

(pathname (values obj :hg))

104

(string

105

(if (char= (schar obj 0) #\[)

106

(let ((end (position #\] obj)))

107

            (values (uri (subseq obj (1+ end))) (keywordicate (string-upcase (subseq obj 1 end)))))

108

(values (uri obj) :hg)))))

109

110

(defun find-hgrc (&optional (root *default-pathname-defaults*) (load t))

111

(when-let ((config (probe-file (merge-pathnames ".hg/hgrc" root))))

112

(let ((cfg (deserialize config :toml)))

113

(if load

114

(let ((ret (make-config :hg)))

115

(dolist (c (unwrap cfg) ret)

116

(unless (null c)

117

(string-case ((car c))

118

("paths" (setf (slot-value ret 'paths) (cdr c)))

119

("ui" (setf (slot-value ret 'ui) (cdr c)))))))

120

cfg))))

121

122

(defun find-hg-bookmarks (&optional (root *default-pathname-defaults*))

123

(when-let ((bkm (probe-file (merge-pathnames ".hg/bookmarks" root))))

124

(mapcar (lambda (x) (nreverse (mapcar 'trim (ssplit #\space x)))) (lines (read-file bkm)))))

125

126

(defun find-hg-submodules (&optional (root *default-pathname-defaults*))

127

(when-let ((subs (probe-file (merge-pathnames ".hgsub" root))))

128

(mapcar (lambda (x) (mapcar 'trim (ssplit #\= x)))

129

(lines (read-file subs)))))

130

131

;;; Repo

132

;; (describe (make-instance 'hg-repo))

133

;; https://repo.mercurial-scm.org/hg/file/tip/mercurial/interfaces/repository.py

134

(defclass hg-repo (vc-repo)

135

((dirstate :accessor vc-dirstate) ;; working-directory

136

(bookmarks :accessor vc-bookmarks)

137

(requires :accessor vc-requires)))

138

139

(defmethod vc-init ((self (eql :hg)))

140

(make-instance 'hg-repo :path (pathname *default-pathname-defaults*)))

141

142

(defmethod vc-init ((self hg-repo))

143

(let ((path (path self)))

144

(if (zerop (sb-ext:process-exit-code (run-hg-command "init" (list path))))

145

path

146

(hg-error "hg init failed:" path))))

147

148

(defun make-hg-repo (path &key init (update '(:bookmarks :submodules :remotes)))

149

(flet ((set-requires (repo)

150

(setf (vc-requires repo)

151

(mapcar 'trim

152

(lines

153

(with-output-to-string (s)

154

(run-hg-command "debugrequires" nil s)

155

s)))))

156

157

(set-submodules (repo)

158

(setf (vc-submodules repo)

159

(mapcar

160

(lambda (x)

161

(let ((r (make-hg-repo

162

(probe-directory (merge-pathnames (car x) path))

163

:update update)))

164

(unless (find "default" (vc-remotes r) :key 'name :test 'string=)

165

                         (push (make-vc-remote :type :hg :name "default" :url (cdr x)) (vc-remotes r)))

166

r))

167

(find-hg-submodules path))))

168

(set-bookmarks (repo) (setf (vc-bookmarks repo) (find-hg-bookmarks path))))

169

(let ((repo (make-instance 'hg-repo :path path)))

170

(when init (vc-init repo))

171

(etypecase update

172

((eql t)

173

(set-requires repo)

174

(set-bookmarks repo)

175

(set-submodules repo))

176

(cons

177

(when (member :requires update) (set-requires repo))

178

(when (member :bookmarks update) (set-bookmarks repo))

179

(when (member :submodules update) (set-submodules repo))))

180

(when-let ((cfg (find-hgrc path)))

181

(setf (vc-config repo) cfg)

182

(when (or (eql update t) (member :remotes update))

183

(setf (vc-remotes repo)

184

(mapcar (lambda (x)

185

(multiple-value-bind (uri type) (parse-hg-uri (cdr x))

186

(make-vc-remote :type type :url uri :name (car x))))

187

(slot-value cfg 'paths)))))

188

repo)))

189

190

(defmethod vc-type ((self hg-repo)) :hg)

191

192

(defmethod vc-run ((self hg-repo) (cmd string) &rest args)

193

(with-directory (path self)

194

(current-directory)

195

(let ((proc (run-hg-command cmd args)))

196

       (if (eq 0 (sb-ext:process-exit-code proc)) nil (error 'hg-error :message (format nil "hg command failed: ~A" cmd))))))

197

198

;; NOTE 2025-06-29: this needs to be compatible with skel writers

199

;; (defmethod print-object ((self hg-repo) stream)

200

;; (print-unreadable-object (self stream)

201

;; (format stream "hg-repo")

202

;; (unless (zerop (length (vc-remotes self)))

203

;; (format stream " ")

204

;; (pprint-tabular stream (coerce (vc-remotes self) 'list) nil nil 2))))

205

206

;; (defmethod vc-init ((self list))

207

;; (when-let ((form self))

208

;; (make-instance 'hg-repo

209

;; :path (pathname (pop form))

210

;; :remotes (or (getf form :remotes) #()))))

211

212

(defmethod vc-clone ((self hg-repo) remote &key &allow-other-keys)

213

(with-slots (path) self

214

(sb-ext:process-exit-code (run-hg-command "clone" (list remote path)))))

215

216

(defmethod vc-pull ((self hg-repo) &optional (remote "default"))

217

(vc-run self "pull" remote))

218

219

(defmethod vc-update ((self hg-repo) &optional branch)

220

(vc-run self "update" branch))

221

222

(defmethod vc-push ((self hg-repo) &key (remote "default"))

223

(vc-run self "push" remote))

224

225

(defmethod vc-commit ((self hg-repo) msg &key &allow-other-keys)

226

(vc-run self "commit" "-m" msg))

227

228

(defmethod vc-add ((self hg-repo) &rest files)

229

(vc-run self "add" files))

230

231

(defmethod vc-remove ((self hg-repo) &rest files)

232

(vc-run self "remove" files))

233

234

(defmethod vc-addremove ((self hg-repo) &rest files)

235

(apply 'vc-run self "addremove" files))

236

237

(defmethod vc-status ((self hg-repo) &key &allow-other-keys) (vc-run self "status"))

238

239

(defmethod vc-branch ((self hg-repo)) (vc-run self "branch"))

240

241

(defmethod vc-diff ((a hg-repo) (b hg-repo) &key &allow-other-keys)

242

(vc-run a "diff" (vc-head a) (vc-head b)))

243

244

(defmethod vc-log ((self hg-repo))

245

(vc-run self "log"))

246

247

(defmethod vc-bundle ((self hg-repo) output &key rev branch base (type "zstd-v2"))

248

(let ((*default-pathname-defaults* (path self))

249

(args))

250

(when rev

251

(appendf args `("--rev" ,rev)))

252

(when branch

253

(appendf args `("--branch" ,branch)))

254

(when base

255

(appendf args `("--base" ,base)))

256

(when type

257

(appendf args `("--type" ,type)))

258

(unless (or rev branch)

259

(push "--all" args))

260

(apply #'vc-run self `("bundle" ,@args ,output))

261

output))

262

263

(defmethod vc-unbundle ((self hg-repo) (input pathname) &key)

264

(vc-run self "unbundle" (namestring input)))

265

266

(defmethod id ((self hg-repo))

267

(with-directory (path self)

268

(let ((proc (run-hg-command "id" nil :stream)))

269

(with-open-stream (s (sb-ext:process-output proc))

270

(with-output-to-string (str)

271

(loop for c = (read-char s nil)

272

until (char= c #\space)

273

do (write-char c str))

274

(if (eq 0 (sb-ext:process-exit-code proc))

275

str

276

(error 'hg-error

277

:message "hg command failed: id")))))))

278

279

(defvar *fast-export-directory* (merge-pathnames ".stash/fast-export/" (user-homedir-pathname)))

280

(defvar *hg-fast-export-script* (merge-pathnames "hg-fast-export.sh" *fast-export-directory*))

281

282

(defun hg-fast-export (repo &optional output filter-regexp)

283

"Call the hg-fast-export.sh script, converting a HG-REPO to a GIT-REPO which is

284

initialized at OUTPUT. Note that the repo will be 'bare' and not contain a

285

working directory.

286

287

FILTER-REGEXP is an optional field containing a regexp string which will be

288

used in the following call in the OUTPUT directory after init:

289

290

git filter-repo --invert-paths --path-regex FILTER-REGEXP --force"

291

(let* ((output (ensure-directories-exist

292

                   (or output (format nil "/tmp/~A" (car (last (pathname-directory (path repo))))))))

293

(out-repo (make-repo output :type :git :init t)))

294

(sb-ext:run-program "/bin/bash" (list

295

(namestring *hg-fast-export-script*)

296

                                      "-r" (namestring (path repo)) "-M" "default")

297

:output t

298

:directory (pathname output))

299

(when filter-regexp

300

(with-directory output

301

(run-git-command "filter-repo" `("--invert-paths" "--path-regex" ,filter-regexp "--force"))))

302

out-repo))

303

304

(defmethod vc-export ((self hg-repo) output &key filter-regexp)

305

(hg-fast-export self output filter-regexp))

306

307

;;; Client

308

;; ref: https://wiki.mercurial-scm.org/CommandServer

309

(declaim (inline %make-hg-client))

310

(defstruct (hg-client (:constructor %make-hg-client))

311

"hg-client structures contain the client connection state

312

machinery and a handle to the unix socket running Mercurial command

313

server."

314

(pid 0 :type fixnum :read-only t)

315

(pgid 0 :type fixnum)

316

(cwd (sb-posix:getcwd) :type string)

317

(buffer (make-array *default-hg-client-buffer-size* :element-type 'unsigned-byte :adjustable nil))

318

(socket nil :type (or local-socket null))

319

(caps 0 :type fixnum))

320

321

(defun make-hg-client (&optional bufsize)

322

(%make-hg-client

323

:buffer (make-array (or bufsize *default-hg-client-buffer-size*)

324

:element-type 'unsigned-byte

325

:adjustable nil)))

326

327

;;;; Client Protocol

328

;; all communication with the mercurial cmdserver is done over a

329

;; socket. byte order is big-endian.

330

331

;; data from server is channel-based - (channel length pair sent

332

;; before data) - 5 byte header total

333

334

;; on init, the server will send hello message on channel #\o. the

335

;; message is a signel chunk consisting of a #\Newline-separated list

336

;; of lines of the form:

337

#|

338

<field name>: <field data>

339

|#

340

341

;; fields include: capabilities, encoding, pid

342

343

#|

344

o

345

1234

346

<data: 1234 bytes>

347

|#

348

349

(defmethod vc-init ((self hg-client))

350

"Initialize the hg commandserver client. This method initializes the

351

appropriate process IDs and a socket for communicating with the

352

commandserver."

353

(with-slots (pid pgid socket caps) self

354

(format nil "pid: ~A, pgid: ~A, socket: ~A, caps: ~A" pid pgid socket caps)))

355

356

;; TODO 2023-12-29:

357

(defmethod vc-run ((self hg-client) cmd &rest args)

358

(declare (ignorable args)))

359

360

;;; Low-level

361

(defstruct hg-nodeid id)

362

363

(defstruct hg-revlog)

364

365

(defstruct hg-manifest)

366

367

(defstruct hg-changeset id)

368

369

;;;; Dirstate

370

371

;; see also: https://wiki.mercurial-scm.org/DirstateFormatImprovementsPlan

372

373

#|

374

.hg/dirstate:

375

<p1 binhash><p2 binhash>

376

<list of dirstate entries>

377

|#

378

379

#| entry

380

8bit: status

381

32bit: mode

382

32bit: size

383

32bit: mtime

384

32bit: length

385

variable length entry (length given by the previous length field) with:

386

"<filename>" followed if it's a copy by: "\0<source if copy>"

387

|#

388

389

(defstruct dirstate-entry status mode size mtime length filename)

390

391

;; (defmethod read-dirstate-file ((self hg-repo)))

392

393

(defstruct dirstate

394

   (entries (make-array 0 :element-type 'dirstate-entry :fill-pointer 0 :adjustable t) :type (vector dirstate-entry)))