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 ++++++++++++++++++++++-------- src/image.lisp | 140 +++++++++++++++++++++-------------------------------- src/package.lisp | 4 +- 3 files changed, 119 insertions(+), 104 deletions(-) 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)))))) diff --git a/src/image.lisp b/src/image.lisp index c3f1884..6f94037 100644 --- a/src/image.lisp +++ b/src/image.lisp @@ -290,26 +290,20 @@ Called by connection types which start up remote Lisp images." (requirements (make-instance 'asdf-requirements))) (with-slots (asdf-requirements) requirements (dolist (system (propspec-systems (host-propspec *host*))) + ;; This call to ASDF:REQUIRED-COMPONENTS seems to get us everything, + ;; but see the warning in the comment attached to the call to + ;; ASDF:REQUIRED-COMPONENTS in the (defmethod component-depends-on ((o + ;; gather-operation) (s system))) implementation in ASDF's source. (dolist (requirement - ;; This call to ASDF:REQUIRED-COMPONENTS is based on one in - ;; the definition of the ASDF:COMPONENT-DEPENDS-ON generic - ;; for ((o gather-operation) (s system)). We use - ;; ASDF:COMPILE-OP as the :KEEP-OPERATION because - ;; ASDF::BASIC-COMPILE-OP is not exported, so this won't work - ;; for certain exotic systems. See the comment in ASDF source. - ;; - ;; TODO Can we detect when this won't work and fail, possibly - ;; falling back to ASDF:MONOLITHIC-CONCATENATE-SOURCE-OP? (asdf:required-components (asdf:find-system system) - :other-systems t :component-type 'asdf:system - :keep-component 'asdf:system :goal-operation 'asdf:load-op - :keep-operation 'asdf:compile-op)) - ;; Handle UIOP specially because it comes with ASDF. - (unless (string= "uiop" (asdf:component-name requirement)) - ;; What we really want instead of PUSHNEW here is a proper - ;; topological sort. - (pushnew requirement asdf-requirements)))) + :other-systems t :keep-component 'asdf:system + :goal-operation 'asdf:monolithic-compile-bundle-op)) + (let ((name (asdf:component-name requirement))) + ;; Handle UIOP specially because it comes with ASDF. + (unless + (memstring= (asdf:primary-system-name name) '("asdf" "uiop")) + (pushnew requirement asdf-requirements))))) (nreversef asdf-requirements)) requirements)) @@ -325,67 +319,57 @@ Called by connection types which start up remote Lisp images.") when (and (subtypep type 'asdf:system) (not (subtypep type 'asdf:require-system))) do (require-data "--lisp-system" - (asdf:component-name requirement))))) + (asdf:primary-system-name requirement))))) (defgeneric asdf-requirements-load-form (asdf-requirements) (:documentation - "Return form to (compile and) load each of the Lisp systems specified in + "Return form to unpack and load each of the Lisp systems specified in ASDF-REQUIREMENTS, after having uploaded those Lisp systems using UPLOAD-ALL-PREREQUISITE-DATA.") (:method ((asdf-requirements asdf-requirements)) - ;; As soon as we recompile something, we have to recompile everything else - ;; following it in the list, because macro definitions may have changed. - `(let* (recompile - (file (merge-pathnames "consfigurator/fasls" - (ensure-directory-pathname - (or (getenv "XDG_CACHE_HOME") - (strcat (getenv "HOME") "/.cache"))))) - (record (with-open-file (stream file :if-does-not-exist nil) - (and stream (safe-read-from-string - (slurp-stream-string stream)))))) - (unwind-protect - (progn - ,@(loop - with table = (get-connattr 'cached-data) - for requirement - in (slot-value asdf-requirements 'asdf-requirements) - for name = (asdf:component-name requirement) - collect - (etypecase requirement - (asdf:require-system `(require ,name)) - (asdf:system - (let ((source - (gethash (cons "--lisp-system" name) table))) - (unless source - (error "Somehow Lisp system ~A was not uploaded." - name)) - ;; Using COMPILE-FILE-PATHNAME* like this has the - ;; advantage that, for example, SBCL will save the FASL - ;; somewhere from which only the same version of SBCL - ;; will try to load FASLs. - `(let ((fasl (compile-file-pathname* ,source))) - (if (and (file-exists-p fasl) (not recompile)) - (load fasl) - ;; The concatenated source of at least - ;; Alexandria won't compile unless it's loaded - ;; first. This means we compile every library - ;; that's changed since the last deploy twice, - ;; which is not ideal. One possible improvement - ;; would be to maintain a list of systems known - ;; not to have this problem, such as - ;; Consfigurator, and switch the order of the - ;; LOAD and COMPILE-FILE* here for those. - (let ((pair (assoc ,source record))) - (load ,source) - (or (compile-file* ,source) - (error "Failed to compile ~S" ,source)) - (if pair - (rplacd pair fasl) - (setq record (acons ,source fasl record))) - (setq recompile t))))))))) - (with-open-file (stream file :direction :output :if-exists :supersede) - (with-standard-io-syntax - (prin1 record stream))))))) + `(progn + (let* ((cache (ensure-directory-pathname + (or (getenv "XDG_CONFIG_HOME") + (strcat (getenv "HOME") "/.cache")))) + (dest (ensure-directories-exist + (merge-pathnames "consfigurator/systems/" cache))) + (file (merge-pathnames + "consfigurator/extracted-systems" cache)) + (record (and (file-exists-p file) + (safe-read-file-form file)))) + (unwind-protect + (with-current-directory (dest) + ,@(loop + for (iden1 . system) being the hash-keys + in (get-connattr 'cached-data) using (hash-value tarball) + for version = (parse-integer (pathname-name tarball)) + and system* = (ensure-directory-pathname system) + when (string= "--lisp-system" iden1) + collect + `(let ((pair (assoc ,system record :test #'string=))) + (unless (and pair (>= (cdr pair) ,version)) + (when (directory-exists-p ,system*) + (delete-directory-tree + ,system* + :validate + (lambda (dir) + (and (relative-pathname-p dir) + (not (search ".." (unix-namestring dir))))))) + (run-program + (list "tar" "-C" (ensure-directories-exist + ,(unix-namestring system*)) + "-xzf" ,(unix-namestring tarball))) + (if pair + (rplacd pair ,version) + (setq record (acons ,system ,version record))))))) + (with-open-file (stream file :direction :output + :if-exists :supersede) + (with-standard-io-syntax (prin1 record stream)))) + (asdf:clear-source-registry) + (asdf:initialize-source-registry + `(:source-registry (:tree ,dest) :ignore-inherited-configuration))) + ,@(loop for system in (propspec-systems (host-propspec *host*)) + collect `(asdf:load-system ,system))))) (defgeneric continue-deploy*-program (remaining-connections asdf-requirements) (:documentation @@ -460,18 +444,6 @@ Preprocessing must occur in the root Lisp.")) (uiop:quit 3))) (when (>= *consfigurator-debug-level* 3) (format t "~&~A" string)))) - ;; Delete old FASLs. With SBCL they are megabytes in size. - (with-lisp-data-file - (record (merge-pathnames - "consfigurator/fasls" - (ensure-directory-pathname - (or (getenv "XDG_CACHE_HOME") - (strcat (getenv "HOME") "/.cache"))))) - (loop for cell in record - if (file-exists-p (car cell)) - collect cell into accum - else do (ignore-errors (delete-file (cdr cell))) - finally (setq record accum))) ;; Continue the deployment. The READ indirection is to try ;; to ensure that the fork control child does not end up with ;; information about the deployment in its memory. diff --git a/src/package.lisp b/src/package.lisp index c172460..adb6182 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -26,6 +26,7 @@ #:enough-pathname #:pathname-equal #:subpathp + #:relative-pathname-p #:getenv #:subdirectories #:directory-files @@ -63,6 +64,7 @@ #:enough-pathname #:pathname-equal #:subpathp + #:relative-pathname-p #:getenv #:subdirectories #:directory-files @@ -867,7 +869,7 @@ (#:user #:consfigurator.property.user))) (defpackage :consfigurator.data.asdf - (:use #:cl #:consfigurator)) + (:use #:cl #:alexandria #:consfigurator)) (defpackage :consfigurator.data.pgp (:use #:cl #:consfigurator #:alexandria) -- cgit v1.2.3