362 lines
14 KiB
Common Lisp
362 lines
14 KiB
Common Lisp
;;;; bundle.lisp
|
|
|
|
(in-package #:ql-bundle)
|
|
|
|
;;; Bundling is taking a set of Quicklisp-provided systems and
|
|
;;; creating a directory structure and metadata in which those systems
|
|
;;; can be loaded without involving Quicklisp.
|
|
;;;
|
|
;;; This works for systems provided directly Quicklisp, or systems in
|
|
;;; the Quicklisp local-projects directories (if
|
|
;;; :include-local-projects is specified).
|
|
|
|
(defgeneric find-system (system bundle))
|
|
(defgeneric add-system (system bundle))
|
|
(defgeneric ensure-system (system bundle))
|
|
|
|
(defgeneric find-release (relase bundle))
|
|
(defgeneric add-release (release bundle))
|
|
(defgeneric ensure-release (release bundle))
|
|
|
|
(defgeneric write-loader-script (bundle stream))
|
|
(defgeneric write-system-index (bundle stream))
|
|
|
|
(defgeneric unpack-release (release target))
|
|
(defgeneric unpack-releases (bundle target))
|
|
|
|
(defgeneric write-bundle (bundle target))
|
|
|
|
(defvar *ignored-systems*
|
|
(list "asdf")
|
|
"Systems that might appear in depends-on lists in Quicklisp, but
|
|
which can't be bundled.")
|
|
|
|
(defvar *bundle-progress-output*
|
|
(make-synonym-stream '*trace-output*)
|
|
"Informative output related to creating the bundle is sent to this
|
|
stream.")
|
|
|
|
;;; Implementation
|
|
|
|
;;; Conditions
|
|
|
|
(define-condition bundle-error (error) ())
|
|
|
|
(define-condition object-not-found (bundle-error)
|
|
((name
|
|
:initarg :name
|
|
:reader object-not-found-name)
|
|
(type
|
|
:initarg :type
|
|
:reader object-not-found-type))
|
|
(:report
|
|
(lambda (condition stream)
|
|
(format stream "~A ~S not found"
|
|
(object-not-found-type condition)
|
|
(object-not-found-name condition))))
|
|
(:default-initargs
|
|
:type "Object"))
|
|
|
|
(define-condition system-not-found (object-not-found)
|
|
((name
|
|
:reader system-not-found-system))
|
|
(:default-initargs
|
|
:type "System"))
|
|
|
|
(define-condition release-not-found (object-not-found)
|
|
()
|
|
(:default-initargs
|
|
:type "Release"))
|
|
|
|
(define-condition bundle-directory-exists (bundle-error)
|
|
((directory
|
|
:initarg :directory
|
|
:reader bundle-directory-exists-directory))
|
|
(:report
|
|
(lambda (condition stream)
|
|
(format stream "Bundle directory ~A already exists"
|
|
(bundle-directory-exists-directory condition)))))
|
|
|
|
|
|
(defun iso8601-time-stamp (&optional (time (get-universal-time)))
|
|
(multiple-value-bind (second minute hour day month year)
|
|
(decode-universal-time time 0)
|
|
(format nil "~4,'0D-~2,'0D-~2,'0DT~
|
|
~2,'0D:~2,'0D:~2,'0DZ"
|
|
year month day
|
|
hour minute second)))
|
|
|
|
|
|
(defclass bundle ()
|
|
((requested-systems
|
|
:initarg :requested-systems
|
|
:reader requested-systems
|
|
:documentation "Names of the systems requested directly for
|
|
bundling.")
|
|
(creation-time
|
|
:initarg :creation-time
|
|
:reader creation-time)
|
|
(release-table
|
|
:initarg :release-table
|
|
:reader release-table)
|
|
(system-table
|
|
:initarg :system-table
|
|
:reader system-table))
|
|
(:default-initargs
|
|
:requested-systems nil
|
|
:creation-time (iso8601-time-stamp)
|
|
:release-table (make-hash-table :test 'equalp)
|
|
:system-table (make-hash-table :test 'equalp)))
|
|
|
|
(defmethod print-object ((bundle bundle) stream)
|
|
(print-unreadable-object (bundle stream :type t)
|
|
(format stream "~D release~:P, ~D system~:P"
|
|
(hash-table-count (release-table bundle))
|
|
(hash-table-count (system-table bundle)))))
|
|
|
|
(defmethod provided-releases ((bundle bundle))
|
|
(let ((releases '()))
|
|
(maphash (lambda (name release)
|
|
(declare (ignore name))
|
|
(push release releases))
|
|
(release-table bundle))
|
|
(sort releases 'string< :key 'name)))
|
|
|
|
(defmethod provided-systems ((bundle bundle))
|
|
(sort (mapcan #'provided-systems (provided-releases bundle))
|
|
'string<
|
|
:key 'name))
|
|
|
|
(defmethod find-system (name (bundle bundle))
|
|
(values (gethash name (system-table bundle))))
|
|
|
|
(defmethod add-system (name (bundle bundle))
|
|
(let ((system (ql-dist:find-system name)))
|
|
(unless system
|
|
(error 'system-not-found
|
|
:name name))
|
|
(ensure-release (name (release system)) bundle)
|
|
system))
|
|
|
|
(defmethod ensure-system (name (bundle bundle))
|
|
(or (find-system name bundle)
|
|
(add-system name bundle)))
|
|
|
|
(defmethod find-release (name (bundle bundle))
|
|
(values (gethash name (release-table bundle))))
|
|
|
|
(defmethod add-release (name (bundle bundle))
|
|
(let ((release (ql-dist:find-release name)))
|
|
(unless release
|
|
(error 'release-not-found
|
|
:name name))
|
|
(setf (gethash (name release) (release-table bundle)) release)
|
|
(let ((system-table (system-table bundle)))
|
|
(dolist (system (provided-systems release))
|
|
(setf (gethash (name system) system-table) system)))
|
|
release))
|
|
|
|
(defmethod ensure-release (name (bundle bundle))
|
|
(or (find-release name bundle)
|
|
(add-release name bundle)))
|
|
|
|
|
|
(defun add-systems-recursively (names bundle)
|
|
(with-consistent-dists
|
|
(labels ((add-one (name)
|
|
(unless (member name *ignored-systems* :test 'equalp)
|
|
(let ((system
|
|
(restart-case
|
|
(ensure-system name bundle)
|
|
(omit ()
|
|
:report "Ignore this system and omit it from the bundle."))))
|
|
(when system
|
|
(dolist (required-system-name (required-systems system))
|
|
(add-one required-system-name)))))))
|
|
(map nil #'add-one names)))
|
|
bundle)
|
|
|
|
|
|
(defmethod unpack-release (release target)
|
|
(let ((*default-pathname-defaults* (truename
|
|
(ensure-directories-exist target)))
|
|
(archive (ensure-local-archive-file release))
|
|
(temp-tar (ensure-directories-exist
|
|
(ql-setup:qmerge "tmp/bundle.tar"))))
|
|
(ql-gunzipper:gunzip archive temp-tar)
|
|
(ql-minitar:unpack-tarball temp-tar :directory "software/")
|
|
(delete-file temp-tar)
|
|
release))
|
|
|
|
(defmethod unpack-releases ((bundle bundle) target)
|
|
(dolist (release (provided-releases bundle))
|
|
(unpack-release release target))
|
|
bundle)
|
|
|
|
(defmethod write-system-index ((bundle bundle) stream)
|
|
(dolist (release (provided-releases bundle))
|
|
;; Working with strings, here, intentionally not with pathnames
|
|
(let ((prefix (concatenate 'string "software/" (prefix release))))
|
|
(dolist (system-file (system-files release))
|
|
(format stream "~A/~A~%" prefix system-file)))))
|
|
|
|
(defmethod write-loader-script ((bundle bundle) stream)
|
|
(let ((template-lines
|
|
(load-time-value
|
|
(with-open-file (stream #. (merge-pathnames "bundle-template"
|
|
(or *compile-file-truename*
|
|
*load-truename*)))
|
|
(loop for line = (read-line stream nil)
|
|
while line collect line)))))
|
|
(dolist (line template-lines)
|
|
(write-line line stream))))
|
|
|
|
(defun coerce-to-directory (pathname)
|
|
;; Cribbed from quicklisp-bootstrap/quicklisp.lisp
|
|
(let ((name (file-namestring pathname)))
|
|
(if (or (null name)
|
|
(equal name ""))
|
|
pathname
|
|
(make-pathname :defaults pathname
|
|
:name nil
|
|
:type nil
|
|
:directory (append (pathname-directory pathname)
|
|
(list name))))))
|
|
|
|
(defun bundle-metadata-plist (bundle)
|
|
(list :creation-time (creation-time bundle)
|
|
:requested-systems (requested-systems bundle)
|
|
:lisp-info (list :machine-instance (machine-instance)
|
|
:machine-type (machine-type)
|
|
:machine-version (machine-version)
|
|
:lisp-implementation-type (lisp-implementation-type)
|
|
:lisp-implementation-version (lisp-implementation-version))
|
|
:quicklisp-info (list :home (namestring ql:*quicklisp-home*)
|
|
:local-project-directories
|
|
(mapcar 'namestring ql:*local-project-directories*)
|
|
:dists
|
|
(loop for dist in (enabled-dists)
|
|
collect (list :name (name dist)
|
|
:dist-url
|
|
(canonical-distinfo-url dist)
|
|
:version (version dist))))))
|
|
|
|
(defmethod write-bundle ((bundle bundle) target)
|
|
(unpack-releases bundle target)
|
|
(let ((index-file (merge-pathnames "system-index.txt" target))
|
|
(loader-file (merge-pathnames "bundle.lisp" target))
|
|
(local-projects (merge-pathnames "local-projects/" target))
|
|
(metadata-file (merge-pathnames "bundle-info.sexp" target)))
|
|
(ensure-directories-exist local-projects)
|
|
(with-open-file (stream index-file :direction :output
|
|
:if-exists :supersede)
|
|
(write-system-index bundle stream))
|
|
(with-open-file (stream loader-file :direction :output
|
|
:if-exists :supersede)
|
|
(write-loader-script bundle stream))
|
|
(with-open-file (stream metadata-file :direction :output
|
|
:if-exists :supersede)
|
|
(with-standard-io-syntax
|
|
(let ((*print-pretty* t))
|
|
(prin1 (bundle-metadata-plist bundle) stream)
|
|
(terpri stream))))
|
|
(probe-file loader-file)))
|
|
|
|
|
|
(defun copy-file (from-file to-file)
|
|
(with-open-file (from-stream from-file :element-type '(unsigned-byte 8)
|
|
:if-does-not-exist nil)
|
|
(when from-stream
|
|
(let ((buffer (make-array 10000 :element-type '(unsigned-byte 8))))
|
|
(with-open-file (to-stream to-file
|
|
:direction :output
|
|
:if-exists :supersede
|
|
:element-type '(unsigned-byte 8))
|
|
(loop
|
|
(let ((end-index (read-sequence buffer from-stream)))
|
|
(when (zerop end-index)
|
|
(return to-file))
|
|
(write-sequence buffer to-stream :end end-index))))))))
|
|
|
|
(defun copy-directory-tree (from-directory to-directory)
|
|
;; Use the truename here to ensure that relative pathnames match up
|
|
;; properly. For example, on SBCL, "~/foo/bar/" entries are not
|
|
;; relative to "/home/baz/foo/bar/" entries.
|
|
(setf from-directory (truename from-directory))
|
|
(map-directory-tree
|
|
from-directory
|
|
(lambda (from-pathname)
|
|
(when (probe-file from-pathname)
|
|
(let* ((relative (enough-namestring from-pathname from-directory))
|
|
(relative-directory (pathname-directory relative))
|
|
(to-pathname (merge-pathnames relative to-directory)))
|
|
(unless (or (null relative-directory)
|
|
(eql (first relative-directory)
|
|
:relative))
|
|
(error "Expected relative pathname to copy from ~A ~
|
|
- bad symlink? - ~S"
|
|
from-pathname
|
|
relative))
|
|
(ensure-directories-exist to-pathname)
|
|
(copy-file from-pathname to-pathname))))))
|
|
|
|
(defun copy-local-projects-directories (local-projects-directories
|
|
to-directory)
|
|
"Copy the local-projects directories to TO-DIRECTORY. Each one gets
|
|
a distinct subdirectory."
|
|
(loop for prefix from 0
|
|
for prefix-directory = (make-pathname :directory
|
|
(list :relative
|
|
(format nil "~4,'0X" prefix)))
|
|
for from-directory in local-projects-directories
|
|
for real-to-directory = (merge-pathnames prefix-directory to-directory)
|
|
do
|
|
(format *bundle-progress-output*
|
|
"~&; Copying ~A to bundle..." from-directory )
|
|
(force-output *bundle-progress-output*)
|
|
(ensure-directories-exist real-to-directory)
|
|
(copy-directory-tree from-directory real-to-directory)
|
|
(format *bundle-progress-output* "done.~%")
|
|
(force-output *bundle-progress-output*)))
|
|
|
|
|
|
(defun ql:bundle-systems (system-names
|
|
&key include-local-projects to (overwrite t))
|
|
"In the directory TO, construct a self-contained bundle of libraries
|
|
based on SYSTEM-NAMES. For each system named, and its recursive
|
|
required systems, unpack its release archive in TO/software/, and
|
|
write a system index, compatible with the output of
|
|
QL:WRITE-ASDF-MANIFEST-FILE, to TO/system-index.txt. Write a loader
|
|
script to TO/bundle.lisp that, when loaded via CL:LOAD, configures
|
|
ASDF to load systems from the bundle before any other system.
|
|
|
|
SYSTEM-NAMES must name systems provided directly by Quicklisp.
|
|
|
|
If INCLUDE-LOCAL-PROJECTS is true, each directory in
|
|
QL:*LOCAL-PROJECT-DIRECTORIES* is copied into the bundle and loaded
|
|
before any of the other bundled systems."
|
|
(unless to
|
|
(error "TO argument must be provided"))
|
|
(let* ((bundle (make-instance 'bundle
|
|
:requested-systems system-names))
|
|
(to (coerce-to-directory to))
|
|
(software (merge-pathnames "software/" to)))
|
|
(when (and (probe-directory to)
|
|
(not overwrite))
|
|
(cerror "Overwrite it"
|
|
'bundle-directory-exists
|
|
:directory to))
|
|
(when (probe-directory software)
|
|
(delete-directory-tree software))
|
|
(add-systems-recursively system-names bundle)
|
|
(let ((bundled-local-projects (merge-pathnames "bundled-local-projects/"
|
|
to)))
|
|
(when include-local-projects
|
|
(when (probe-directory bundled-local-projects)
|
|
(delete-directory-tree bundled-local-projects))
|
|
(copy-local-projects-directories ql:*local-project-directories*
|
|
bundled-local-projects)
|
|
(ensure-directories-exist bundled-local-projects)
|
|
(ql::make-system-index bundled-local-projects)))
|
|
(values (write-bundle bundle to)
|
|
bundle)))
|