~A" + (cl-who:escape-string (failure-snippet system)))) + (when responsible + (format stream "
~A~%" (versions-and-such))) 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* diff --git a/misc.lisp b/misc.lisp index fd0cb77..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" @@ -281,7 +298,7 @@ (tail-file file n))) (defvar *failtail-credentials-file* - #p"quicklisp-controller:failtail-credentials.txt") + #p"quicklisp-controller:dist;failtail-credentials.txt") (defvar *failtail-credentials* (zs3:file-credentials *failtail-credentials-file*)) @@ -393,7 +410,7 @@ (error "Can't guess project name")) (when (equal name "") (error "Name can't be empty")) - (let ((file (project-source-filename name))) + (let ((file (project-name-source-file name))) (restart-case (when (probe-file file) (error "Project already has a file")) @@ -530,13 +547,16 @@ (defun =location~ (substring) (lambda (source) - (search substring (location source)))) + (ppcre:scan substring (location source)))) (defun http-to-https (source) (let ((location (ppcre:regex-replace "https://" (location source) "https://"))) (format nil "https ~A" location))) (defun rewrite-sources (match-fun new-source-fun) + "Rewrite any source that returns TRUE from MATCH-FUN with +NEW-SOURCE-FUN, which should return a single line for use in the +source's source.txt file. Useful for bulk-updating sources." (map-sources (lambda (source) (when (funcall match-fun source) @@ -544,3 +564,34 @@ (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))))) + +;;; 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/quicklisp-controller.asd b/quicklisp-controller.asd index 5bfde62..5bba6db 100644 --- a/quicklisp-controller.asd +++ b/quicklisp-controller.asd @@ -12,17 +12,16 @@ #:drakma #:yason #:function-cache - #:trivial-utf-8 + #:trivial-utf-8 #:ironclad #:lparallel - #:cl-who - #:ubiquitous + #: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") @@ -30,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") @@ -39,6 +38,7 @@ (:file "upstream-darcs") (:file "upstream-git") (:file "upstream-github") + (:file "upstream-gitlab") (:file "upstream-mercurial") (:file "upstream-svn") (:file "upstream-bzr") @@ -52,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/recrank.lisp b/recrank.lisp index 793417f..c37b064 100644 --- a/recrank.lisp +++ b/recrank.lisp @@ -8,6 +8,7 @@ (file #p"quicklisp:tmp;update-failures.txt")) (clear-fasl-cache) (preflight) + (clear-dist-caches) (when update (update-what-you-can :file file :parallel parallel) (when (and file *report-to-email*) @@ -16,9 +17,6 @@ :subject "Quicklisp update failures" :from *report-to-email* :to *report-to-email*)))) - (run "rm" "-rf" - (native-namestring - (translate-logical-pathname #p"quicklisp-controller:dist;"))) (ensure-what-wins-you-can) (when report (with-skipping 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/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) 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 3644494..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))) @@ -63,16 +71,63 @@ (:method ((source git-at-commit-source)) (format nil "~A" (commit source)))) +(defstruct (submodule (:type vector)) + name + path + sha1) + +(defun git-submodules (git-path) + (loop for line in + (run-output-lines "git" "-C" (truename git-path) "submodule" + "--quiet" + "foreach" + "--recursive" + "echo $name $sha1 $displaypath") + for (name sha1 path) = (split-spaces line) + 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 +git checkout GIT-PATH, including submodules. The repo is archived at +TARGET-REF, e.g. 'HEAD'. " + (run "git" "-C" (truename git-path) + "submodule" "update" "--init" "--recursive") + (let ((submodules (git-submodules git-path))) + (in-temporary-directory prefix + (let* ((temp-base *default-pathname-defaults*)) + (with-posix-cwd git-path + (run "git" "archive" + :format "tar" + :prefix (format nil "~A/" prefix) + "-o" (make-pathname :name (string-right-trim "/" prefix) + :type "tar" + :defaults temp-base) + target-ref) + (dolist (submodule submodules) + (with-posix-cwd (submodule-path submodule) + (let ((output (make-pathname :name (submodule-name submodule) + :type "tar" + :defaults temp-base))) + (run "git" "archive" + :format "tar" + "-o" output + :prefix (format nil "~A/~A/" + prefix (submodule-path submodule)) + (submodule-sha1 submodule)))))) + ;; Back in the temp directory + (dolist (tarball (directory "*.tar")) + (run "tar" "xf" tarball)) + (let ((combined "combined.tar") + (combined-tgz "combined.tar.gz")) + (run "tar" "cf" combined prefix) + (run "gzip" "-vn9" "-S" ".gz" combined) + (rename-file combined-tgz output-file)) + output-file)))) + (defmethod make-release-tarball ((source git-source) output-file) (let ((prefix (release-tarball-prefix source)) (checkout (ensure-source-cache source))) - (in-temporary-directory prefix - (let ((temptar (merge-pathnames "package.tar")) - (tempgz (merge-pathnames "package.tar.gz"))) - (with-posix-cwd checkout - (with-binary-run-output temptar - (run "git" "archive" :format "tar" :prefix prefix - (target-ref source))) - (run "gzip" "-vn9" temptar) - (copy tempgz output-file)))))) + (full-git-archive checkout (target-ref source) prefix output-file))) diff --git a/upstream-github.lisp b/upstream-github.lisp index b24c220..0633209 100644 --- a/upstream-github.lisp +++ b/upstream-github.lisp @@ -28,13 +28,15 @@ :tag (githappy:jref json '(0 "name")))))) -(defclass latest-github-release-source (http-source) +(defclass latest-github-release-source (git-source) ((release-url :initarg :release-url :accessor release-url) (release-tag :initarg :release-tag - :accessor release-tag))) + :accessor release-tag + :reader tag-data + :reader target-ref))) (defclass latest-github-tag-source (latest-github-release-source) ()) @@ -69,10 +71,7 @@ (defmethod release-tarball-prefix ((source latest-github-release-source)) (format nil "~A-~A/" (name source) (release-tag source))) -(defmethod create-source-cache ((source latest-github-release-source)) - (let ((cached (cache-object-file source))) - (ensure-directories-exist cached) - (curl (release-url source) cached) - (repack cached (release-tarball-prefix source) cached) - (probe-file cached))) - +(defmethod parse-location ((source latest-github-release-source) + location-string) + (setf (location source) location-string) + source) 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))) diff --git a/upstream-http.lisp b/upstream-http.lisp index f7e1990..35176a1 100644 --- a/upstream-http.lisp +++ b/upstream-http.lisp @@ -22,7 +22,11 @@ (merge-logical (format nil "~A/~A.dat" (project-name source) (string-digest (location source))) - "quicklisp-controller:http-cache;")) + "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)) @@ -77,7 +81,7 @@ (with-binary-run-output "temp.dat" (run "bunzip2" "-c" "temp.bz2")) (run "gzip" "temp.dat") - (rename-file "temp.dat.gz" cached)) + (alexandria:copy-file "temp.dat.gz" cached)) (probe-file cached))) (defmethod update-source-cache ((source http-source)) diff --git a/upstream-vcs.lisp b/upstream-vcs.lisp index c4e53aa..630d36c 100644 --- a/upstream-vcs.lisp +++ b/upstream-vcs.lisp @@ -79,7 +79,7 @@ (merge-logical (format nil "~A/~A/" (project-name source) (string-digest (location source))) - "quicklisp-controller:vcs-cache;"))) + "quicklisp-controller:upstream-cache;vcs;"))) (defmethod ensure-source-cache ((source vcs-source)) (let ((pathname (cached-checkout-directory source))) @@ -96,6 +96,8 @@ (probe-file pathname))) + + ;;; Tags of some sort (defclass tagged-mixin () diff --git a/upstream.lisp b/upstream.lisp index c75a0a1..cb517ae 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" @@ -78,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. ;;; @@ -146,8 +171,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 +212,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 +250,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)) diff --git a/utils.lisp b/utils.lisp index 2579820..50fb8b1 100644 --- a/utils.lisp +++ b/utils.lisp @@ -42,7 +42,7 @@ (defun rm-rf (path) (unless *rm-rf-debug* - (run "rm" "-rf" (native path)))) + (run "rm" "-rf" (native (translate-logical-pathname path))))) (defun call-in-temporary-directory (template-pathname fun) (flet ((random-temporary () @@ -176,19 +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 ((prefix (subseq (first contents) 0 - (1+ (position #\/ (first contents)))))) - (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))) @@ -288,3 +290,42 @@ template pathname." (#\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))))))) + + +(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)))))