From e4a27593009b650b7f7b17cd8775997fedb1fffa Mon Sep 17 00:00:00 2001 From: Sean Whitton Date: Mon, 26 Jul 2021 11:46:17 -0700 Subject: upload Lisp systems as tarballs, not concatenated source This should enable depending on Lisp systems which use the CFFI Groveller. Signed-off-by: Sean Whitton --- src/data/asdf.lisp | 79 +++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 60 insertions(+), 19 deletions(-) (limited to 'src/data') diff --git a/src/data/asdf.lisp b/src/data/asdf.lisp index a681bb1..83142c0 100644 --- a/src/data/asdf.lisp +++ b/src/data/asdf.lisp @@ -19,26 +19,67 @@ (named-readtables:in-readtable :consfigurator) (defmethod register-data-source ((type (eql :asdf)) &key) - (cons #'asdf-data-source-check #'get-path-to-concatenated-system)) + (cons #'asdf-data-source-check #'get-path-to-system-tarball)) (defun asdf-data-source-check (iden1 system) (let ((system (and (string= iden1 "--lisp-system") (asdf:find-system system nil)))) - (and system (system-version system)))) - -(defun get-path-to-concatenated-system (iden1 system) - "Try to concatenate all the source code for SYSTEM, store it somewhere and -return the filename." - (let ((op 'asdf:concatenate-source-op) - (co (asdf:find-component system nil))) - (asdf:operate op co) - (make-instance 'file-data :file (asdf:output-file op co) - :mime "text/plain" - :iden1 iden1 - :iden2 system - :version (system-version co)))) - -(defun system-version (system) - (reduce #'max - (mapcar #'file-write-date - (asdf:input-files 'asdf:concatenate-source-op system)))) + (and system (system-version-files system)))) + +(defun get-path-to-system-tarball (iden1 system) + (let* ((tarball (merge-pathnames + (strcat "consfigurator/systems/" system ".tar.gz") + (ensure-directory-pathname + (or (getenv "XDG_CACHE_HOME") + (strcat (getenv "HOME") "/.cache"))))) + (tarball-write-date + (and (file-exists-p tarball) (file-write-date tarball)))) + (multiple-value-bind (version files) (system-version-files system) + (if (and tarball-write-date (>= tarball-write-date version)) + (setq version tarball-write-date) + (let* ((dir (asdf:system-source-directory system)) + (relative + (loop for file in files + if (subpathp file dir) + collect (unix-namestring + (enough-pathname file dir)) + else + do (error "~A is not a subpath of ~A." file dir)))) + (run-program + (list* "tar" "-C" (unix-namestring dir) + "-czf" (unix-namestring (ensure-directories-exist tarball)) + relative)))) + (make-instance 'file-data :file tarball :mime "application/gzip" + :iden1 iden1 :iden2 system :version version)))) + +(defun system-version-files (system) + (let* ((system (asdf:find-system system)) + (name (asdf:component-name system)) + (file (asdf:system-source-file system)) + (written (file-write-date file))) + (unless (string= (pathname-name file) name) + (error "Cannot upload secondary systems directly.")) + (labels ((recurse (component) + (let ((pathname (asdf:component-pathname component)) + (rest (and (compute-applicable-methods + #'asdf:component-children (list component)) + (mapcan #'recurse + (asdf:component-children component))))) + (if (and pathname (file-exists-p pathname)) + (progn (maxf written (file-write-date pathname)) + (cons pathname rest)) + rest)))) + ;; We include secondary systems because otherwise, for systems using the + ;; package-inferred-system extension, we could end up uploading a huge + ;; number of tarballs. We need to ensure SYSTEM is loaded so that all + ;; the secondary systems are known to ASDF. + (asdf:load-system system) + (let ((files + (nconc + (recurse system) + (loop for other in (asdf:registered-systems) + for other* = (asdf:find-system other) + when (and (not (eql system other*)) + (string= name (asdf:primary-system-name other*))) + nconc (recurse other*))))) + (values written (cons file files)))))) -- cgit v1.2.3