diff --git a/dist-cache.lisp b/dist-cache.lisp index 3b2ce1b..9cc7207 100644 --- a/dist-cache.lisp +++ b/dist-cache.lisp @@ -261,6 +261,10 @@ if needed." (ensure-system-file-index) (ignore-errors (system-file-systems system-name))) +(defun system-nonblacklisted-systems (source system-name) + (remove-if (lambda (system-name) (blacklistedp source system-name)) + (system-defined-systems system-name))) + (defun find-fake-winning-systems (source) (let ((fake-wins (relative-to source "wins.txt")) (*read-eval* nil)) @@ -366,6 +370,14 @@ their name does not match the system file name." (unless (blacklistedp source system) (funcall fun system-file-name system)))))) +(defun collect-source-systems (source) + (ensure-system-file-index) + (setf source (source-designator source)) + (with-system-index + (loop + for system-file-name in (system-names source) + appending (system-nonblacklisted-systems source system-file-name)))) + (defun acceptable-system-name (name) (declare (ignore name)) t) diff --git a/misc.lisp b/misc.lisp index 8cd5d05..9d12817 100644 --- a/misc.lisp +++ b/misc.lisp @@ -526,3 +526,73 @@ (when new-source (setf (first-line (source-file source)) new-source))))))) + +;;; write metadata.sexp files + +(defun compute-system-deps (system) + (getf (cdr system) :depends-on)) +(defun compute-source-deps (source) + (reduce #'union (mapcar #'compute-system-deps + (cdr source)))) +(defun compute-deps (sources) + (let ((requires (reduce #'union + (mapcar #'compute-source-deps + sources))) + (provides (mapcar #'car sources))) + (set-difference requires provides :test #'equal))) + +(defun write-metadata-sexps () + (ensure-system-file-index) + (with-skipping + (map-sources + (lambda (source) + (format t "mapping over the system files in source ~A~%" source) + (dolist (system-file-name (system-names source)) + (let ((metadata-file (make-pathname :defaults (source-file source) + :name (format nil "~A.metadata" system-file-name) + :type "sexp")) + (system-name (car (last (system-nonblacklisted-systems source system-file-name))))) + (when system-name + (format t "writing system metadata to ~A~%" metadata-file) + (system-file-magic system-name + (project-name source) + metadata-file)))) + (flet ((trim-prefix (file) + (subseq file (1+ (position #\/ file))))) + (let ((metadata-file (make-pathname :defaults (source-file source) + :name "metadata" + :type "sexp"))) + (with-open-file (stream metadata-file :direction :output :if-exists :supersede) + (let* ((tarball (ensure-cached-release-tarball source)) + (project-name (project-name source)) + (url (format nil "http://~A/archive/~A/~A/~A" + *s3-bucket* + project-name + (dist-string (file-write-date tarball)) + (file-namestring tarball))) + (system-files (system-names source)) + (systems (loop + for system-file-name in system-files + collecting (cons system-file-name + (read (open (make-pathname :defaults metadata-file + :name (format nil "~A.metadata" system-file-name) + :type "sexp")))))) + (primary-system-file-metadata (cdr (assoc project-name systems :test #'equal))) + (primary-system-metadata (cdr (assoc project-name primary-system-file-metadata :test #'equal)))) + (format t "writing project metadata to ~A~%" metadata-file) + (pprint (list :project project-name + :description (getf primary-system-metadata :description) + :long-description (getf primary-system-metadata :long-description) + :license (getf primary-system-metadata :license) + :author (getf primary-system-metadata :author) + :homepage (getf primary-system-metadata :homepage) + :bug-tracker (getf primary-system-metadata :bug-tracker) + :depends-on (compute-deps systems) + :release-url url + :size (file-size tarball) + :file-md5 (file-md5 tarball) + :file-sha256 (file-sha256 tarball) + :file-content-sha1 (first (last (pathname-directory tarball))) + :system-files system-files + :systems systems) + stream))))))))) diff --git a/system-file-magic.lisp b/system-file-magic.lisp index a3f283b..ad95df3 100644 --- a/system-file-magic.lisp +++ b/system-file-magic.lisp @@ -50,19 +50,19 @@ :homepage (asdf:system-homepage system) :bug-tracker (asdf:system-bug-tracker system))) -(defun save-system-metadata (system-name project-name file) +(defun save-system-metadata (system-names project-name file) (ensure-directories-exist file) - (let* ((system (asdf:find-system system-name)) - (sexp (ignore-errors (system-metadata-sexp system project-name))) - (*print-pretty* nil) - (*print-escape* nil) - (*package* (find-package :cl))) - (when sexp - (with-open-file (stream file :direction :output - :if-exists :rename-and-delete - :if-does-not-exist :create) - (format stream "~S~%~%" - sexp))))) + (with-open-file (stream file :direction :output + :if-exists :rename-and-delete + :if-does-not-exist :create) + (let ((*package* (find-package :cl))) + (pprint (loop + for system-name in system-names + collecting (cons system-name + (ignore-errors + (system-metadata-sexp (asdf:find-system system-name) + project-name)))) + stream)))) (defun main (argv) (setf *package* (find-package :keyword)) @@ -83,9 +83,9 @@ :direction :output :if-exists :supersede) (let ((broadcast (make-broadcast-stream stream *standard-output*)) - (system-names (system-file-systems system-name))) + (system-names (reverse (system-file-systems system-name)))) (when description-file - (save-system-metadata system-name project-name description-file)) + (save-system-metadata system-names project-name description-file)) (format broadcast "~A~{ ~A~}~%" system-name system-names))))) diff --git a/utils.lisp b/utils.lisp index 894332a..dac52a2 100644 --- a/utils.lisp +++ b/utils.lisp @@ -244,6 +244,10 @@ template pathname." (ironclad:byte-array-to-hex-string (ironclad:digest-file :md5 file))) +(defun file-sha256 (file) + (ironclad:byte-array-to-hex-string + (ironclad:digest-file :sha256 file))) + (defun dist-string (&optional (timestamp (get-universal-time))) (multiple-value-bind (second minute hour day month year) (decode-universal-time timestamp 0)