;;; lisp/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) 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) 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! ci (&args _) "Commands that automate development processes." :partial t) ;; TODO Move to 'doom install --git-hooks' (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))))))) ;; TODO Move to 'doom lint commits' (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 Move to 'doom lint hook:commit-msg' (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)))))))) ;; TODO Move to 'doom lint hook:pre-push' (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 'doom-cli-ci) ;;; ci.el ends here