23feb482e9
BREAKING CHANGE: This renames the fn! macro to lambda! and fn!! to fn!. I hadn't put much thought into their names when they were added, but now that they're seeing more use, I've reconsidered. The reasoning is (and I'll refer to them by their new names): - If you're using fn!, you care more about the syntax's brevity, than if you were using lambda!, so I wanted fn! to have the (even if slightly) shorter name. - lambda! decorates native lambda (with cl-function). Its old name did not suggest that connection like other !-macros in Doom's library do. - Their old names implied the two macros were somehow related or that one decorated the other. They aren't and don't.
471 lines
20 KiB
EmacsLisp
471 lines
20 KiB
EmacsLisp
;;; core/cli/ci.el -*- lexical-binding: t; -*-
|
|
|
|
;;
|
|
;;; Variables
|
|
|
|
(defvar doom-ci-commit-trailer-keys
|
|
'(("Fix" ref hash url)
|
|
("Ref" ref hash url)
|
|
("Close" ref)
|
|
("Revert" ref hash)
|
|
("Amend" ref hash)
|
|
("Co-authored-by" name)
|
|
("Signed-off-by" name))
|
|
"An alist of valid trailer keys and their accepted value types.
|
|
|
|
Accapted value types can be one or more of ref, hash, url, username, or name.")
|
|
|
|
(defvar doom-ci-commit-trailer-types
|
|
'((ref . "^\\(https?://[^ ]+\\|[^/]+/[^/]+\\)?#[0-9]+$")
|
|
(hash . "^\\(https?://[^ ]+\\|[^/]+/[^/]+@\\)?[a-z0-9]\\{12\\}$")
|
|
(url . "^https?://")
|
|
(name . "^[a-zA-Z0-9-_ \\.']+<[^@]+@[^.]+\\.[^>]+>$")
|
|
(username . "^@[^a-zA-Z0-9_-]+$"))
|
|
"An alist of valid trailer keys and their accepted value types.
|
|
|
|
Accapted value types can be one or more of ref, hash, url, username, or name.")
|
|
|
|
(defvar doom-ci-commit-types
|
|
'(bump dev docs feat fix merge nit perf refactor release revert test tweak)
|
|
"A list of valid commit types.")
|
|
|
|
(defvar doom-ci-commit-scopeless-types '(bump merge release revert)
|
|
"A list of commit types whose scopes should be passed in its BODY.
|
|
|
|
Don't: \"bump(SCOPE): ...\"
|
|
Do: \"bump: SCOPE\"")
|
|
|
|
(defvar doom-ci-commit-scopes '("ci" doom-ci-enforce-scopeless-types)
|
|
"A list of valid commit scopes as strings, predicate functions, or lists.
|
|
|
|
These are checked against each item in the comma-delimited scope field of the
|
|
current commit's message. E.g. 'fix(foo,bar,baz): ...' => foo, bar and baz
|
|
|
|
Each element of this list can be one of:
|
|
|
|
- A string, compared literally against the scope's name.
|
|
- A function predicate, taking two arguments (a scope as a symbol, and a plist
|
|
containing information about the current commit--see `doom-ci-commit-scopes'
|
|
for more about its structure). These predicates should:
|
|
- Return non-nil to immediately pass a scope.
|
|
- Throw a `user-error' to immediately fail the scope.
|
|
- Return nil to continue with the checks in this list.
|
|
- A list, denoting type-specific scopes. Its CAR is the type as a symbol, and
|
|
its CDR is a nested list of scopes as strings/predicates. E.g.
|
|
|
|
'(docs \"faq\" \"install\" check-docs)")
|
|
|
|
(defvar doom-ci-commit-rules
|
|
;; TODO Extract into named functions
|
|
(list (lambda! (&key subject)
|
|
"If a fixup/squash commit, don't lint this commit"
|
|
(when (string-match "^\\(\\(?:fixup\\|squash\\)!\\|FIXUP\\|WIP\\) " subject)
|
|
(skip! (format "Found %S commit, skipping commit" (match-string 1 subject)))))
|
|
|
|
(lambda! (&key type subject)
|
|
"Test SUBJECT length"
|
|
(let ((len (length subject)))
|
|
(cond ((memq type '(bump revert)))
|
|
((<= len 10)
|
|
(fail! "Subject is too short (<10) and should be more descriptive"))
|
|
((<= len 20)
|
|
(warn! "Subject is short (<20); are you sure it's descriptive enough?"))
|
|
((> len 72)
|
|
(fail! "Subject is %d characters, above the 72 maximum"
|
|
len))
|
|
((> len 50)
|
|
(warn! "Subject is %d characters; <=50 is ideal"
|
|
len)))))
|
|
|
|
(lambda! (&key type)
|
|
"Ensure commit has valid type"
|
|
(or (memq type doom-ci-commit-types)
|
|
(if type
|
|
(fail! "Invalid commit type: %s" type)
|
|
(fail! "Commit has no detectable type"))))
|
|
|
|
(lambda! (&key summary)
|
|
"Ensure commit has a summary"
|
|
(when (or (not (stringp summary))
|
|
(string-blank-p summary))
|
|
(fail! "Commit has no summary")))
|
|
|
|
(lambda! (&key type summary subject)
|
|
"Ensure summary isn't needlessly capitalized"
|
|
(and (stringp summary)
|
|
(string-match-p "^[A-Z][^-A-Z.]" summary)
|
|
(fail! "%S in summary should not be capitalized"
|
|
(car (split-string summary " ")))))
|
|
|
|
(lambda! (&rest plist &key type scopes)
|
|
"Ensure scopes are valid"
|
|
(dolist (scope scopes)
|
|
(condition-case e
|
|
(letf! (defun* check-rule (rule)
|
|
(or (and (stringp rule)
|
|
(string= rule scope))
|
|
(and (functionp rule)
|
|
(funcall rule scope plist))
|
|
(and (listp rule)
|
|
(eq type (car rule))
|
|
(seq-find #'check-rule (cdr rule)))))
|
|
(or (seq-find #'check-rule doom-ci-commit-scopes)
|
|
(fail! "Invalid scope: %s" scope)))
|
|
(user-error (fail! "%s" (error-message-string e))))))
|
|
|
|
(lambda! (&key scopes)
|
|
"Esnure scopes are sorted correctly"
|
|
(unless (equal scopes (sort (copy-sequence scopes) #'string-lessp))
|
|
(fail! "Scopes are not in lexicographical order")))
|
|
|
|
(lambda! (&key type body)
|
|
"Enforce 72 character line width for BODY"
|
|
(catch 'result
|
|
(with-temp-buffer
|
|
(save-excursion (insert body))
|
|
(while (re-search-forward "^[^\n]\\{73,\\}" nil t)
|
|
(save-excursion
|
|
(or
|
|
;; Long bump lines are acceptable
|
|
(let ((bump-re "\\(https?://.+\\|[^/]+\\)/[^/]+@[a-z0-9]\\{12\\}"))
|
|
(re-search-backward (format "^%s -> %s$" bump-re bump-re) nil t))
|
|
;; Long URLs are acceptable
|
|
(re-search-backward "https?://[^ ]+\\{73,\\}" nil t)
|
|
;; Lines that start with # or whitespace are comment or
|
|
;; code blocks.
|
|
(re-search-backward "^\\(?:#\\| +\\)" nil t)
|
|
(throw 'result (fail! "Line(s) in commit body exceed 72 characters"))))))))
|
|
|
|
(lambda! (&key bang body type)
|
|
"Ensure ! is accompanied by a 'BREAKING CHANGE:' in BODY"
|
|
(if bang
|
|
(cond ((not (string-match-p "^BREAKING CHANGE:" body))
|
|
(fail! "'!' present in commit type, but missing 'BREAKING CHANGE:' in body"))
|
|
((not (string-match-p "^BREAKING CHANGE: .+" body))
|
|
(fail! "'BREAKING CHANGE:' present in commit body, but missing explanation")))
|
|
(when (string-match-p "^BREAKING CHANGE:" body)
|
|
(fail! "'BREAKING CHANGE:' present in body, but missing '!' after %S"
|
|
type))))
|
|
|
|
(lambda! (&key type body)
|
|
"Ensure bump commits have package ref lines"
|
|
(and (eq type 'bump)
|
|
(let ((bump-re "\\(?:https?://.+\\|[^/]+\\)/[^/]+@\\([a-z0-9]+\\)"))
|
|
(not (string-match-p (concat "^" bump-re " -> " bump-re "$")
|
|
body)))
|
|
(fail! "Bump commit is missing commit hash diffs")))
|
|
|
|
(lambda! (&key body)
|
|
"Ensure commit hashes in bump lines are 12 characters long"
|
|
(with-temp-buffer
|
|
(insert body)
|
|
(let ((bump-re "\\<\\(?:https?://[^@]+\\|[^/]+\\)/[^/]+@\\([a-z0-9]+\\)")
|
|
refs)
|
|
(while (re-search-backward bump-re nil t)
|
|
(when (/= (length (match-string 1)) 12)
|
|
(push (match-string 0) refs)))
|
|
(when refs
|
|
(fail! "%d commit hash(s) not 12 characters long: %s"
|
|
(length refs) (string-join (nreverse refs) ", "))))))
|
|
|
|
;; TODO Add bump validations for revert: type.
|
|
(lambda! (&key body trailers)
|
|
"Validate commit trailers."
|
|
(let* ((keys (mapcar #'car doom-ci-commit-trailer-keys))
|
|
(key-re (regexp-opt keys t))
|
|
(lines
|
|
;; Scan BODY because invalid trailers won't be in TRAILERS.
|
|
(save-match-data
|
|
(and (string-match "\n\\(\n[a-zA-Z][a-zA-Z-]*:? [^ ][^\n]+\\)+\n+\\'" body)
|
|
(split-string (match-string 0 body) "\n" t)))))
|
|
(dolist (line lines)
|
|
(unless (string-match-p (concat "^" key-re ":? [^ ]") line)
|
|
(fail! "Found %S, expected one of: %s"
|
|
(truncate-string-to-width (string-trim line) 16 nil nil "…")
|
|
(string-join keys ", ")))
|
|
(when (and (string-match "^[^a-zA-Z-]+:? \\(.+\\)$" line)
|
|
(string-match-p " " (match-string 1 line)))
|
|
(fail! "%S has multiple references, but should only have one per line"
|
|
(truncate-string-to-width (string-trim line) 20 nil nil "…")))
|
|
(when (or (string-match (concat "^" key-re "\\(?:e?[sd]\\|ing\\)? [^ ]") line)
|
|
(string-match (concat "^\\([a-zA-Z-]+\\) [^ \n]+$") line))
|
|
(fail! "%S missing colon after %S"
|
|
(truncate-string-to-width (string-trim line) 16 nil nil "…")
|
|
(match-string 1 line))))
|
|
(pcase-dolist (`(,key . ,value) trailers)
|
|
(if (and (not (memq 'name (cdr (assoc key doom-ci-commit-trailer-keys))))
|
|
(string-match-p " " value))
|
|
(fail! "Found %S, but only one value allowed per trailer"
|
|
(truncate-string-to-width (concat key ": " value) 20 nil nil "…"))
|
|
(when-let (allowed-types (cdr (assoc key doom-ci-commit-trailer-keys)))
|
|
(or (cl-loop for type in allowed-types
|
|
if (cdr (assq type doom-ci-commit-trailer-types))
|
|
if (string-match-p it value)
|
|
return t)
|
|
(fail! "%S expects one of %s, but got %S"
|
|
key allowed-types value)))))))
|
|
|
|
;; TODO Check that bump/revert SUBJECT list: 1) valid modules and 2)
|
|
;; modules whose files are actually being touched.
|
|
|
|
;; TODO Ensure your diff corraborates your SCOPE
|
|
|
|
)
|
|
"A list of validator functions to run against a commit.
|
|
|
|
Each function is N-arity and is passed a plist with the following keys:
|
|
|
|
:bang
|
|
(Boolean) If `t', the commit is declared to contain a breaking change.
|
|
e.g. 'refactor!: this commit breaks everything'
|
|
:body
|
|
(String) Contains the whole BODY of a commit message, excluding the
|
|
TRAILERS.
|
|
:scopes
|
|
(List<Symbol>) Contains a list of scopes, as symbols. e.g. with
|
|
'feat(org,lsp): so on and so forth', this contains '(org lsp).
|
|
:subject
|
|
(String) Contains the whole first line of a commit message.
|
|
:summary
|
|
(String) Contains the summary following the type and scopes. e.g. In
|
|
'feat(org): fix X, Y, and Z' the summary is 'fix X, Y, and Z.
|
|
:trailers
|
|
(Map<String, String>) Contains an alist of 'KEY: VALUE' trailers, i.e. All
|
|
Fix, Ref, Close, Revert, etc lines with a valid value. This will be empty if
|
|
the formatting of a commit's trailers is invalid.
|
|
:type
|
|
(Symbol) The type of commit this is. E.g. `feat', `fix', `bump', etc.
|
|
|
|
Each function should call `fail!' or `warn!' one or more times, or `skip!'
|
|
(immediately returns). Each of these lexical functions take the same arguments
|
|
as `format'.
|
|
|
|
Note: warnings are not considered failures.")
|
|
|
|
|
|
;;
|
|
;;; Commands
|
|
|
|
;;; doom ci
|
|
(defcli! (:before ci) (&args _)
|
|
(when-let*
|
|
((repo-root
|
|
(if-let* ((result (sh! "git" "rev-parse" "--show-toplevel"))
|
|
((zerop (car result))))
|
|
(cdr result)
|
|
default-directory))
|
|
(local-config
|
|
(car (or (doom-glob repo-root "ci.el")
|
|
(doom-glob doom-private-dir "ci.el")))))
|
|
(load local-config nil t t)
|
|
(print! (item "Loaded %S") local-config)))
|
|
|
|
(defcli! ci ()
|
|
"Commands that automate development processes."
|
|
:partial t)
|
|
|
|
(defcli! (ci deploy-hooks) ((force ("--force")))
|
|
"TODO"
|
|
(let* ((repo-path (sh! "git" "rev-parse" "--show-toplevel"))
|
|
(repo-path (if (zerop (car repo-path))
|
|
(cdr repo-path)
|
|
(user-error "Cannot locate a git repo in %s"
|
|
(file-relative-name default-directory))))
|
|
(submodule-p (string-empty-p (cdr (sh! "git" "rev-parse" "show-superproject-working-tree"))))
|
|
(config-hooks-path (cdr (sh! "git" "config" "core.hooksPath")))
|
|
(hooks-path (cdr (sh! "git" "rev-parse" "--git-path" "hooks"))))
|
|
(unless (string-empty-p config-hooks-path)
|
|
(or force
|
|
(y-or-n-p
|
|
(format (concat "Detected non-standard core.hookPath: %S\n\n"
|
|
"Install Doom's commit-msg and pre-push git hooks anyway?")
|
|
hooks-path))
|
|
(user-error "Aborted")))
|
|
(make-directory hooks-path 'parents)
|
|
(print-group!
|
|
(dolist (hook '("commit-msg" "pre-push"))
|
|
(let* ((hook (doom-path hooks-path hook))
|
|
(overwrite-p (file-exists-p hook)))
|
|
(with-temp-file hook
|
|
(insert "#!/usr/bin/env sh\n"
|
|
(doom-path doom-emacs-dir "bin/doom")
|
|
" --no-color ci hook " (file-name-base hook)
|
|
" \"$@\""))
|
|
(set-file-modes hook #o700)
|
|
(print! (success "%s %s")
|
|
(if overwrite-p "Overwrote" "Created")
|
|
(path hook)))))))
|
|
|
|
(defcli! (ci lint-commits) (from &optional to)
|
|
"TODO"
|
|
(with-temp-buffer
|
|
(insert
|
|
(cdr (doom-call-process
|
|
"git" "log"
|
|
(format "%s...%s" from (or to (concat from "~1"))))))
|
|
(doom-ci--lint
|
|
(let (commits)
|
|
(while (re-search-backward "^commit \\([a-z0-9]\\{40\\}\\)" nil t)
|
|
(push (cons (match-string 1)
|
|
(replace-regexp-in-string
|
|
"^ " ""
|
|
(save-excursion
|
|
(buffer-substring-no-properties
|
|
(search-forward "\n\n")
|
|
(if (re-search-forward "\ncommit \\([a-z0-9]\\{40\\}\\)" nil t)
|
|
(match-beginning 0)
|
|
(point-max))))))
|
|
commits))
|
|
commits))))
|
|
|
|
;;; TODO
|
|
(defcli! (ci run-tests) (&rest targets) :stub t)
|
|
|
|
;;; doom ci hook
|
|
(defcli! (ci hook commit-msg) (file)
|
|
"Run git commit-msg hook.
|
|
|
|
Lints the current commit message."
|
|
(with-temp-buffer
|
|
(insert-file-contents file)
|
|
(doom-ci--lint
|
|
`(("CURRENT" .
|
|
,(buffer-substring
|
|
(point-min)
|
|
(if (re-search-forward "^# Please enter the commit message" nil t)
|
|
(match-beginning 0)
|
|
(point-max))))))))
|
|
|
|
(defcli! (ci hook pre-push) (remote url)
|
|
"Run git pre-push hook.
|
|
|
|
Prevents pushing if there are unrebased or WIP commits."
|
|
(with-temp-buffer
|
|
(let ((z40 (make-string 40 ?0))
|
|
line error)
|
|
(while (setq line (ignore-errors (read-from-minibuffer "")))
|
|
(catch 'continue
|
|
(seq-let (local-ref local-sha remote-ref remote-sha)
|
|
(split-string line " ")
|
|
;; TODO Extract this branch detection to a variable
|
|
(unless (or (string-match-p "^refs/heads/\\(master\\|main\\)$" remote-ref)
|
|
(equal local-sha z40))
|
|
(throw 'continue t))
|
|
(print-group!
|
|
(mapc (lambda (commit)
|
|
(seq-let (hash msg) (split-string commit "\t")
|
|
(setq error t)
|
|
(print! (item "%S commit in %s"
|
|
(car (split-string msg " "))
|
|
(substring hash 0 12)))))
|
|
(split-string
|
|
(cdr (doom-call-process
|
|
"git" "rev-list"
|
|
"--grep" (concat "^" (regexp-opt '("WIP" "squash!" "fixup!" "FIXUP") t) " ")
|
|
"--format=%H\t%s"
|
|
(if (equal remote-sha z40)
|
|
local-sha
|
|
(format "%s..%s" remote-sha local-sha))))
|
|
"\n" t))
|
|
(when error
|
|
(print! (error "Aborting push due to unrebased WIP, squash!, or fixup! commits"))
|
|
(exit! 1)))))))))
|
|
|
|
|
|
;;
|
|
;;; Helpers
|
|
|
|
(cl-defun doom-ci-enforce-scopeless-types (scope (&key type scopes summary &allow-other-keys))
|
|
"Complain about scoped commit types that shouldn't be scoped."
|
|
(when (memq type doom-ci-commit-scopeless-types)
|
|
(user-error "Scopes for %s commits should go after the colon, not before"
|
|
type)))
|
|
|
|
|
|
(defun doom-ci--parse-commit (commit-msg)
|
|
(with-temp-buffer
|
|
(save-excursion (insert commit-msg))
|
|
(append
|
|
(let ((end
|
|
(save-excursion
|
|
(if (re-search-forward "\n\\(\n[a-zA-Z-]+: [^ ][^\n]+\\)+\n*\\'" nil t)
|
|
(1+ (match-beginning 0))
|
|
(point-max)))))
|
|
`(:subject ,(buffer-substring (point-min) (line-end-position))
|
|
:body ,(string-trim-right (buffer-substring (line-beginning-position 3) end))
|
|
:trailers ,(save-match-data
|
|
(cl-loop with footer = (buffer-substring end (point-max))
|
|
for line in (split-string footer "\n" t)
|
|
if (string-match "^\\([a-zA-Z-]+\\): \\(.+\\)$" line)
|
|
collect (cons (match-string 1 line) (match-string 2 line))))))
|
|
(save-match-data
|
|
(when (looking-at "^\\([a-zA-Z0-9_-]+\\)\\(!?\\)\\(?:(\\([^)]+\\))\\)?: \\([^\n]+\\)")
|
|
`(:type ,(intern (match-string 1))
|
|
:bang ,(equal (match-string 2) "!")
|
|
:summary ,(match-string 4)
|
|
:scopes ,(ignore-errors (split-string (match-string 3) ",")))))
|
|
(save-excursion
|
|
(let ((bump-re "\\(\\(?:https?://.+\\|[^/ \n]+\\)/[^/ \n]+@[a-z0-9]\\{12\\}\\)")
|
|
bumps)
|
|
(while (re-search-forward (format "^\\s-*\\<%s -> %s\\>" bump-re bump-re) nil t)
|
|
(cond ((rassoc (match-string 1) bumps)
|
|
(setcdr (rassoc (match-string 1) bumps) (match-string 2)))
|
|
((assoc (match-string 2) bumps)
|
|
(setcar (assoc (match-string 2) bumps) (match-string 1)))
|
|
((setf (alist-get (match-string 1) bumps nil nil #'equal)
|
|
(match-string 2)))))
|
|
`(:bumps ,(cl-sort (delete-dups bumps) #'string-lessp :key #'car)))))))
|
|
|
|
(defun doom-ci--parse-bumps (from end)
|
|
(with-temp-buffer
|
|
(save-excursion
|
|
(insert
|
|
(cdr (doom-call-process "git" "log" "--format=full" "--grep=\\(bump\\|revert\\):"
|
|
(format "%s...%s" from end)))))
|
|
(save-match-data
|
|
(let (packages)
|
|
(while (let ((bump-re "\\(\\(?:https?://.+\\|[^/ ]+\\)/[^/ ]+@[a-z0-9]\\{12\\}\\)"))
|
|
(re-search-forward (format "^\\s-*\\<%s -> %s\\>" bump-re bump-re) nil t))
|
|
(cond ((rassoc (match-string 1) packages)
|
|
(setcdr (rassoc (match-string 1) packages) (match-string 2)))
|
|
((assoc (match-string 2) packages)
|
|
(setcar (assoc (match-string 2) packages) (match-string 1)))
|
|
((setf (alist-get (match-string 1) packages nil nil #'equal)
|
|
(match-string 2)))))
|
|
(cl-sort (delete-dups packages) #'string-lessp :key #'car)))))
|
|
|
|
(defun doom-ci--lint (commits)
|
|
(let ((warnings 0)
|
|
(failures 0))
|
|
(print! (start "Linting %d commits" (length commits)))
|
|
(print-group!
|
|
(pcase-dolist (`(,ref . ,commitmsg) commits)
|
|
(let* ((commit (doom-ci--parse-commit commitmsg))
|
|
(shortref (substring ref 0 7))
|
|
(subject (plist-get commit :subject)))
|
|
(cl-block 'linter
|
|
(letf! ((defun skip! (reason &rest args)
|
|
(print! (warn "Skipped because: %s") (apply #'format reason args))
|
|
(cl-return-from 'linter))
|
|
(defun warn! (reason &rest args)
|
|
(cl-incf warnings)
|
|
(print! (warn "%s") (apply #'format reason args)))
|
|
(defun fail! (reason &rest args)
|
|
(cl-incf failures)
|
|
(print! (error "%s") (apply #'format reason args))))
|
|
(print! (start "%s %s") shortref subject)
|
|
(print-group!
|
|
(mapc (doom-rpartial #'apply commit)
|
|
doom-ci-commit-rules)))))))
|
|
(let ((issues (+ warnings failures)))
|
|
(if (= issues 0)
|
|
(print! (success "There were no issues!"))
|
|
(if (> warnings 0) (print! (warn "Warnings: %d" warnings)))
|
|
(if (> failures 0) (print! (warn "Failures: %d" failures)))
|
|
(print! "\nSee https://discourse.doomemacs.org/git-conventions")
|
|
(unless (zerop failures)
|
|
(exit! 1)))
|
|
t)))
|
|
|
|
(provide 'core-cli-ci)
|
|
;;; ci.el ends here
|