gnuboot/scripts/checkpatch.scm

623 lines
22 KiB
Scheme
Executable File

#!/usr/bin/env -S guix repl --
!#
;; Copyright (C) 2024 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;
;; 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/>.
(use-modules (ice-9 rdelim))
(use-modules (ice-9 regex))
(use-modules (srfi srfi-1))
(use-modules (srfi srfi-9))
(use-modules (srfi srfi-19))
(define (startswith str value)
(if (> (string-length str) (string-length value))
(string=? (substring str 0 (string-length value)) value) #f))
(define (read-file path func)
(define results #f)
(let ((port (open-input-file path)))
(set! results (func path port))
(close-port port)
results))
(define (print-patch-name path)
(define dashes
(string-append
(string-join (make-list (string-length path) "-") "")
"\n"))
(display dashes)
(display (string-append path "\n"))
(display dashes))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;; ;; Patch parsing logic ;; ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-record-type <rule>
(make-rule name default line-match line end)
rule?
(name rule-name) ;; Name of the rule
(default rule-default) ;; Runs once at the beginning, inconditionally
(line-match rule-line-match) ;; Runs each line, returns true/false
(line rule-line) ;; Runs if rule-line-match is true
(end rule-end)) ;; Runs once at the end, inconditionally
(define parse-rules
(list
;; Here's an example of a parse rule below. Since it runs each time it is
;; also tested. TODO: A a proper unit testing environment needs to
;; be added and then this could be moved to only run inside that
;; separate testing environment.
(make-rule
"Example empty rule"
(lambda (results) results)
(lambda (line _ results) #t)
(lambda (line _ results) results)
(lambda (path _ results) results))
(make-rule
"Count lines"
(lambda (results) (acons 'line 0 results))
(lambda (line _ results) #t)
(lambda (line _ results)
(acons 'line (+ 1 (assq-ref results 'line)) results))
(lambda (path _ results) results))
(make-rule
"Find diff start"
(lambda (results) results)
(lambda (line _ results)
(startswith line "diff --git "))
(lambda (line _ results)
(acons 'diff-start
(assq-ref results
'line) results))
(lambda (path _ results)
results))
(make-rule
"Retrieve Signed-off-by"
(lambda (results) (acons 'signed-off-by '() results))
(lambda (line _ results) (startswith line "Signed-off-by: "))
(lambda (line _ results)
(let ((signed-off-by
(string-join (cdr (string-split line #\ )) " ")))
(acons 'signed-off-by
(append (assq-ref results 'signed-off-by) (list signed-off-by))
results)))
(lambda (path _ results) results))
;; TODO: Raise an exception if there is no lines with From:, and
;; when handling it, complain that the file is not a valid git
;; patch.
(make-rule
"Find commit author"
(lambda (results) results)
(lambda (line _ results) (startswith line "From: "))
(lambda (line _ results)
(let ((commit-author (string-join (cdr (string-split line #\ )) " ")))
(acons
'commit-author
commit-author
results)))
(lambda (path _ results) results))
(make-rule
"Find commit hash"
(lambda (results) results)
(lambda (line _ results)
;; Example:
;; From 0df4fe5fadfb7f51c1c34dad10ca9e6e04c3fa18 Mon Sep 17 00:00:00 2001
(and (not (startswith line "From: "))
(startswith line "From ")))
(lambda (line _ results)
(let ((commit-hash (list-ref (string-split line #\ ) 1)))
(acons 'commit-hash commit-hash results)))
(lambda (path _ results) results))
;; TODO: Raise an exception if there is no lines with Date:, and
;; when handling it, complain that the file is not a valid git
;; patch.
(make-rule
"Find commit date"
(lambda (results) results)
(lambda (line _ results) (startswith line "Date: "))
(lambda (line _ results)
(acons 'commit-date
(string->date
(string-join (cdr (string-split line #\ )) " ")
"~a, ~d ~b ~Y ~H:~M:~S ~z")
results))
(lambda (path _ results) results))
;; TODO:
;; - In general we might want to have the commit summary instead of
;; the subject, but for now we will use the mail subject instead
;; as we don't use the summary yet and properly parsing the
;; subject would require to reimplement the cleanup_subject
;; function from mailinfo.c in git source code.
;; - Raise an exception if there is no lines with From:, and when
;; handling it, complain that the file is not a valid git patch.
(make-rule
"Find patch subject"
(lambda (results) results)
(lambda (line _ results) (startswith line "Subject: "))
(lambda (line _ results)
(let ((commit-subject (string-join (cdr (string-split line #\ )) " ")))
(acons
'commit-subject-line
(assq-ref results 'line)
(acons
'commit-subject
commit-subject
results))))
(lambda (path _ results) results))
(make-rule
"Find commit subject and message separator"
(lambda (results) results)
(lambda (line _ results)
;; TODO: Raise an exception if the line after the commit subject
;; line is not empty, and when handling it, complain that the
;; file is not a valid git patch.
(and
(not (assq-ref results 'commit-message-end-line))
(assq-ref results 'commit-subject)
(string=? line "")
(eq? (+ 1 (assq-ref results 'commit-subject-line))
(assq-ref results 'line))))
(lambda (line _ results)
(acons
'commit-subject-message-separator-line
(assq-ref results 'line)
results))
(lambda (path _ results) results))
;; TODO: Raise an exception if there is more than two lines with
;; ---, and when handling it, complain that the file is not a valid
;; git patch.
(make-rule
"Find changelog end"
(lambda (results) results)
(lambda (line _ results)
(and
(assq-ref results 'commit-message-end-line)
(string=? line "---")))
(lambda (line _ results)
(acons 'changelog-end-line (assq-ref results 'line) results))
(lambda (path _ results) results))
;; TODO: Raise an exception if there is no line with ---, and when
;; handling it, complain that the file is not a valid git patch.
(make-rule
"Find commit message end"
(lambda (results) results)
(lambda (line _ results)
;; This matches the first "---" but there could be more as shown
;; in the example below:
;; ---
;; ChangeLog: [...]
;; ---
;; So until found we are in the commit message, but after it is found
;; we could also be in the ChangeLog.
(and (string=? line "---")
(not (assq-ref results 'commit-message-end-line))))
(lambda (line _ results)
(acons 'commit-message-end-line (assq-ref results 'line) results))
(lambda (path _ results) results))
(make-rule
"Find the end of the commit"
(lambda (results) results)
(lambda (line _ results) #f)
(lambda (line _ results) results)
(lambda (path _ results)
(acons 'commit-end-line
(if (assq-ref results 'changelog-end-line)
(assq-ref results 'changelog-end-line)
(assq-ref results 'commit-message-end-line))
results)))
(make-rule
"Find commit message"
(lambda (results) results)
(lambda (line _ results)
(and
(not (assq-ref results 'commit-message-end-line))
(assq-ref results 'commit-subject-message-separator-line)
(> (assq-ref results 'line)
(assq-ref results 'commit-subject-message-separator-line))))
(lambda (line _ results)
(let ((commit-message
(if (not (assq-ref results 'commit-message))
(list)
(append (assq-ref results 'commit-message) (list line)))))
(acons
'commit-message
commit-message
results)))
(lambda (path _ results) results))
(make-rule
"Find added files"
(lambda (results)
(acons 'added-files
'() results))
(lambda (line _ results)
(and (startswith line " create mode ")))
(lambda (line _ results)
(define line-parts
(string-split line #\space))
(define added-file
'())
(if (> (length line-parts) 3)
(set! added-file
(list (list-ref line-parts 4))))
(acons 'added-files
(append (assq-ref results 'added-files) added-file)
results))
(lambda (path _ results)
results))
(make-rule
"Find deleted files"
(lambda (results)
(acons 'deleted-files
'() results))
(lambda (line _ results)
(and (startswith line " delete mode ")))
(lambda (line _ results)
(define line-parts
(string-split line #\space))
(define deleted-file
'())
(if (> (length line-parts) 3)
(set! deleted-file
(list (list-ref line-parts 4))))
(acons 'deleted-files
(append (assq-ref results 'deleted-files) deleted-file)
results))
(lambda (path _ results)
results))
(make-rule
"Find modified files and track current file diff"
(lambda (results)
(acons 'current-diff-file #f
(acons 'modified-files '() results)))
(lambda (line _ results)
(startswith line "diff --git a/"))
(lambda (line _ results)
(define line-parts
(string-split line #\space))
(define current-diff-file
#f)
(define modified-file
'())
(if (> (length line-parts) 3)
;; Example: b/www/x60t_unbrick/0009.JPG
(let* ((part3 (list-ref line-parts 3))
;; remove the b/
(path (substring part3 2
(string-length part3))))
(set! current-diff-file path)
(if (not (or (any (lambda (added-file-path)
(string=? added-file-path path))
(assq-ref results 'added-files))
(any (lambda (deleted-file-path)
(string=? deleted-file-path
path))
(assq-ref results 'deleted-files))))
(set! modified-file
(list path)))))
(acons 'modified-files
(append (assq-ref results 'modified-files) modified-file)
(acons 'current-diff-file current-diff-file
results)))
(lambda (path _ results)
results))
(make-rule
"Track diff"
(lambda (results) results)
(lambda (line _ results) #t)
(lambda (line _ results)
(define diff-start
0)
(define diff-end
0)
(if (and (assq-ref results
'current-diff-file)
(startswith line "@@"))
(set! diff-start
(assq-ref results
'line)))
(if (startswith line "diff --git a/")
(set! diff-end
(assq-ref results
'line)))
(if (and (not (eq? diff-start 0))
(not (eq? diff-end 0)))
(acons 'diff-end diff-end
(acons 'diff-start diff-start results))
(if (not (eq? diff-start 0))
(acons 'diff-start diff-start results)
(acons 'diff-end diff-end results))))
(lambda (path _ results) results))
(make-rule
"Check for copyrights inside the patch"
(lambda (results)
(acons 'diff-path-added-proper-copyright
'() results))
(lambda (line _ results)
(and (startswith line "+")
(assq-ref results
'current-diff-file)
(> (assq-ref results
'diff-start) 0)))
(lambda (line _ results)
(let ((diff-start (assq-ref results
'diff-start))
(diff-end (assq-ref results
'diff-end))
(current-diff-file (assq-ref results
'current-diff-file))
(commit-author (assq-ref results
'commit-author))
(commit-year (date-year (assq-ref results
'commit-date))))
;; Example: Copyright (C) 2024 Some Name <mail@domain.org>
(if
(string-match
(string-append
"Copyright[ ]\\(C\\)[ ]" ;"Copyright (C) "
".*" ;We can have multiple years
(number->string commit-year 10) ;Year
".*" ;We can have multiple years
" " ;We have at least 1 space before the author line
commit-author) line)
(acons 'diff-path-added-proper-copyright
(append (assq-ref results
'diff-path-added-proper-copyright)
(list current-diff-file)) results)
results)))
(lambda (path _ results) results))
;; We can also use rules for debugging the code, here are two
;; examples below.
;; (make-rule
;; "Debug: print lines."
;; (lambda (results) results)
;; (lambda (line _ results) #t)
;; (lambda (line _ results)
;; (display "Count lines: line #")
;; (display (+ 1 (assq-ref results 'line)))
;; (display (string-append ": " line "\n"))
;; results)
;; (lambda (path _ results) results))
;; (make-rule
;; "Debug: print results."
;; (lambda (results) results)
;; (lambda (line _ results) #f)
;; (lambda (line _ results) results)
;; (lambda (path _ results)
;; (pk results)
;; results))
))
(define (set-defaults rules results)
(for-each
(lambda (rule)
(set! results ((rule-default rule) results)))
rules)
results)
(define (run-line-match-rules port rules parse-results results)
(define line (read-line port))
(if (eof-object? line)
results
((lambda _
(for-each
(lambda (rule)
(if ((rule-line-match rule) line parse-results results)
(set! results ((rule-line rule) line parse-results results))))
rules)
(run-line-match-rules port rules parse-results results)))))
(define (run-end-rules path rules other-results results)
(for-each
(lambda (rule)
(set! results ((rule-end rule) path other-results results)))
rules)
results)
(define (run-parse-rules rules path)
(read-file
path
(lambda (path port)
(let* ((defaults (set-defaults rules '()))
(results (run-line-match-rules port rules #f defaults)))
(run-end-rules path rules #f results)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; ;;;;;;;;;;;; ;;
;; ;; Checks ;; ;;
;; ;;;;;;;;;;;; ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (run-check-rules parse-results rules path)
(read-file
path
(lambda (path port)
(let* ((defaults (set-defaults rules '()))
(check-results
(run-line-match-rules port rules parse-results defaults)))
(run-end-rules path rules parse-results check-results)))))
(define check-rules
(list
;; Here's an example of a check rule below. Since it runs each time it is
;; also tested. TODO: A a proper unit testing environment needs to
;; be added and then this could be moved to only run inside that
;; separate testing environment.
(make-rule
"Example empty rule"
(lambda (check-results) check-results)
(lambda (line parse-results check-results) #t)
(lambda (line parse-results check-results) check-results)
(lambda (path parse-results check-results) check-results))
(make-rule
"Count lines"
(lambda (check-results) (acons 'line 0 check-results))
(lambda (line parse-results check-results) #t)
(lambda (line parse-results check-results)
(acons 'line (+ 1 (assq-ref check-results 'line)) check-results))
(lambda (path parse-results check-results) check-results))
;; Workarround for the bug #66268
;; [1]https://debbugs.gnu.org/cgi/bugreport.cgi?bug=66268
(make-rule
"Enforce commit size < 4KB"
(lambda (check-results)
(acons 'commit-size 0 check-results))
(lambda (line parse-results check-results)
(< (assq-ref check-results 'line)
(assq-ref parse-results 'commit-end-line)))
(lambda (line parse-results check-results)
(acons 'commit-size
(+
1 ;; for the \n
(string-length line)
(assq-ref check-results 'commit-size))
check-results))
(lambda (path parse-results check-results)
;; We're not sure of the exact size limit so let's use 2500
;; instead of 4096, since we're not counting signatures etc
(let ((limit 2500)
(commit-size (assq-ref check-results 'commit-size)))
(if (>= commit-size limit)
((lambda _
(display
(string-append
"ERROR: Commit size is " (number->string commit-size) " B"
" which is over the " (number->string limit) " B limit\n\n"))
(acons
'errors
(+ 1 (assq-ref check-results 'errors)) check-results)))
check-results))))
(make-rule
"Check for Signed-off-by"
(lambda (check-results) check-results)
(lambda (line parse-results check-results) #t)
(lambda (line parse-results check-results) check-results)
(lambda (path parse-results check-results)
(let ((author (assq-ref parse-results 'commit-author)))
(if (not (any (lambda (elm)
(string=? author elm))
(assq-ref parse-results 'signed-off-by)))
((lambda _
(display
(string-append "ERROR: Missing Signed-off-by: " author "\n\n"))
(acons
'errors
(+ 1 (assq-ref check-results 'errors)) check-results)))
check-results))))
(make-rule
"Track total errors and warnings"
(lambda (check-results) (acons 'warnings 0 (acons 'errors 0 check-results)))
(lambda (line parse-results check-results) #t)
(lambda (line parse-results check-results) check-results)
(lambda (path parse-results check-results)
(let* ((nr-lines (number->string (assq-ref parse-results 'line) 10))
(errors (assq-ref check-results 'errors))
(warnings (assq-ref check-results 'warnings))
(error-text
(string-append (number->string errors 10)
(if (> errors 1) " errors, " " error, ")))
(warning-text
(string-append (number->string warnings 10)
(if (> warnings 1) " warnings, " " warning, "))))
(display
(string-append
"total: " error-text warning-text nr-lines " lines checked\n\n"))
(if (or (> errors 0) (> warnings 0))
((lambda _
(display
(string-append path " has style problems, please review.\n"))
(display
(string-append
"NOTE: If any of the errors are false positives, "
"please report them to the GNU Boot maintainers.\n"))))
(display
(string-append
path
" has no obvious style problems "
"and is ready for submission.\n"))))
check-results))))
(define (test-patch path)
(let* ((parse-results (run-parse-rules parse-rules path))
(check-results (run-check-rules parse-results check-rules path)))
parse-results))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;; ;; Command line parsing handlig ;; ;;
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; error if not in git tree and in topdir.
(define (in-tree-topdir?)
(string=?
(canonicalize-path (getcwd))
(dirname (dirname (current-filename)))))
(define (usage progname exit-code)
(display (string-append
"Usage: "
progname
" [path/to/file.patch [path/to/file.patch ...]]\n"))
(exit exit-code))
(if (eq? (length (program-arguments)) 1)
(usage "checkpatch.pl" 64) ;; 64 is EX_USAGE in sysexits.h
(if (not (in-tree-topdir?))
((lambda _
(display
(string-append
"Error: please run checkpatch.scm in the git top directory.\n"))
(exit 69))) ;; 69 is EX_UNAVAILABLE in sysexits.h
(map (lambda (path)
(if (> (length (program-arguments)) 2)
(print-patch-name path))
(test-patch path))
(cdr (program-arguments)))))