From 4e643daab7ad2234e16b1296524370aa0aa4d307 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Mon, 8 Jul 2019 12:26:04 -0400 Subject: [PATCH 01/17] Remove ubiquitous --- config.lisp | 15 +++++++++++---- quicklisp-controller.asd | 1 - 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/config.lisp b/config.lisp index a943447..397c669 100644 --- a/config.lisp +++ b/config.lisp @@ -2,11 +2,18 @@ (in-package #:quicklisp-controller) -(eval-when (:compile-toplevel :load-toplevel :execute) - (ubiquitous:restore 'quicklisp-controller)) +(defun config-value (name) + (let* ((base "quicklisp-controller:config;value.txt") + (file (make-pathname :name name :defaults base))) + (when (probe-file file) + (with-open-file (stream file) + (read-line stream))))) -(defvar *report-to-email* (ubiquitous:value 'report-to-email) + +(defvar *report-to-email* + (config-value "report-to-email") "The email address to which reports are emailed.") -(defparameter githappy:*oauth2-token* (ubiquitous:value 'github-access-token)) +(defparameter githappy:*oauth2-token* + (config-value "githappy-token")) diff --git a/quicklisp-controller.asd b/quicklisp-controller.asd index 5bfde62..9f1284e 100644 --- a/quicklisp-controller.asd +++ b/quicklisp-controller.asd @@ -16,7 +16,6 @@ #:ironclad #:lparallel #:cl-who - #:ubiquitous #:githappy #:project-info #:westbrook) From 5ce3d2952e263aa33f58403266a56df4a2e1d8bb Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Mon, 8 Jul 2019 12:26:44 -0400 Subject: [PATCH 02/17] Recrank log work --- misc.lisp | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/misc.lisp b/misc.lisp index 083069c..874424a 100644 --- a/misc.lisp +++ b/misc.lisp @@ -547,3 +547,23 @@ source's source.txt file. Useful for bulk-updating sources." (when new-source (setf (first-line (source-file source)) new-source))))))) + + +;;; Showing update failures from a recrank log + +(defun starts-with (subseq seq) + (and (<= (length subseq) (length seq)) + (every #'equal subseq seq))) + +(defun crank-projects (crank-logfile) + (with-open-file (stream crank-logfile) + (loop for line = (read-line stream nil) + while line + when (and line (starts-with "* " line)) + collect (subseq line 2)))) + +(defun crank-failures (crank-logfile) + (dolist (project (crank-projects crank-logfile)) + (format t ";;; ~A~%" project) + (with-simple-restart (skip "Skip ~A" project) + (update-source-cache (find-source project))))) From 502ff20e30de700e6a8135a331db273a5f39dac6 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Mon, 8 Jul 2019 12:27:03 -0400 Subject: [PATCH 03/17] Make sure the path for the timing file is available --- dist-cache.lisp | 1 + 1 file changed, 1 insertion(+) diff --git a/dist-cache.lisp b/dist-cache.lisp index e1bd69e..31ae5d4 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -412,6 +412,7 @@ structure \(SYSTEM-FILE-NAME SYSTEM-NAME &REST DEPENDENCIES). " (let ((winners '()) (timing-file (timing-file source)) (start-time (get-universal-time))) + (ensure-directories-exist timing-file) (map-source-systems source (lambda (system-name system) From 47061a060663a47ccaa98130d22479433ad9d786 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Mon, 8 Jul 2019 12:31:19 -0400 Subject: [PATCH 04/17] Add failtail to irepl, fix up cantbuild to leave a comment on the issue with the log --- git.lisp | 15 +++++++++++++++ irepl.lisp | 25 +++++++++++++++++-------- 2 files changed, 32 insertions(+), 8 deletions(-) diff --git a/git.lisp b/git.lisp index 9ae3cab..469677d 100644 --- a/git.lisp +++ b/git.lisp @@ -39,6 +39,14 @@ (run "git" "commit" "-m" message)) (list :committed (name source) :with message))) +(defmacro with-issue-number ((var source) &body body) + (let ((source-var (copy-symbol 'source))) + `(let* ((,source-var (source-designator ,source)) + (,var (github-issue-number ,source-var))) + (unless ,var + (error "Can't find issue number for ~A" ,source-var)) + ,@body))) + (defun set-issue-label (source label) (setf source (source-designator source)) (let ((issue-number (github-issue-number source))) @@ -49,6 +57,13 @@ :number issue-number :body (githappy:js "labels" (list label))))) +(defun comment-on-issue (source comment) + (with-issue-number (number source) + (githappy:create-repo-issue-comment :body (githappy:js "body" comment) + :issue-number number + :repo "quicklisp-projects" + :owner "quicklisp"))) + (defun mark-canbuild (source) (set-issue-label source "canbuild")) diff --git a/irepl.lisp b/irepl.lisp index c66434b..49bc18a 100644 --- a/irepl.lisp +++ b/irepl.lisp @@ -126,12 +126,15 @@ (define-irepl-command skip (let ((index (position-if-not (=jref '("labels" :* "name")) - (all-issues *irepl-state*)))) + (all-issues *irepl-state*)))) (if index - (progn - (setf (issue-index *irepl-state*) index) - (invoke-irepl-command 'show)) - (format t "; No issue without labels~%")))) + (progn + (setf (issue-index *irepl-state*) index) + (invoke-irepl-command 'show)) + (format t "; No issue without labels~%")))) + +(define-irepl-command failtail + (failtail)) (defvar *irepl-guess-patterns* "https://github.com/") @@ -142,9 +145,15 @@ :canbuild)) (define-irepl-command cantbuild - (when *last-source* - (mark-cantbuild *last-source*) - :cantbuild)) + (cond (*last-source* + (mark-cantbuild *last-source*) + (let ((log-url (publish-source-failure *last-source*))) + (comment-on-issue *last-source* + (format nil "Failure log here: ~A" + log-url))) + :cantbuild) + (t + (warn "No last-source defined")))) (define-irepl-command commit (when *last-source* From 96beb451737e170d8fe551b389532f1cadda7228 Mon Sep 17 00:00:00 2001 From: Zachary Beane Date: Mon, 8 Jul 2019 15:20:34 -0400 Subject: [PATCH 05/17] Submodule names can have slashes, so encode them before use on the filesystem --- upstream-git.lisp | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/upstream-git.lisp b/upstream-git.lisp index 422fb0b..6dcfd7e 100644 --- a/upstream-git.lisp +++ b/upstream-git.lisp @@ -76,7 +76,9 @@ "--recursive" "echo $name $sha1 $displaypath") for (name sha1 path) = (split-spaces line) - collect (make-submodule :name name :path path :sha1 sha1))) + collect (make-submodule :name (encode-string-for-filesystem name) + :path path + :sha1 sha1))) (defun full-git-archive (git-path target-ref prefix output-file) "Create a tarball archive in OUTPUT-FILE of the full contents of the From d38ca7711f74995797a61b8032c3d537b19dc6d1 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Mon, 23 Dec 2019 10:30:38 -0500 Subject: [PATCH 06/17] Highlight failure log source lines in VCS websites if possible. --- html-failure-report.lisp | 172 ++++++++++++++++++++++++++++----------- 1 file changed, 126 insertions(+), 46 deletions(-) diff --git a/html-failure-report.lisp b/html-failure-report.lisp index 7240a36..225f208 100644 --- a/html-failure-report.lisp +++ b/html-failure-report.lisp @@ -82,6 +82,77 @@ the string is returned unchanged." (when substituted (return substituted))))) +(defun reconstitute (string patterns) + (let ((result (maybe-reconstitute string patterns))) + (and (not (eq result string)) + result))) + +;;; Linking to VCS sources from log lines + +(defun parse-vcs-source-log-line (log-line) + "Return a plist of info about log-line." + (when (and (search "dist/build-cache/" log-line) + (not (search ".cache/common-lisp" log-line))) + (ppcre:register-groups-bind (project-name full-path) + ("dist/build-cache/(.*?)/(.*$)" log-line) + (let* ((pos 0) + (second-slash + (dotimes (i 2 pos) + (setf pos (position #\/ full-path :start (1+ pos))))) + (end (and second-slash (position #\& full-path :start second-slash)))) + (let ((source (find-source project-name))) + (when (and source second-slash) + (let* ((path (subseq full-path (1+ second-slash) end)) + (start (search path log-line)) + (line-number nil)) + (ppcre:register-groups-bind ((#'parse-integer log-line-number)) ("Line: (\\d+)" log-line) + (setf line-number log-line-number)) + (list :source source + :path path + :line-number line-number + :path-bounds (cons start (+ start (length path))))))))))) + +(defparameter *location-base-substitutions* + '(("(https://github.com/.*?/.*?)\\.git" 0 "/blob/") + ("(https://.*gitlab.*)\\.git$" 0 "/blob/") + ("(https://bitbucket.org/.*?)\\.git$" 0 "/src/") + ("(http://dwim.hu/live/.*$)" 0))) + +(defun location-base (location) + (reconstitute location *location-base-substitutions*)) + +(defun source-branch (source) + (typecase source + (tagged-mixin + (tag-data source)) + (git-source + "master") + (t + nil))) + +(defun source-file-link-base (source) + (let ((base (location-base (location source)))) + (when base + (format nil "~A~@[~A/~]" base (source-branch source))))) + +(defun source-file-link (source path line-number) + (let ((base (source-file-link-base source))) + (when base + (format nil "~A~A~@[#L~A~]" base path line-number)))) + +(defun link-subseq (line link bounds) + (destructuring-bind (start . end) + bounds + (concatenate 'string + (subseq line 0 start) + "" + (subseq line start end) + "" + (subseq line end)))) + + ;;; Posting to S3 (defun report-publishing-enabled-p () @@ -90,8 +161,8 @@ the string is returned unchanged." (defun content-type (file) (cond ((equalp (pathname-type file) "css") "text/css") - ((equalp (pathname-type file) "rss") - "application/rss+xml") + ((equalp (pathname-type file) "rss") + "application/rss+xml") (t "text/html"))) @@ -124,9 +195,9 @@ the string is returned unchanged." (defgeneric full-failure-report-url (object) (:method (object) (format nil "http://~A/~A~A" - *failtail-bucket* - (report-prefix) - (failure-report-url object)))) + *failtail-bucket* + (report-prefix) + (failure-report-url object)))) (defgeneric failure-report-html-file (base object)) (defgeneric stylesheet-path (object)) @@ -161,8 +232,10 @@ the string is returned unchanged." (defmethod new-failure-p ((object failing-system)) (let* ((dist (ql-dist:find-dist "quicklisp")) - (system (ql-dist:find-system-in-dist (system-name object) dist))) - (not (not system)))) + (existing-system + (ql-dist:find-system-in-dist (system-name object) dist))) + (or (not (not existing-system)) + (< (days-old (source object)) 30)))) (defmethod failure-data ((source upstream-source)) (let ((result '())) @@ -260,61 +333,61 @@ source is found that matches the filename, return nil." ;; reason), so don't try to make a failing-source in that case. (let ((source (find-source source-name))) (when source - (make-instance 'failing-system - :source (find-source source-name) - :failure-log-file failure-file - :system-file-name system-file-name - :system-name (decode-string-from-filesystem - failing-system)))))) + (make-instance 'failing-system + :source (find-source source-name) + :failure-log-file failure-file + :system-file-name system-file-name + :system-name (decode-string-from-filesystem + failing-system)))))) (defun failing-source-log-files () (let* ((base (translate-logical-pathname "quicklisp-controller:dist;build-artifacts;")) - (fail-wild (merge-pathnames "**/fail_*_*_*.txt" base))) + (fail-wild (merge-pathnames "**/fail_*_*_*.txt" base))) (directory fail-wild))) (defun failing-systems () (remove nil - (mapcar #'parse-failure-file-name - (failing-source-log-files)))) + (mapcar #'parse-failure-file-name + (failing-source-log-files)))) (defun failure-log-failure-report () "Scan the failure log files of all projects to produce a failure report." (let ((systems (make-hash-table :test 'equal))) (flet ((fsource (source) - (or (gethash (name source) systems) - (setf (gethash (name source) systems) - (make-instance 'failing-source - :failure-data nil - :source source))))) + (or (gethash (name source) systems) + (setf (gethash (name source) systems) + (make-instance 'failing-source + :failure-data nil + :source source))))) (let ((table (make-hash-table :test 'eq)) - (systems (failing-systems)) - (report (make-instance 'failure-report - :failure-data '()))) - (dolist (system systems) - (let ((key (fsource (source system)))) - (push system (gethash key table)))) - (maphash (lambda (failing-source failing-systems) - (setf (failure-data failing-source) failing-systems) - (push failing-source (failure-data report))) - table) - report)))) + (systems (failing-systems)) + (report (make-instance 'failure-report + :failure-data '()))) + (dolist (system systems) + (let ((key (fsource (source system)))) + (push system (gethash key table)))) + (maphash (lambda (failing-source failing-systems) + (setf (failure-data failing-source) failing-systems) + (push failing-source (failure-data report))) + table) + report)))) (defmethod failure-data ((object (eql t))) (failure-log-failure-report)) (defparameter *log-lines-that-are-boring* (mapcar 'ppcre:create-scanner - '("^WARNING:"))) + '("^WARNING:"))) (defparameter *log-lines-to-highlight* (mapcar 'ppcre:create-scanner '("^; caught (WARNING|ERROR):" " READ error during" - "^Backtrace for" + "^Backtrace for" "^Unhandled"))) (defparameter *failure-log-reconstitution-patterns* - '(("(The ANSI Standard, Section )([0-9.]*)" + '(("(^.*The ANSI Standard, Section )([0-9.]*)" 0 "" 1 ""))) (defun failure-log-reconstitute-line (line) @@ -363,18 +436,25 @@ source is found that matches the filename, return nil." (loop for line = (read-line log-stream nil) while line do - (setf line (cl-who:escape-string line)) - (cond ((highlighted-log-line-p line) - (write-string "" stream) - (write-string line stream) - (write-string "" stream) - (terpri stream)) - ((boring-log-line-p line) - (format stream "~A~%" line)) - (t - (write-line line stream))))) + (setf line (failure-log-reconstitute-line (cl-who:escape-string line))) + (let ((upstream-info (parse-vcs-source-log-line line))) + (when upstream-info + (destructuring-bind (&key source path path-bounds line-number &allow-other-keys) + upstream-info + (let ((link (source-file-link source path line-number))) + (when link + (setf line (link-subseq line link path-bounds))))))) + (cond ((highlighted-log-line-p line) + (write-string "" stream) + (write-string line stream) + (write-string "" stream) + (terpri stream)) + ((boring-log-line-p line) + (format stream "~A~%" line)) + (t + (write-line line stream)))) (format stream "") - (format stream "~%")) + (format stream "~%"))) (defmethod write-html-failure-report-content ((source failing-source) stream) (dolist (system (failure-data source)) From aa9a552d1082dbdb52a38604bf7f41b37bff1d07 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 15 Mar 2020 09:11:56 -0400 Subject: [PATCH 07/17] Add daily run files --- daily.screenrc | 1 + daily.sh | 5 +++++ 2 files changed, 6 insertions(+) create mode 100644 daily.screenrc create mode 100755 daily.sh diff --git a/daily.screenrc b/daily.screenrc new file mode 100644 index 0000000..752272f --- /dev/null +++ b/daily.screenrc @@ -0,0 +1 @@ +screen sbcl --non-interactive --no-userinit --no-sysinit --load daily-script.lisp diff --git a/daily.sh b/daily.sh new file mode 100755 index 0000000..0e11d5a --- /dev/null +++ b/daily.sh @@ -0,0 +1,5 @@ +#!/bin/bash + +cd `dirname $0` +PATH=$PATH:/usr/local/bin +screen -c daily.screenrc -dmS daily-build From bfa87fe5e10a70f732852e49e0f72f37dbf35d41 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 15 Mar 2020 09:12:16 -0400 Subject: [PATCH 08/17] More patterns for failure links --- html-failure-report.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/html-failure-report.lisp b/html-failure-report.lisp index 225f208..9f786fc 100644 --- a/html-failure-report.lisp +++ b/html-failure-report.lisp @@ -116,7 +116,8 @@ the string is returned unchanged." '(("(https://github.com/.*?/.*?)\\.git" 0 "/blob/") ("(https://.*gitlab.*)\\.git$" 0 "/blob/") ("(https://bitbucket.org/.*?)\\.git$" 0 "/src/") - ("(http://dwim.hu/live/.*$)" 0))) + ("(http://dwim.hu/live/.*$)" 0) + ("^(https:.*notabug.*)\.git$" 0 "/src/"))) (defun location-base (location) (reconstitute location *location-base-substitutions*)) From a7ed476ad8584cf623d7cc56033638e64b8716a7 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 15 Mar 2020 09:12:42 -0400 Subject: [PATCH 09/17] Add util to post to gist --- utils.lisp | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/utils.lisp b/utils.lisp index c0380a0..d6ebc89 100644 --- a/utils.lisp +++ b/utils.lisp @@ -294,3 +294,17 @@ the subdirectory is absent or inconsistent." (#\Nul (write-string "[nul]" s)) (t (write-char char s)))))) + +(defun gist-file (&key (description "No description") pathname (public t)) + (unless pathname + (error "Pathname required")) + (flet ((js (&rest args) + (apply #'githappy:js args)) + (table (&rest args) + (apply #'githappy:table args))) + (let ((value (alexandria:read-file-into-string pathname)) + (key (file-namestring pathname))) + (githappy:create-gist :body + (githappy:js "description" description + "public" public + "files" (table key (table "content" value))))))) From 9fc95237f0f2f86cafc3afb2f1e7666610e8561b Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 15 Mar 2020 09:12:58 -0400 Subject: [PATCH 10/17] Misc updates --- misc.lisp | 11 +++++++++++ upstream.lisp | 24 +++++++++++++++--------- 2 files changed, 26 insertions(+), 9 deletions(-) diff --git a/misc.lisp b/misc.lisp index 874424a..2cbe42c 100644 --- a/misc.lisp +++ b/misc.lisp @@ -567,3 +567,14 @@ source's source.txt file. Useful for bulk-updating sources." (format t ";;; ~A~%" project) (with-simple-restart (skip "Skip ~A" project) (update-source-cache (find-source project))))) + +;;; Recrank only failing systems + +(defun recrank-failing-systems () + (map nil + (lambda (source) + (format *trace-output* "~&; XXX updating and cranking ~A~%" source) + (update-and-crank source)) + (remove-duplicates (mapcar 'source (failing-systems)) + :key 'name + :test 'equal))) diff --git a/upstream.lisp b/upstream.lisp index c75a0a1..def0ec6 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -26,6 +26,12 @@ (defmethod base-directory ((source upstream-source)) (pathname (directory-namestring (source-file source)))) +(defgeneric days-old (source) + (:method (source) + (truncate (- (get-universal-time) + (file-write-date (source-file source))) + 86400))) + (defgeneric print-source (source stream) (:method (source stream) (format stream "~S ~S" @@ -146,8 +152,8 @@ (defun collect-sources-if (fun) (let ((result '())) (map-sources (lambda (source) - (when (funcall fun source) - (push source result)))) + (when (funcall fun source) + (push source result)))) (sort result 'string< :key 'name))) (defun pmap-sources (fun &key (parallel-key #'source-host) @@ -187,7 +193,7 @@ (not (probe-file (make-pathname :type nil :name "fresh-cache" - :defaults (project-name-source-file (name source)) ))))) + :defaults (project-name-source-file (name source)) ))))) (defun find-source (project-name) (let* ((name (string-downcase project-name)) @@ -225,13 +231,13 @@ (defun missing-commands () (let ((missing '()) - (tried (make-string-table))) + (tried (make-string-table))) (map-sources (lambda (source) (let ((command (command source))) - (when command - (unless (gethash command tried) - (setf (gethash command tried) t) - (unless (ignore-errors (run command "--version")) - (push command missing))))))) + (when command + (unless (gethash command tried) + (setf (gethash command tried) t) + (unless (ignore-errors (run command "--version")) + (push command missing))))))) missing)) From eda88f25b4e65078877d4fdfa9ca727be7702e36 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sat, 1 Aug 2020 18:23:57 -0400 Subject: [PATCH 11/17] Make the excluded systems mechanism more explicit. --- dist-cache.lisp | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) diff --git a/dist-cache.lisp b/dist-cache.lisp index 31ae5d4..bc10580 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -82,7 +82,7 @@ ;;; System files -(defun blacklist-table (name) +(defun excluded-systems-table (name) (let* ((pathname (merge-logical (make-pathname :name name) #p"quicklisp-controller:projects;qlc-meta;template.txt")) (lines (and (probe-file pathname) (config-file-lines pathname))) @@ -90,16 +90,16 @@ (dolist (line lines table) (setf (gethash line table) t)))) -(defun blacklist-list (name) +(defun excluded-systems-list (name) (let ((pathname (merge-logical (make-pathname :name name) #p"quicklisp-controller:projects;qlc-meta;template.txt"))) (when (probe-file pathname) (config-file-lines pathname)))) -(defun make-blacklister (source) +(defun make-system-excluder (source) (lambda (system-file) - (let ((bad-patterns (blacklist-list "system-pathname-blacklist")) - (bad-combos (blacklist-table "blacklist")) + (let ((bad-patterns (excluded-systems-list "excluded-system-pathnames")) + (bad-combos (excluded-systems-table "excluded-systems")) (combo-key (format nil "~A ~A" (project-name source) (pathname-name system-file)))) @@ -108,10 +108,11 @@ (search string (namestring system-file))) bad-patterns))))) -(defun blacklistedp (source system-file) - "Is SYSTEM-FILE for SOURCE somehow forbidden, e.g. " - (let ((bad-patterns (blacklist-list "system-pathname-blacklist")) - (bad-combos (blacklist-table "blacklist")) +(defun excluded-system-p (source system-file) + "Is SYSTEM-FILE for SOURCE excluded through a pathname exclusion +list or a system name exclusion list?" + (let ((bad-patterns (excluded-systems-list "excluded-system-pathnames")) + (bad-combos (excluded-systems-table "excluded-systems")) (combo-key (format nil "~A ~A" (project-name source) (pathname-name system-file))) @@ -132,12 +133,12 @@ (defun build-system-files (source) "Return a list of system files in the build directory of SOURCE." (setf source (source-designator source)) - (let* ((blacklist-fun (make-blacklister source)) + (let* ((excluded-system-fun (make-system-excluder source)) (base (ensure-cached-build-directory source)) (wild (merge-pathnames "**/*.asd" base)) (files (directory wild))) (mapcan (lambda (file) - (unless (funcall blacklist-fun file) + (unless (funcall excluded-system-fun file) (when (find-if #'upper-case-p (file-namestring file)) (error "Mixed-case system file ~A cannot be used" file)) @@ -171,7 +172,7 @@ if needed." (setf source (source-designator source)) (let ((files (ensure-build-system-files source))) (remove-if (lambda (file) - (blacklistedp source file)) + (excluded-system-p source file)) files))) (defun system-names (source) @@ -184,7 +185,7 @@ if needed." ;; Add SBCL contribs first (let* ((base (sb-int:sbcl-homedir-pathname)) (contrib-system-files - (directory (merge-pathnames "contrib/*.asd" base)))) + (directory (merge-pathnames "**/*.asd" base)))) (dolist (file contrib-system-files) (setf (gethash (pathname-name file) table) file))) (map-sources @@ -205,6 +206,7 @@ if needed." :direction :output :if-exists :supersede) (maphash (lambda (system-name system-file) + (declare (ignore system-name)) (format stream "~A~%" (enough-namestring system-file (translate-logical-pathname file)))) @@ -384,7 +386,7 @@ their name does not match the system file name." (with-system-index (dolist (system-file-name (system-names source)) (dolist (system (ignore-errors (system-defined-systems system-file-name))) - (unless (blacklistedp source system) + (unless (excluded-system-p source system) (funcall fun system-file-name system)))))) (defun acceptable-system-name (name) @@ -453,7 +455,7 @@ structure \(SYSTEM-FILE-NAME SYSTEM-NAME &REST DEPENDENCIES). " (defun build-duration (source) (destructuring-bind (&key start-time end-time) (timing-data source) - (if start-time + (if (and start-time end-time) (- end-time start-time) -1))) From 691ce50e5c4352aa53044e2c8e0959b3fba1448c Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Wed, 26 Aug 2020 16:43:17 -0400 Subject: [PATCH 12/17] Adapt to latest sbcl --- system-file-magic.lisp | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/system-file-magic.lisp b/system-file-magic.lisp index a3f283b..f40407a 100644 --- a/system-file-magic.lisp +++ b/system-file-magic.lisp @@ -64,6 +64,18 @@ (format stream "~S~%~%" sexp))))) +(defun setenv (name value) + (let ((r + (sb-alien:alien-funcall + (sb-alien:extern-alien "setenv" + (sb-alien:function + sb-alien:int (sb-alien:c-string :not-null t) + (sb-alien:c-string :not-null t) sb-alien:int)) + name value 1))) + (if (minusp r) + (error "setenv") + r))) + (defun main (argv) (setf *package* (find-package :keyword)) (sb-ext:disable-debugger) @@ -71,6 +83,11 @@ ;; (load-time-value ;; (directory-namestring sb-int::*core-string*)) ;; 1) + (setenv "SBCL_HOME" + (load-time-value + (directory-namestring sb-int::*core-string*))) + (setf sb-sys::*sbcl-homedir-pathname* (sb-impl::%sbcl-homedir-pathname)) + (destructuring-bind (index-file system-name output-file &optional project-name description-file) (rest argv) From 5713773187536219b5e542807c0819584d1e86f9 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Wed, 26 Aug 2020 16:43:57 -0400 Subject: [PATCH 13/17] Sync with latest sbcl --- depcheck.lisp | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/depcheck.lisp b/depcheck.lisp index 74c29f4..9cf0470 100644 --- a/depcheck.lisp +++ b/depcheck.lisp @@ -5,6 +5,10 @@ (in-package #:depcheck) +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-symbol "SBCL-HOMEDIR-PATHNAME" "SB-SYS") + (pushnew :sbcl-homedir-pathname *features*))) + (defvar *direct-dependencies* nil) (defun load-asdf-system-table (file) @@ -201,6 +205,7 @@ (setenv "SBCL_HOME" (load-time-value (directory-namestring sb-int::*core-string*))) + (setf sb-sys::*sbcl-homedir-pathname* (sb-impl::%sbcl-homedir-pathname)) #+nil (setenv "CC" "gcc") (eval *load-op-wrapper*) From a6fdd275bfce495f7fbc602fe325fc3c47c37a81 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Wed, 27 Jan 2021 19:42:52 -0500 Subject: [PATCH 14/17] Snapshot of various works in progress. --- daily.sh | 2 +- depcheck.lisp | 3 + failure-report.css | 8 ++ html-failure-report.lisp | 210 ++++++++++++++++++++++++++++++++----- misc.lisp | 23 +++- submit-bug-report.lisp | 87 +++++++++++++++ update-failure-report.lisp | 21 ++++ upstream-git.lisp | 8 ++ upstream-http.lisp | 4 + upstream-vcs.lisp | 2 + upstream.lisp | 19 ++++ utils.lisp | 47 ++++++--- 12 files changed, 390 insertions(+), 44 deletions(-) create mode 100644 submit-bug-report.lisp create mode 100644 update-failure-report.lisp diff --git a/daily.sh b/daily.sh index 0e11d5a..f100de4 100755 --- a/daily.sh +++ b/daily.sh @@ -2,4 +2,4 @@ cd `dirname $0` PATH=$PATH:/usr/local/bin -screen -c daily.screenrc -dmS daily-build +screen -c daily.screenrc -dmLS daily-build diff --git a/depcheck.lisp b/depcheck.lisp index 9cf0470..0862ac1 100644 --- a/depcheck.lisp +++ b/depcheck.lisp @@ -200,6 +200,9 @@ (when (equalp (second argv) "--sbcl-version") (format t "~A~%" (lisp-implementation-version)) (sb-ext:exit :code 0)) + (when (getenv "DEPCHECK_HIDEBUG") + (sb-ext:restrict-compiler-policy 'debug 3) + (sb-ext:restrict-compiler-policy 'safety 3)) (unless (getenv "DEPCHECK_DEBUG") (sb-ext:disable-debugger)) (setenv "SBCL_HOME" diff --git a/failure-report.css b/failure-report.css index 2321b11..0fe6532 100644 --- a/failure-report.css +++ b/failure-report.css @@ -1,3 +1,11 @@ +pre.snippet { + overflow-wrap: break-word; + color: black; + font-weight: normal; + white-space: pre-wrap; + width: 75em; +} + .failing-system pre { color: #111; margin-left: 2em; diff --git a/html-failure-report.lisp b/html-failure-report.lisp index 9f786fc..ab2744a 100644 --- a/html-failure-report.lisp +++ b/html-failure-report.lisp @@ -154,6 +154,88 @@ the string is returned unchanged." (subseq line end)))) +;;; Scraping error logs for the real problem + +(defstruct peekstream + stream + buffered-line) + +(defun next-line (peekstream) + (if (peekstream-buffered-line peekstream) + (shiftf (peekstream-buffered-line peekstream) nil) + (read-line (peekstream-stream peekstream) nil))) + +(defun peek-line (peekstream) + (or (peekstream-buffered-line peekstream) + (setf (peekstream-buffered-line peekstream) + (read-line (peekstream-stream peekstream) nil)))) + +(defun unread-line (line peekstream) + (setf (peekstream-buffered-line peekstream) line)) + +(defun =line-matches (pattern) + (let ((scanner (ppcre:create-scanner pattern))) + (lambda (line) + (ppcre:scan scanner line)))) + +(defun callfun (object) + (lambda (fun) + (funcall fun object))) + +(defun =or (&rest funs) + (lambda (object) + (some (callfun object) funs))) + +(defun =not (fun) + (complement fun)) + +(defun skip-text-until (fun stream) + (loop for line = (peek-line stream) + while line + do + (cond ((funcall fun line) + (return line)) + (t + (next-line stream))))) + +(defun collect-text-while (fun stream) + (with-output-to-string (s) + (loop for line = (peek-line stream) + while (and line (funcall fun line)) + do (write-line (next-line stream) s)))) + +(defun collect-text-between (start-fun end-fun stream) + (let* ((first-line (skip-text-until start-fun stream)) + (rest (and first-line (next-line stream) (collect-text-while (=not end-fun) stream)))) + (when first-line + (concatenate 'string + first-line #(#\newline) + rest)))) + +(defun extract-warnings-and-errors (file) + "Scrape warnings and errors out of the logfile FILE. Repeated +consecutive strings are coalesced into a single string to avoid +redundant info." + (flet ((coalesce-consecutive-strings (strings) + (let ((out '())) + (dolist (string strings (nreverse out)) + (unless (equal (first out) string) + (push string out)))))) + (coalesce-consecutive-strings + (with-open-file (stream file) + (let ((pstream (make-peekstream :stream stream))) + (let (result) + (loop + (let ((match (collect-text-between (=or (=line-matches "^; caught (COMMON-LISP:)?(WARNING|ERROR):") + (=line-matches "^Unhandled")) + (=not (=line-matches "^;")) + pstream))) + (if match + (push match result) + (return (nreverse result))))))))))) + + + ;;; Posting to S3 (defun report-publishing-enabled-p () @@ -208,6 +290,8 @@ the string is returned unchanged." (defgeneric write-html-failure-report-content (object stream)) (defgeneric write-html-failure-report-footer (object stream)) +(defgeneric failure-impact (object)) + (defmethod failure-report-html-file (base object) (relative-to base (failure-report-url object))) @@ -225,12 +309,39 @@ the string is returned unchanged." :reader source) (failure-log-file :initarg :failure-log-file - :reader failure-log-file))) + :reader failure-log-file) + (warnings-and-errors + :reader warnings-and-errors) + (breaks + :accessor breaks + :initform nil) + (broken-by + :accessor broken-by + :initform nil))) (defmethod print-object ((object failing-system) stream) (print-unreadable-object (object stream :type t) (write-string (system-name object) stream))) +(defmethod failure-impact ((object failing-system)) + (length (breaks object))) + +(defmethod slot-unbound ((class t) (instance failing-system) (slot (eql 'warnings-and-errors))) + (setf (slot-value instance 'warnings-and-errors) + (extract-warnings-and-errors (failure-log-file instance)))) + +(defun broken-by-name (failing-system) + (let* ((unhandled-log-line + (find "Unhandled" (warnings-and-errors failing-system) + :test #'search)) + (responsible-system-name + (ppcre:register-groups-bind (system-name) + ("^Unhandled.*while compiling.*SOURCE-FILE \"(.*?)\"" + unhandled-log-line) + system-name))) + (or responsible-system-name + (system-name failing-system)))) + (defmethod new-failure-p ((object failing-system)) (let* ((dist (ql-dist:find-dist "quicklisp")) (existing-system @@ -239,22 +350,11 @@ the string is returned unchanged." (< (days-old (source object)) 30)))) (defmethod failure-data ((source upstream-source)) - (let ((result '())) - (map-source-systems - source - (lambda (system-file-name system-name) - (write-char #\. *trace-output*) - (force-output *trace-output*) - (let ((file (winfail-file "fail" source system-file-name system-name))) - (when (probe-file file) - (push (make-instance 'failing-system - :system-name system-name - :system-file-name - system-file-name - :source source - :failure-log-file file) - result))))) - result)) + (remove (name source) + (failing-systems) + :test-not 'string= + :key (lambda (system) + (name (source system))))) (defmethod name ((object failing-system)) (name (source object))) @@ -282,6 +382,9 @@ the string is returned unchanged." (name (source object)) (length (failure-data object))))) +(defmethod failure-impact ((object failing-source)) + (reduce #'+ (mapcar #'failure-impact (failure-data object)))) + (defmethod source-link ((source failing-source)) (source-link (source source))) @@ -347,9 +450,29 @@ source is found that matches the filename, return nil." (directory fail-wild))) (defun failing-systems () - (remove nil - (mapcar #'parse-failure-file-name - (failing-source-log-files)))) + ;; This is the best way to get failure info, because it populates + ;; useful failure cross-reference data. + (let* ((systems (remove nil + (mapcar #'parse-failure-file-name + (failing-source-log-files)))) + (table (make-hash-table :test 'equal))) + (dolist (system systems) + (setf (gethash (system-name system) table) system)) + (dolist (system systems) + (let ((broken-by (or (gethash (broken-by-name system) table) + system))) + (unless (eq broken-by system) + (setf (broken-by system) + broken-by) + (push system (breaks broken-by))))) + systems)) + +(defun who-is-broken-by (name) + (remove name (failing-systems) + :test-not #'string= + :key (lambda (failing-system) + (and (broken-by failing-system) + (system-name (broken-by failing-system)))))) (defun failure-log-failure-report () "Scan the failure log files of all projects to produce a failure report." @@ -402,6 +525,13 @@ source is found that matches the filename, return nil." (loop for scanner in *log-lines-that-are-boring* thereis (ppcre:scan scanner line))) +(defun failure-snippet (object) + (etypecase object + (failing-system + (format nil "~{~A~^...~%~}~%" + (extract-warnings-and-errors (failure-log-file object)))) + (failing-source + (format nil "~{~A~}" (mapcar #'failure-snippet (failure-data object)))))) (defmethod write-html-failure-report-header (object stream) (format stream "~A~ @@ -476,22 +606,45 @@ source is found that matches the filename, return nil." (new (remove-if-not #'new-failure-p sources)) (old (remove-if #'new-failure-p sources))) (flet ((show (sources) - (dolist (source sources) + (dolist (source (sort (copy-seq sources) #'string< :key #'name)) (let ((link (source-link source))) (format stream " ~A:
" (new-failure-p source) (name source)) + (let ((age (source-cache-age-or-nil (source source)))) + (when age + (format stream "last modified ~A ago
~%" (how-long-ago age)))) (if link (format stream "~A" link link) (format stream "~A" (location (source source)))) (format stream "~%") (format stream "
    ") - (dolist (system (failure-data source)) - (format stream " ~A~%" - (new-failure-p system) - (failure-report-url system) - (system-name system)))) - (format stream "
~%")))) + (dolist (system (sort (copy-seq (failure-data source)) #'string< :key #'system-name)) + (let ((responsible (broken-by system)) + (system-name (system-name system))) + (format stream " ~A" + (new-failure-p system) + system-name + (failure-report-url system) + system-name) + (when responsible + (format stream " caused by ~A~%" + (system-name responsible) + (system-name responsible))) + (when (breaks system) + (format stream "
Breaks: ") + (dolist (broken (breaks system)) + (format stream "~A " + (system-name broken) + (system-name broken))) + (format stream "
")) + (unless responsible + (format stream "
~A
" + (cl-who:escape-string (failure-snippet system)))) + (when responsible + (format stream "
")) + (format stream "~%")))) + (format stream "")))) (show new) (format stream "

") (show old))) @@ -503,6 +656,9 @@ source is found that matches the filename, return nil." (let ((link (source-link (source object)))) (when link (format stream "
  • site: ~A~%" link link))) + (let ((age (source-cache-age-or-nil (source object)))) + (when age + (format stream "
  • last updated: ~A ago" (how-long-ago age)))) (format stream "~%") (format stream "

    ~A~%" (versions-and-such))) diff --git a/misc.lisp b/misc.lisp index 2cbe42c..52c4f7f 100644 --- a/misc.lisp +++ b/misc.lisp @@ -6,6 +6,11 @@ (run "rm" "-rf" (merge-pathnames ".cache/common-lisp/" (user-homedir-pathname)))) +(defun clear-all-caches () + (clear-fasl-cache) + (clear-dist-caches) + (clear-system-file-magic-cache)) + (defun system-from-release (system-name dist) (let* ((dist (ql-dist:dist dist)) (system (ql-dist:find-system-in-dist system-name dist)) @@ -162,15 +167,27 @@ (check-for-program program))) (defun crank (&optional (source *last-source*)) + (setf source (source-designator source)) (check-critical-programs) (unless (source-designator source) (warn "Not a known source -- ~S" source) (return-from crank nil)) (setf *last-source* source) (update-system-file-index) - (let ((wins (find-more-winning-systems source))) - (list :fails (missing-components source) - :wins wins))) + (find-more-winning-systems source) + (let ((fails (failure-data source))) + (when fails + (format t "FAILURES:~%") + (dolist (fail fails) + (cond ((broken-by fail) + (let ((responsible-system (broken-by fail))) + (format t "System ~A broken by ~A~%" + (system-name fail) + (system-name responsible-system)))) + (t + (format t "~S:~%~A" + (system-name fail) + (failure-snippet fail)))))))) (defun source-pathname (project-name) (let ((directory `(:relative "quicklisp-controller" diff --git a/submit-bug-report.lisp b/submit-bug-report.lisp new file mode 100644 index 0000000..204cb53 --- /dev/null +++ b/submit-bug-report.lisp @@ -0,0 +1,87 @@ +;;;; submit-bug-report.lisp +;;;; +;;;; Semiautomatically create bug reports to send to projects for +;;;; systems that fail. +;;;; +;;;; This is based around the data in a failing-system object, defined +;;;; in html-failure-report.lisp +;;;; + +(in-package #:quicklisp-controller) + +(defun github-source-p (source) + (search "/github.com/" (location source))) + +(deftype github-source () + `(satisfies github-source-p)) + +(defun github-owner (failing-system) + (nth-value 0 (github-owner-and-repo (location (source failing-system))))) + +(defun github-repo (failing-system) + (nth-value 1 (github-owner-and-repo (location (source failing-system))))) + +(defun submit-github-issue (owner repo title body) + (githappy::create-repo-issue + :owner owner + :repo repo + :body (githappy:js "title" title "body" body))) + + +(defun existing-bug-reports (source) + (multiple-value-bind (owner repo) + (github-owner-and-repo (location source)) + (unless owner + (error "Not a github repo")) + (let* ((response (githappy:repo-issues :owner owner :repo repo :per-page 100)) + (json (githappy:json response))) + (mapcan + (lambda (issue) + (when (equal "quicklisp" (githappy:jref issue '("user" "login"))) + (list (list :number (githappy:jref issue "number") + :title (githappy:jref issue "title"))))) + json)))) + +(defun blameless-for-failure-p (failing-source) + (null (remove-if #'broken-by (failure-data failing-source)))) + +(defun bug-report-body (failing-source &key log-link) + (with-output-to-string (s) + (format s "Building with ~A for quicklisp dist creation.~%~%" + (versions-and-such)) + (format s "Trying to build commit id ~A~%~%" (commit-id (source failing-source))) + (dolist (system (failure-data failing-source)) + (format s "*~A* fails to build" (system-name system)) + (if (broken-by system) + (format s " because of a failure in _~A_.~%~%" + (system-name (broken-by system))) + (format s " with the following error:~%~%```~%~A~&```~%~%" + (failure-snippet system)))) + (when log-link + (format s "[Full log here](~A)~%~%" log-link)))) + +(defun report-bug-stuff (source) + (setf source (source-designator source)) + (let* ((failing-source (find-failing-source source)) + (log-link (publish-source-failure source)) + (body (bug-report-body failing-source :log-link log-link)) + (title "Some systems failed to build for Quicklisp dist")) + (list :title title + :body body))) + +(defun report-bug-in (source) + (setf source (source-designator source)) + (let* ((failing-source (find-failing-source source)) + (log-link (publish-source-failure source)) + (body (bug-report-body failing-source :log-link log-link))) + (multiple-value-bind (owner repo) + (github-owner-and-repo (location source)) + (format t "Posting bug report for ~A~%~%" source) + (format t "~A" body) + (let ((existing (existing-bug-reports (source failing-source)))) + (when existing + (format t "WARNING: BUGS ALREADY SUBMITTED BY quicklisp:~%~{ ~A~%~}~%" + existing))) + (when (ql-util:press-enter-to-continue) + (submit-github-issue owner repo "Some systems failed to build for Quicklisp dist" body))))) + diff --git a/update-failure-report.lisp b/update-failure-report.lisp new file mode 100644 index 0000000..0c0a873 --- /dev/null +++ b/update-failure-report.lisp @@ -0,0 +1,21 @@ +(in-package #:quicklisp-controller) + +(defun latest-build-log-file () + (let ((logs (directory (asdf:system-relative-pathname "quicklisp-controller" + #p"logs/**/*.txt")))) + (first (last (sort logs #'string< :key #'namestring ))))) + +(defun collect-matching (fun stream) + (loop for line = (next-line stream) + while line + when (funcall fun line) + collect line)) + +(defun extract-failed-updates (file) + (with-open-file (stream file) + (mapcar (lambda (line) + (find-source (second (split-spaces line)))) + (collect-matching (=line-matches "^[*]") (make-peekstream :stream stream))))) + +(defun sources-that-failed-to-update () + (extract-failed-updates (latest-build-log-file))) diff --git a/upstream-git.lisp b/upstream-git.lisp index 6dcfd7e..1d12acf 100644 --- a/upstream-git.lisp +++ b/upstream-git.lisp @@ -45,6 +45,14 @@ (with-run-output (stream ("git" "rev-parse" "HEAD")) (read-line stream))))) +(defmethod source-cache-timestamp ((source git-source)) + (let ((unix-time-offset (load-time-value (encode-universal-time 0 0 0 1 1 1970 0)))) + (let ((checkout (ensure-source-cache source))) + (with-posix-cwd checkout + (with-run-output (stream ("git" "show" "-s" "--format=%ct")) + (let ((unix-time-string (read-line stream))) + (+ (parse-integer unix-time-string) unix-time-offset))))))) + (defmethod tag-data :around ((source branched-git-source)) (let ((tag (call-next-method)) (commit (commit-id source))) diff --git a/upstream-http.lisp b/upstream-http.lisp index 43a9eb1..35176a1 100644 --- a/upstream-http.lisp +++ b/upstream-http.lisp @@ -24,6 +24,10 @@ (string-digest (location source))) "quicklisp-controller:upstream-cache;http;")) +(defmethod source-cache-timestamp ((source http-source)) + (and (probe-file (cache-object-file source)) + (file-write-date (cache-object-file source)))) + (defmethod make-release-tarball ((source http-source) output-file) (let ((prefix (release-tarball-prefix source)) (package (ensure-source-cache source))) diff --git a/upstream-vcs.lisp b/upstream-vcs.lisp index 052aa70..630d36c 100644 --- a/upstream-vcs.lisp +++ b/upstream-vcs.lisp @@ -96,6 +96,8 @@ (probe-file pathname))) + + ;;; Tags of some sort (defclass tagged-mixin () diff --git a/upstream.lisp b/upstream.lisp index def0ec6..cb517ae 100644 --- a/upstream.lisp +++ b/upstream.lisp @@ -84,6 +84,25 @@ (:documentation "Try to update cached data for SOURCE.")) +(defgeneric source-cache-timestamp (source) + (:documentation "Return the timestamp, as a universal time, at which + the source cache was last updated by the upstream. Return NIL if the + timestamp can't be determined.") + (:method ((source t)) + nil)) + +(defgeneric source-cache-age-or-nil (source) + (:documentation "Return the age, in days, of the source's cached + data. For VCS, it is the age of commit. For HTTP/HTTPS, it's the + date on the last-modified. If the age can't be determined, return + NIL.") + (:method (source) + (let ((time (source-cache-timestamp source))) + (and time + (/ (- (get-universal-time) (source-cache-timestamp source)) + 86400.0))))) + + ;;; ;;; Loading & mapping sources from the quicklisp-projects directory. ;;; diff --git a/utils.lisp b/utils.lisp index d6ebc89..50fb8b1 100644 --- a/utils.lisp +++ b/utils.lisp @@ -176,25 +176,21 @@ template pathname." (save-forms (list form) file)) (defun tarball-contents (file) - (with-run-output (stream ("tar" "tzf" (native file))) - (loop for line = (read-line stream nil) - while line collect line))) + (run-output-lines "tar" "tzf" file)) (defun tarball-prefix (file) "For a tarball that unpacks into a subdirectory (e.g. 'foo/foo.asd', 'foo/package.asd', etc), extract the subdirectory string. Errors if the subdirectory is absent or inconsistent." (let ((contents (tarball-contents file))) - (let ((first-slash (position #\/ (first contents)))) - (unless first-slash - (error "No slash in first entry of tarball -- ~A" (first contents))) - (let ((prefix (subseq (first contents) 0 - (1+ first-slash)))) - (dolist (entry contents prefix) - (unless (and (<= (length prefix) (length entry)) - (string= prefix entry :end2 (length prefix))) - (error "Tarball ~A lacks consistent prefix output directory" - file))))))) + (let ((prefixes (loop for path in contents + collect + (subseq path 0 (position #\/ path))))) + (unless (every 'string= prefixes (rest prefixes)) + (error "Inconsistent prefixes in ~A: ~S" + file + (remove-duplicates prefixes :test 'string=))) + (format nil "~A/" (first prefixes))))) (defun tarball-canonical-name (file) (string-right-trim "/" (tarball-prefix file))) @@ -308,3 +304,28 @@ the subdirectory is absent or inconsistent." (githappy:js "description" description "public" public "files" (table key (table "content" value))))))) + + +(defun gist-string (&key (description "No description") string (public t)) + (unless string + (error "string required")) + (flet ((js (&rest args) + (apply #'githappy:js args)) + (table (&rest args) + (apply #'githappy:table args))) + (let ((value string) + (key "text.md")) + (githappy:create-gist :body + (githappy:js "description" description + "public" public + "files" (table key (table "content" value))))))) + +(defun how-long-ago (days) + (cond ((< days 1) + "less than a day") + ((< days 21) + (format nil "~:D day~:P" (truncate days))) + ((< days 365) + (format nil "~:D week~:P" (truncate days 7.0))) + (t + (format nil "~:D year~:P" (truncate days 365.0))))) From 26f750b353a9e6732f547ff451080b5ba29bf11a Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 30 May 2021 19:40:05 -0400 Subject: [PATCH 15/17] Add gitlab upstream --- quicklisp-controller.asd | 20 +++++++++++--------- upstream-gitlab.lisp | 38 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 9 deletions(-) create mode 100644 upstream-gitlab.lisp diff --git a/quicklisp-controller.asd b/quicklisp-controller.asd index 9f1284e..5bba6db 100644 --- a/quicklisp-controller.asd +++ b/quicklisp-controller.asd @@ -12,16 +12,16 @@ #:drakma #:yason #:function-cache - #:trivial-utf-8 + #:trivial-utf-8 #:ironclad #:lparallel - #:cl-who + #:cl-who #:githappy #:project-info - #:westbrook) + #:westbrook) :serial t :components ((:file "tarhash") - (:file "github-issues") + (:file "github-issues") (:file "package") (:file "config") (:file "logical-host") @@ -29,7 +29,7 @@ (:file "utils") (:file "setup") (:file "upstream") - (:file "system-file-magic-cache") + (:file "system-file-magic-cache") (:file "dist-cache") (:file "upstream-vcs") (:file "upstream-http") @@ -38,6 +38,7 @@ (:file "upstream-darcs") (:file "upstream-git") (:file "upstream-github") + (:file "upstream-gitlab") (:file "upstream-mercurial") (:file "upstream-svn") (:file "upstream-bzr") @@ -51,11 +52,12 @@ (:file "update-client-version") (:file "descriptions") (:file "ng-indexes") - (:file "git") - (:file "html-failure-report") - (:file "rss-failure-feeds") + (:file "git") + (:file "html-failure-report") + (:file "rss-failure-feeds") (:file "recrank") - (:file "irepl"))) + (:file "irepl") + (:file "submit-bug-report"))) (defpackage #:quicklisp-controller-config (:use) diff --git a/upstream-gitlab.lisp b/upstream-gitlab.lisp new file mode 100644 index 0000000..345f599 --- /dev/null +++ b/upstream-gitlab.lisp @@ -0,0 +1,38 @@ +;;;; upstream-gitlab.lisp +;;;; +;;;; Fetch some basic info about a source from gitlab +;;;; + +(in-package #:quicklisp-controller) + +(defun gitlab-project-id (url) + (ppcre:register-groups-bind (user project) + ("gitlab.com/(.*?)/(.*?)(.git)?$" url) + (when user + (format nil "~A%2F~A" user project)))) + +(defun gitlab-project-release-json (url) + (let* ((uri (format nil "https://gitlab.com/api/v4/projects/~A/releases" + (gitlab-project-id url))) + (request (make-instance 'githappy::request + :uri uri)) + (response (githappy::submit request)) + (json (yason:parse (githappy::utf8-string (githappy::body response))))) + json)) + +(defun gitlab-latest-tag-info (url) + (let ((json (gitlab-project-release-json url))) + (when json + (let ((tag-data (githappy:jref json '(0 "tag_name"))) + (sources (githappy:jref json '(0 "assets" "sources")))) + (dolist (source sources) + (when (equal (githappy:jref source "format") "tar.gz") + (return (list :tag tag-data + :url (githappy:jref source "url"))))))))) + + +(defclass latest-gitlab-release-source (latest-github-release-source) + ()) + +(defmethod github-info-plist ((source latest-gitlab-release-source)) + (gitlab-latest-tag-info (location source))) From 5608e75ec9c4e1f33438c204d37f4d4ca2b21ff6 Mon Sep 17 00:00:00 2001 From: Zach Beane Date: Sun, 30 May 2021 19:40:31 -0400 Subject: [PATCH 16/17] add logging to daily --- daily.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/daily.sh b/daily.sh index f100de4..a587934 100755 --- a/daily.sh +++ b/daily.sh @@ -2,4 +2,4 @@ cd `dirname $0` PATH=$PATH:/usr/local/bin -screen -c daily.screenrc -dmLS daily-build +screen -L -c daily.screenrc -dmLS daily-build From 120fde6946495a1026a78d7516a423899441ce07 Mon Sep 17 00:00:00 2001 From: Eric Timmons Date: Fri, 10 Sep 2021 18:08:38 -0400 Subject: [PATCH 17/17] Improve package-inferred-system dependency extraction Prior to this commit effectively only the direct dependencies of the parent system of a package-inferred-system were extracted. This commit fixes that by continuing to extract dependencies of inferred child systems. Previously depcheck would produce the following dependency list for the 40ants-doc system: 40ants-doc 40ants-doc/core 40ants-doc/glossary 40ants-doc/restart asdf With this commit, the following is instead produced: 40ants-doc asdf named-readtables pythonic-string-reader --- depcheck.lisp | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/depcheck.lisp b/depcheck.lisp index 0862ac1..17cd23a 100644 --- a/depcheck.lisp +++ b/depcheck.lisp @@ -119,6 +119,38 @@ ;;(check-attribute 'asdf:system-license :license) (check-attribute 'asdf:system-author :author)))) +(defun child-system-p (maybe-parent-name maybe-child-name) + (and (not (equal maybe-parent-name maybe-child-name)) + (equal maybe-parent-name (asdf:primary-system-name maybe-child-name)))) + +(defun system-direct-dependencies (system-designator) + (mapcar 'normalize-dependency + (asdf:system-depends-on (asdf:find-system system-designator)))) + +(defun replace-inferred-system-deps-1 (system-name dependencies) + (let* ((inferred-children-deps + (remove-if-not (lambda (name) (child-system-p system-name name)) + dependencies)) + (deps-of-children + (reduce 'append + (mapcar 'system-direct-dependencies inferred-children-deps) + :initial-value nil))) + (values + (append (set-difference dependencies inferred-children-deps) + deps-of-children) + (null inferred-children-deps)))) + +(defun replace-inferred-system-deps (system-name dependencies) + (let ((external-deps dependencies)) + (loop + (multiple-value-bind (new-dependencies donep) + (replace-inferred-system-deps-1 system-name external-deps) + (setf external-deps (remove-duplicates new-dependencies + :test #'equal)) + (when donep + (return)))) + external-deps)) + (defun compute-dependencies (system-file system-name) (let* ((asdf:*system-definition-search-functions* (list #-asdf3 'asdf::sysdef-find-asdf @@ -135,6 +167,10 @@ (when (equalp system-file system-name) (setf dependencies *implied-dependencies*))) (asdf:oos 'asdf:load-op system-name) + (when (and (typep (asdf:find-system system-name) 'asdf:package-inferred-system) + (equalp system-name system-file)) + (setf *direct-dependencies* + (replace-inferred-system-deps system-name *direct-dependencies*))) (setf dependencies (remove-duplicates (append *direct-dependencies* dependencies) :test #'equalp))