1168 lines
38 KiB
Common Lisp
1168 lines
38 KiB
Common Lisp
;;;; dist.lisp
|
|
|
|
(in-package #:ql-dist)
|
|
|
|
|
|
;;; Generic functions
|
|
|
|
(defgeneric dist (object)
|
|
(:documentation
|
|
"Return the dist of OBJECT."))
|
|
|
|
(defgeneric available-versions (object)
|
|
(:documentation
|
|
"Return a list of version information for OBJECT."))
|
|
|
|
(defgeneric system-index-url (object)
|
|
(:documentation
|
|
"Return the URL for the system index of OBJECT."))
|
|
|
|
(defgeneric release-index-url (object)
|
|
(:documentation
|
|
"Return the URL for the release index of OBJECT."))
|
|
|
|
(defgeneric available-versions-url (object)
|
|
(:documentation
|
|
"Return the URL for the available versions data file of OBJECT."))
|
|
|
|
(defgeneric release (object)
|
|
(:documentation
|
|
"Return the release of OBJECT."))
|
|
|
|
(defgeneric system (object)
|
|
(:documentation
|
|
"Return the system of OBJECT."))
|
|
|
|
(defgeneric name (object)
|
|
(:documentation
|
|
"Return the name of OBJECT."))
|
|
|
|
(defgeneric find-system (name)
|
|
(:documentation
|
|
"Return a system with the given NAME, or NIL if no system is
|
|
found. If multiple systems have the same name, the one with the
|
|
highest preference is returned."))
|
|
|
|
(defgeneric find-release (name)
|
|
(:documentation
|
|
"Return a release with the given NAME, or NIL if no system is
|
|
found. If multiple releases have the same name, the one with the
|
|
highest preference is returned."))
|
|
|
|
(defgeneric find-systems-named (name)
|
|
(:documentation
|
|
"Return a list of all systems in all enabled dists with the given
|
|
NAME, sorted by preference."))
|
|
|
|
(defgeneric find-releases-named (name)
|
|
(:documentation
|
|
"Return a list of all releases in all enabled dists with the given
|
|
NAME, sorted by preference."))
|
|
|
|
|
|
(defgeneric base-directory (object)
|
|
(:documentation
|
|
"Return the base directory pathname of OBJECT.")
|
|
(:method ((object pathname))
|
|
(merge-pathnames object)))
|
|
|
|
(defgeneric relative-to (object pathname)
|
|
(:documentation
|
|
"Merge PATHNAME with the base-directory of OBJECT.")
|
|
(:method (object pathname)
|
|
(merge-pathnames pathname (base-directory object))))
|
|
|
|
|
|
(defgeneric enabledp (object)
|
|
(:documentation
|
|
"Return true if OBJECT is enabled."))
|
|
|
|
(defgeneric enable (object)
|
|
(:documentation
|
|
"Enable OBJECT."))
|
|
|
|
(defgeneric disable (object)
|
|
(:documentation
|
|
"Disable OBJECT."))
|
|
|
|
(defgeneric installedp (object)
|
|
(:documentation
|
|
"Return true if OBJECT is installed."))
|
|
|
|
(defgeneric install (object)
|
|
(:documentation
|
|
"Install OBJECT."))
|
|
|
|
(defgeneric ensure-installed (object)
|
|
(:documentation
|
|
"Ensure that OBJECT is installed.")
|
|
(:method (object)
|
|
(unless (installedp object)
|
|
(install object))
|
|
object))
|
|
|
|
(defgeneric uninstall (object)
|
|
(:documentation
|
|
"Uninstall OBJECT."))
|
|
|
|
(defgeneric metadata-name (object)
|
|
(:documentation
|
|
"The metadata-name of an object is used to form the pathname for a
|
|
few different object metadata files."))
|
|
|
|
(defgeneric install-metadata-file (object)
|
|
(:documentation
|
|
"The pathname to a file describing the installation status of
|
|
OBJECT."))
|
|
|
|
(defgeneric subscription-inhibition-file (object)
|
|
(:documentation "The file whose presence indicates the inhibited
|
|
subscription status of OBJECT.")
|
|
(:method (object)
|
|
(relative-to object "subscription-inhibited.txt")))
|
|
|
|
(defgeneric inhibit-subscription (object)
|
|
(:documentation "Inhibit subscription for OBJECT.")
|
|
(:method (object)
|
|
(ensure-file-exists (subscription-inhibition-file object))))
|
|
|
|
(defgeneric uninhibit-subscription (object)
|
|
(:documentation "Remove inhibition of subscription for OBJECT.")
|
|
(:method (object)
|
|
(delete-file-if-exists (subscription-inhibition-file object))))
|
|
|
|
(defgeneric subscription-inhibited-p (object)
|
|
(:documentation "Return T if subscription to OBJECT is inhibited.")
|
|
(:method (object)
|
|
(not (not (probe-file (subscription-inhibition-file object))))))
|
|
|
|
(define-condition subscription-unavailable (error)
|
|
((object
|
|
:initarg :object
|
|
:reader subscription-unavailable-object)))
|
|
|
|
(defgeneric subscribedp (object)
|
|
(:documentation "Return true if OBJECT is subscribed to updates."))
|
|
|
|
(defgeneric subscribe (object)
|
|
(:documentation "Subscribe to updates of OBJECT, if possible. If no
|
|
updates are available, a condition of type SUBSCRIPTION-UNAVAILABLE
|
|
is raised.")
|
|
(:method (object)
|
|
(uninhibit-subscription object)
|
|
(unless (subscribedp object)
|
|
(error 'subscription-unavailable
|
|
:object object))
|
|
t))
|
|
|
|
(defgeneric unsubscribe (object)
|
|
(:documentation "Unsubscribe from updates to OBJECT.")
|
|
(:method (object)
|
|
(inhibit-subscription object)))
|
|
|
|
|
|
(defgeneric preference-parent (object)
|
|
(:documentation
|
|
"Return a value suitable for checking if OBJECT has no specific
|
|
preference set.")
|
|
(:method (object)
|
|
(declare (ignore object))
|
|
nil))
|
|
|
|
(defgeneric preference-file (object)
|
|
(:documentation
|
|
"Return the file from which preference information is loaded for
|
|
OBJECT.")
|
|
(:method (object)
|
|
(relative-to object "preference.txt")))
|
|
|
|
(defgeneric preference (object)
|
|
(:documentation
|
|
"Returns a value used when comparing multiple systems or releases
|
|
with the same name. Objects with higher preference are returned by
|
|
FIND-SYSTEM and FIND-RELEASE.")
|
|
(:method ((object null))
|
|
0)
|
|
(:method (object)
|
|
(with-open-file (stream (preference-file object)
|
|
:if-does-not-exist nil)
|
|
(if stream
|
|
(values (parse-integer (read-line stream)))
|
|
(preference (preference-parent object))))))
|
|
|
|
(defgeneric (setf preference) (preference object)
|
|
(:documentation
|
|
"Set the preference for OBJECT. Objects with higher preference are
|
|
returned by FIND-SYSTEM and FIND-RELEASE.")
|
|
(:method (preference object)
|
|
(check-type preference integer)
|
|
(let ((preference-file (preference-file object)))
|
|
(ensure-directories-exist preference-file)
|
|
(with-open-file (stream (preference-file object)
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(format stream "~D" preference)))
|
|
preference))
|
|
|
|
(defgeneric forget-preference (object)
|
|
(:documentation
|
|
"Remove specific preference information for OBJECT.")
|
|
(:method (object)
|
|
(delete-file-if-exists (preference-file object))))
|
|
|
|
(defgeneric short-description (object)
|
|
(:documentation "Return a short string describing OBJECT."))
|
|
|
|
|
|
(defgeneric provided-releases (object)
|
|
(:documentation "Return a list of releases provided by OBJECT."))
|
|
|
|
(defgeneric provided-systems (object)
|
|
(:documentation "Return a list of systems provided by OBJECT."))
|
|
|
|
(defgeneric installed-releases (dist)
|
|
(:documentation
|
|
"Return a list of all releases installed for DIST.")
|
|
(:method (dist)
|
|
(remove-if-not #'installedp (provided-releases dist))))
|
|
|
|
(defgeneric installed-systems (dist)
|
|
(:documentation
|
|
"Return a list of all systems installed for DIST.")
|
|
(:method (dist)
|
|
(remove-if-not #'installedp (provided-systems dist))))
|
|
|
|
(defgeneric new-version-available-p (dist)
|
|
(:documentation
|
|
"Return true if a new version of DIST is available."))
|
|
|
|
(defgeneric find-system-in-dist (system-name dist)
|
|
(:documentation
|
|
"Return a system with the given NAME in DIST, or NIL if no system
|
|
is found."))
|
|
|
|
(defgeneric find-release-in-dist (release-name dist)
|
|
(:documentation
|
|
"Return a release with the given NAME in DIST, or NIL if no release
|
|
is found."))
|
|
|
|
|
|
(defgeneric ensure-system-index-file (dist)
|
|
(:documentation
|
|
"Return the pathname for the system index file of DIST, fetching it
|
|
from a remote source first if necessary."))
|
|
|
|
(defgeneric ensure-system-cdb-file (dist)
|
|
(:documentation
|
|
"Return the pathname for the system cdb file of DIST, creating it
|
|
if necessary."))
|
|
|
|
(defgeneric ensure-release-index-file (dist)
|
|
(:documentation
|
|
"Return the pathname for the release index file of DIST, fetching
|
|
it from a remote source first if necessary."))
|
|
|
|
(defgeneric ensure-release-cdb-file (dist)
|
|
(:documentation
|
|
"Return the pathname for the release cdb file of DIST, creating it
|
|
if necessary."))
|
|
|
|
|
|
(defgeneric initialize-release-index (dist)
|
|
(:documentation
|
|
"Initialize the release index of DIST."))
|
|
|
|
(defgeneric initialize-system-index (dist)
|
|
(:documentation
|
|
"Initialize the system index of DIST."))
|
|
|
|
|
|
(defgeneric local-archive-file (release)
|
|
(:documentation
|
|
"Return the pathname to where the archive file of RELEASE should be
|
|
stored."))
|
|
|
|
(defgeneric ensure-local-archive-file (release)
|
|
(:documentation
|
|
"If the archive file for RELEASE is not available locally, fetch it
|
|
and return the pathname to it."))
|
|
|
|
(defgeneric check-local-archive-file (release)
|
|
(:documentation
|
|
"Check the local archive file of RELEASE for validity, including
|
|
size and signature checks. Signals errors in the case of invalid files."))
|
|
|
|
|
|
(defgeneric archive-url (release)
|
|
(:documentation
|
|
"Return the full URL for fetching the archive file of RELEASE."))
|
|
|
|
(defgeneric installed-asdf-system-file (object)
|
|
(:documentation
|
|
"Return the path to the installed ASDF system file for OBJECT, or
|
|
NIL if there is no installed system file."))
|
|
|
|
|
|
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defmacro destructure-line (lambda-list line &body body)
|
|
`(destructuring-bind ,lambda-list
|
|
(split-spaces ,line)
|
|
,@body))
|
|
|
|
(defun call-for-each-line (fun file)
|
|
(with-open-file (stream file)
|
|
(loop for line = (read-line stream nil)
|
|
while line do (funcall fun line))))
|
|
|
|
(defmacro for-each-line ((line file) &body body)
|
|
`(call-for-each-line (lambda (,line) ,@body) ,file)))
|
|
|
|
(defun make-line-instance (line class &rest initargs)
|
|
"Create an instance from words in an index file line. The last initarg collects all the trailing arguments, if any."
|
|
(let* ((words (split-spaces line))
|
|
(args (mapcan #'list
|
|
(butlast initargs)
|
|
words))
|
|
(trailing (subseq words (1- (length initargs)))))
|
|
(apply #'make-instance class (first (last initargs)) trailing args)))
|
|
|
|
(defun ignorable-line (line)
|
|
(labels ((blank-char-p (char)
|
|
(member char '(#\Space #\Tab)))
|
|
(blankp (line)
|
|
(every #'blank-char-p line))
|
|
(ignorable (line)
|
|
(or (zerop (length line))
|
|
(blankp line)
|
|
(eql (char line 0) #\#))))
|
|
(ignorable line)))
|
|
|
|
(defvar *initarg-case-converter*
|
|
(cond ((string= :string "string")
|
|
#'string-downcase)
|
|
((string= :string "STRING")
|
|
#'string-upcase)))
|
|
|
|
(defun config-file-initargs (file)
|
|
(flet ((initarg-keyword (string)
|
|
;; A concession to mlisp
|
|
(intern (funcall *initarg-case-converter* string)
|
|
'keyword)))
|
|
(let ((initargs '()))
|
|
(for-each-line (line file)
|
|
(unless (ignorable-line line)
|
|
(destructure-line (initarg value)
|
|
line
|
|
(let ((keyword (initarg-keyword (string-right-trim ":" initarg))))
|
|
(push value initargs)
|
|
(push keyword initargs)))))
|
|
initargs)))
|
|
|
|
;;;
|
|
;;; A few generic things
|
|
;;;
|
|
|
|
(defmethod dist ((name symbol))
|
|
(dist (string name)))
|
|
|
|
(defmethod dist ((name string))
|
|
(find-dist (string-downcase name)))
|
|
|
|
(defmethod release ((name symbol))
|
|
(release (string name)))
|
|
|
|
(defmethod release ((name string))
|
|
(find-release (string-downcase name)))
|
|
|
|
(defmethod system ((name symbol))
|
|
(system (string name)))
|
|
|
|
(defmethod system ((name string))
|
|
(find-system (string-downcase name)))
|
|
|
|
;;;
|
|
;;; Dists
|
|
;;;
|
|
;;; A dist is a set of releases.
|
|
;;;
|
|
|
|
(defclass dist ()
|
|
((base-directory
|
|
:initarg :base-directory
|
|
:accessor base-directory)
|
|
(name
|
|
:initarg :name
|
|
:accessor name)
|
|
(version
|
|
:initarg :version
|
|
:accessor version)
|
|
(system-index-url
|
|
:initarg :system-index-url
|
|
:accessor system-index-url)
|
|
(release-index-url
|
|
:initarg :release-index-url
|
|
:accessor release-index-url)
|
|
(available-versions-url
|
|
:initarg :available-versions-url
|
|
:accessor available-versions-url)
|
|
(archive-base-url
|
|
:initarg :archive-base-url
|
|
:accessor archive-base-url)
|
|
(canonical-distinfo-url
|
|
:initarg :canonical-distinfo-url
|
|
:accessor canonical-distinfo-url)
|
|
(distinfo-subscription-url
|
|
:initarg :distinfo-subscription-url
|
|
:accessor distinfo-subscription-url)
|
|
(system-index
|
|
:initarg :system-index
|
|
:accessor system-index)
|
|
(release-index
|
|
:initarg :release-index
|
|
:accessor release-index)
|
|
(provided-systems
|
|
:initarg :provided-systems
|
|
:accessor provided-systems)
|
|
(provided-releases
|
|
:initarg :provided-releases
|
|
:accessor provided-releases)
|
|
(local-distinfo-file
|
|
:initarg :local-distinfo-file
|
|
:accessor local-distinfo-file))
|
|
(:default-initargs
|
|
:name "unnamed"
|
|
:version "unknown"
|
|
:distinfo-subscription-url nil))
|
|
|
|
(defmethod short-description ((dist dist))
|
|
(format nil "~A ~A" (name dist) (version dist)))
|
|
|
|
(defmethod print-object ((dist dist) stream)
|
|
(print-unreadable-object (dist stream :type t)
|
|
(write-string (short-description dist) stream)))
|
|
|
|
(defun cdb-lookup (dist key cdb)
|
|
(ql-cdb:lookup key
|
|
(relative-to dist cdb)))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'available-versions-url)))
|
|
(declare (ignore class))
|
|
(setf (available-versions-url dist)
|
|
(make-versions-url (distinfo-subscription-url dist))))
|
|
|
|
|
|
(defmethod ensure-system-index-file ((dist dist))
|
|
(let ((pathname (relative-to dist "systems.txt")))
|
|
(or (probe-file pathname)
|
|
(nth-value 1 (fetch (system-index-url dist) pathname)))))
|
|
|
|
(defmethod ensure-system-cdb-file ((dist dist))
|
|
(let* ((system-file (ensure-system-index-file dist))
|
|
(cdb-file (make-pathname :type "cdb" :defaults system-file)))
|
|
(or (probe-file cdb-file)
|
|
(ql-cdb:convert-index-file system-file
|
|
:cdb-file cdb-file
|
|
:index 2))))
|
|
|
|
(defmethod ensure-release-index-file ((dist dist))
|
|
(let ((pathname (relative-to dist "releases.txt")))
|
|
(or (probe-file pathname)
|
|
(nth-value 1 (fetch (release-index-url dist) pathname)))))
|
|
|
|
(defmethod ensure-release-cdb-file ((dist dist))
|
|
(let* ((release-file (ensure-release-index-file dist))
|
|
(cdb-file (make-pathname :type "cdb" :defaults release-file)))
|
|
(or (probe-file cdb-file)
|
|
(ql-cdb:convert-index-file release-file
|
|
:cdb-file cdb-file
|
|
:index 0))))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'provided-systems)))
|
|
(declare (ignore class))
|
|
(initialize-system-index dist)
|
|
(setf (slot-value dist 'provided-systems)
|
|
(loop for system being each hash-value of (system-index dist)
|
|
collect system)))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'provided-releases)))
|
|
(declare (ignore class))
|
|
(initialize-release-index dist)
|
|
(setf (slot-value dist 'provided-releases)
|
|
(loop for system being each hash-value of (release-index dist)
|
|
collect system)))
|
|
|
|
|
|
(defun dist-name-pathname (name)
|
|
"Return the pathname that would be used for an installed dist with
|
|
the given NAME."
|
|
(qmerge (make-pathname :directory (list :relative "dists" name))))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'base-directory)))
|
|
(declare (ignore class))
|
|
(setf (base-directory dist) (dist-name-pathname (name dist))))
|
|
|
|
(defun make-dist-from-file (file &key (class 'dist))
|
|
"Load dist info from FILE and use it to create a dist instance."
|
|
(let ((initargs (config-file-initargs file)))
|
|
(apply #'make-instance class
|
|
:local-distinfo-file file
|
|
:allow-other-keys t
|
|
initargs)))
|
|
|
|
(defmethod install-metadata-file ((dist dist))
|
|
(relative-to dist "distinfo.txt"))
|
|
|
|
(defun find-dist (name)
|
|
(find name (all-dists)
|
|
:key #'name
|
|
:test #'string=))
|
|
|
|
(defmethod enabledp ((dist dist))
|
|
(not (not (probe-file (relative-to dist "enabled.txt")))))
|
|
|
|
(defmethod enable ((dist dist))
|
|
(ensure-file-exists (relative-to dist "enabled.txt"))
|
|
t)
|
|
|
|
(defmethod disable ((dist dist))
|
|
(delete-file-if-exists (relative-to dist "enabled.txt"))
|
|
t)
|
|
|
|
(defmethod installedp ((dist dist))
|
|
(let ((installed (find-dist (name dist))))
|
|
(equalp (version installed) (version dist))))
|
|
|
|
(defmethod uninstall ((dist dist))
|
|
(when (installedp dist)
|
|
(dolist (system (provided-systems dist))
|
|
(asdf:clear-system (name system)))
|
|
(ql-impl-util:delete-directory-tree (base-directory dist))
|
|
t))
|
|
|
|
|
|
(defun make-release-from-line (line dist)
|
|
(let ((release
|
|
(make-line-instance line 'release
|
|
:project-name
|
|
:archive-url
|
|
:archive-size
|
|
:archive-md5
|
|
:archive-content-sha1
|
|
:prefix
|
|
:system-files)))
|
|
(setf (dist release) dist)
|
|
(setf (archive-size release)
|
|
(parse-integer (archive-size release)))
|
|
release))
|
|
|
|
(defmethod find-release-in-dist (release-name (dist dist))
|
|
(let* ((index (release-index dist))
|
|
(release (gethash release-name index)))
|
|
(or release
|
|
(let ((line (cdb-lookup dist release-name
|
|
(ensure-release-cdb-file dist))))
|
|
(when line
|
|
(setf (gethash release-name index)
|
|
(make-release-from-line line dist)))))))
|
|
|
|
|
|
(defparameter *dist-enumeration-functions*
|
|
'(standard-dist-enumeration-function)
|
|
"ALL-DISTS calls each function in this list with no arguments, and
|
|
appends the results into a list of dist objects, removing
|
|
duplicates. Functions might be called just once for a batch of
|
|
related operations; see WITH-CONSISTENT-DISTS.")
|
|
|
|
(defun standard-dist-enumeration-function ()
|
|
"The default function used for producing a list of dist objects."
|
|
(loop for file in (directory (qmerge "dists/*/distinfo.txt"))
|
|
collect (make-dist-from-file file)))
|
|
|
|
(defun all-dists ()
|
|
"Return a list of all known dists."
|
|
(remove-duplicates
|
|
(apply 'append (mapcar 'funcall *dist-enumeration-functions*))))
|
|
|
|
(defun enabled-dists ()
|
|
"Return a list of all known dists for which ENABLEDP returns true."
|
|
(remove-if-not #'enabledp (all-dists)))
|
|
|
|
|
|
(defmethod install-metadata-file (object)
|
|
(relative-to (dist object)
|
|
(make-pathname :directory
|
|
(list :relative "installed"
|
|
(metadata-name object))
|
|
:name (name object)
|
|
:type "txt")))
|
|
|
|
|
|
(defclass preference-mixin () ()
|
|
(:documentation
|
|
"Instances of this class have a special location for their
|
|
preference files."))
|
|
|
|
(defgeneric filesystem-name (object)
|
|
(:method (object)
|
|
;; This is to work around system names like "foo/bar".
|
|
(let* ((name (name object))
|
|
(slash (position #\/ name)))
|
|
(if slash
|
|
(subseq name 0 slash)
|
|
name))))
|
|
|
|
(defmethod preference-file ((object preference-mixin))
|
|
(relative-to
|
|
(dist object)
|
|
(make-pathname :directory (list :relative
|
|
"preferences"
|
|
(metadata-name object))
|
|
:name (filesystem-name object)
|
|
:type "txt")))
|
|
|
|
(defmethod distinfo-subscription-url :around ((dist dist))
|
|
(unless (subscription-inhibited-p dist)
|
|
(call-next-method)))
|
|
|
|
(defmethod subscribedp ((dist dist))
|
|
(distinfo-subscription-url dist))
|
|
|
|
;;;
|
|
;;; Releases
|
|
;;;
|
|
|
|
(defclass release (preference-mixin)
|
|
((project-name
|
|
:initarg :project-name
|
|
:accessor name
|
|
:accessor project-name)
|
|
(dist
|
|
:initarg :dist
|
|
:accessor dist
|
|
:reader preference-parent)
|
|
(provided-systems
|
|
:initarg :provided-systems
|
|
:accessor provided-systems)
|
|
(archive-url
|
|
:initarg :archive-url
|
|
:accessor archive-url)
|
|
(archive-size
|
|
:initarg :archive-size
|
|
:accessor archive-size)
|
|
(archive-md5
|
|
:initarg :archive-md5
|
|
:accessor archive-md5)
|
|
(archive-content-sha1
|
|
:initarg :archive-content-sha1
|
|
:accessor archive-content-sha1)
|
|
(prefix
|
|
:initarg :prefix
|
|
:accessor prefix
|
|
:reader short-description)
|
|
(system-files
|
|
:initarg :system-files
|
|
:accessor system-files)
|
|
(metadata-name
|
|
:initarg :metadata-name
|
|
:accessor metadata-name))
|
|
(:default-initargs
|
|
:metadata-name "releases")
|
|
(:documentation
|
|
"Instances of this class represent a snapshot of a project at some
|
|
point in time, which might be from version control, or from an
|
|
official release, or from some other source."))
|
|
|
|
(defmethod print-object ((release release) stream)
|
|
(print-unreadable-object (release stream :type t)
|
|
(format stream "~A / ~A"
|
|
(short-description release)
|
|
(short-description (dist release)))))
|
|
|
|
(define-condition invalid-local-archive (error)
|
|
((release
|
|
:initarg :release
|
|
:reader invalid-local-archive-release)
|
|
(file
|
|
:initarg :file
|
|
:reader invalid-local-archive-file))
|
|
(:report
|
|
(lambda (condition stream)
|
|
(format stream "The archive file ~S for release ~S is invalid"
|
|
(file-namestring (invalid-local-archive-file condition))
|
|
(name (invalid-local-archive-release condition))))))
|
|
|
|
(define-condition missing-local-archive (invalid-local-archive)
|
|
()
|
|
(:report
|
|
(lambda (condition stream)
|
|
(format stream "The archive file ~S for release ~S is missing"
|
|
(file-namestring (invalid-local-archive-file condition))
|
|
(name (invalid-local-archive-release condition))))))
|
|
|
|
(define-condition badly-sized-local-archive (invalid-local-archive)
|
|
((expected-size
|
|
:initarg :expected-size
|
|
:reader badly-sized-local-archive-expected-size)
|
|
(actual-size
|
|
:initarg :actual-size
|
|
:reader badly-sized-local-archive-actual-size))
|
|
(:report
|
|
(lambda (condition stream)
|
|
(format stream "The archive file ~S for ~S is the wrong size: ~
|
|
expected ~:D, got ~:D"
|
|
(file-namestring (invalid-local-archive-file condition))
|
|
(name (invalid-local-archive-release condition))
|
|
(badly-sized-local-archive-expected-size condition)
|
|
(badly-sized-local-archive-actual-size condition)))))
|
|
|
|
(defmethod check-local-archive-file ((release release))
|
|
(let ((file (local-archive-file release)))
|
|
(unless (probe-file file)
|
|
(error 'missing-local-archive
|
|
:file file
|
|
:release release))
|
|
(let ((actual-size (file-size file))
|
|
(expected-size (archive-size release)))
|
|
(unless (= actual-size expected-size)
|
|
(error 'badly-sized-local-archive
|
|
:file file
|
|
:release release
|
|
:actual-size actual-size
|
|
:expected-size expected-size)))))
|
|
|
|
(defmethod local-archive-file ((release release))
|
|
(relative-to (dist release)
|
|
(make-pathname :directory '(:relative "archives")
|
|
:defaults (file-namestring
|
|
(path (url (archive-url release)))))))
|
|
|
|
(defmethod ensure-local-archive-file ((release release))
|
|
(let ((pathname (local-archive-file release)))
|
|
(tagbody
|
|
:retry
|
|
(or (probe-file pathname)
|
|
(progn
|
|
(ensure-directories-exist pathname)
|
|
(fetch (archive-url release) pathname)))
|
|
(restart-case
|
|
(check-local-archive-file release)
|
|
(delete-and-retry (&optional v)
|
|
:report "Delete the archive file and fetch it again"
|
|
(declare (ignore v))
|
|
(delete-file pathname)
|
|
(go :retry))))
|
|
pathname))
|
|
|
|
|
|
(defmethod base-directory ((release release))
|
|
(relative-to
|
|
(dist release)
|
|
(make-pathname :directory (list :relative "software" (prefix release)))))
|
|
|
|
(defmethod installedp ((release release))
|
|
(and (probe-file (install-metadata-file release))
|
|
(every #'installedp (provided-systems release))))
|
|
|
|
(defmethod install ((release release))
|
|
(let ((archive (ensure-local-archive-file release))
|
|
(tar (qmerge "tmp/release-install.tar"))
|
|
(output (relative-to (dist release)
|
|
(make-pathname :directory
|
|
(list :relative "software"))))
|
|
(tracking (install-metadata-file release)))
|
|
(ensure-directories-exist tar)
|
|
(ensure-directories-exist output)
|
|
(ensure-directories-exist tracking)
|
|
(gunzip archive tar)
|
|
(unpack-tarball tar :directory output)
|
|
(ensure-directories-exist tracking)
|
|
(with-open-file (stream tracking
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(write-line (qenough (base-directory release)) stream))
|
|
(let ((provided (provided-systems release))
|
|
(dist (dist release)))
|
|
(dolist (file (system-files release))
|
|
(let ((system (find-system-in-dist (pathname-name file) dist)))
|
|
(unless (member system provided)
|
|
(error "FIND-SYSTEM-IN-DIST returned ~A but I expected one of ~A"
|
|
system provided))
|
|
(let ((system-tracking (install-metadata-file system))
|
|
(system-file (merge-pathnames file
|
|
(base-directory release))))
|
|
(ensure-directories-exist system-tracking)
|
|
(unless (probe-file system-file)
|
|
(error "Release claims to have ~A, but I can't find it"
|
|
system-file))
|
|
(with-open-file (stream system-tracking
|
|
:direction :output
|
|
:if-exists :supersede)
|
|
(write-line (qenough system-file)
|
|
stream))))))
|
|
release))
|
|
|
|
(defmethod uninstall ((release release))
|
|
(when (installedp release)
|
|
(dolist (system (installed-systems release))
|
|
(asdf:clear-system (name system))
|
|
(delete-file (install-metadata-file system)))
|
|
(delete-file (install-metadata-file release))
|
|
(delete-file (local-archive-file release))
|
|
(ql-impl-util:delete-directory-tree (base-directory release))
|
|
t))
|
|
|
|
|
|
(defun call-for-each-index-entry (file fun)
|
|
(labels ((blank-char-p (char)
|
|
(member char '(#\Space #\Tab)))
|
|
(blankp (line)
|
|
(every #'blank-char-p line))
|
|
(ignorable (line)
|
|
(or (zerop (length line))
|
|
(blankp line)
|
|
(eql (char line 0) #\#))))
|
|
(with-open-file (stream file)
|
|
(loop for line = (read-line stream nil)
|
|
while line do
|
|
(unless (ignorable line)
|
|
(funcall fun line))))))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'release-index)))
|
|
(declare (ignore class))
|
|
(setf (slot-value dist 'release-index)
|
|
(make-hash-table :test 'equal)))
|
|
|
|
|
|
;;;
|
|
;;; Systems
|
|
;;;
|
|
;;; A "system" in the defsystem sense.
|
|
;;;
|
|
|
|
(defclass system (preference-mixin)
|
|
((name
|
|
:initarg :name
|
|
:accessor name
|
|
:reader short-description)
|
|
(system-file-name
|
|
:initarg :system-file-name
|
|
:accessor system-file-name)
|
|
(release
|
|
:initarg :release
|
|
:accessor release
|
|
:reader preference-parent)
|
|
(dist
|
|
:initarg :dist
|
|
:accessor dist)
|
|
(required-systems
|
|
:initarg :required-systems
|
|
:accessor required-systems)
|
|
(metadata-name
|
|
:initarg :metadata-name
|
|
:accessor metadata-name))
|
|
(:default-initargs
|
|
:metadata-name "systems"))
|
|
|
|
(defmethod print-object ((system system) stream)
|
|
(print-unreadable-object (system stream :type t)
|
|
(format stream "~A / ~A / ~A"
|
|
(short-description system)
|
|
(short-description (release system))
|
|
(short-description (dist system)))))
|
|
|
|
(defmethod provided-systems ((system system))
|
|
(list system))
|
|
|
|
(defmethod initialize-release-index ((dist dist))
|
|
(let ((releases (ensure-release-index-file dist))
|
|
(index (release-index dist)))
|
|
(call-for-each-index-entry
|
|
releases
|
|
(lambda (line)
|
|
(let ((instance (make-line-instance line 'release
|
|
:project-name
|
|
:archive-url
|
|
:archive-size
|
|
:archive-md5
|
|
:archive-content-sha1
|
|
:prefix
|
|
:system-files)))
|
|
;; Don't clobber anything previously loaded via CDB
|
|
(unless (gethash (project-name instance) index)
|
|
(setf (dist instance) dist)
|
|
(setf (archive-size instance)
|
|
(parse-integer (archive-size instance)))
|
|
(setf (gethash (project-name instance) index) instance)))))
|
|
(setf (release-index dist) index)))
|
|
|
|
(defmethod initialize-system-index ((dist dist))
|
|
(initialize-release-index dist)
|
|
(let ((systems (ensure-system-index-file dist))
|
|
(index (system-index dist)))
|
|
(call-for-each-index-entry
|
|
systems
|
|
(lambda (line)
|
|
(let ((instance (make-line-instance line 'system
|
|
:release
|
|
:system-file-name
|
|
:name
|
|
:required-systems)))
|
|
;; Don't clobber anything previously loaded via CDB
|
|
(unless (gethash (name instance) index)
|
|
(let ((release (find-release-in-dist (release instance) dist)))
|
|
(setf (release instance) release)
|
|
(if (slot-boundp release 'provided-systems)
|
|
(pushnew instance (provided-systems release))
|
|
(setf (provided-systems release) (list instance))))
|
|
(setf (dist instance) dist)
|
|
(setf (gethash (name instance) index) instance)))))
|
|
(setf (system-index dist) index)))
|
|
|
|
(defmethod slot-unbound (class (release release) (slot (eql 'provided-systems)))
|
|
(declare (ignore class))
|
|
;; FIXME: This isn't right, since the system index has systems that
|
|
;; don't match the defining system file name.
|
|
(setf (slot-value release 'provided-systems)
|
|
(mapcar (lambda (system-file)
|
|
(find-system-in-dist (pathname-name system-file)
|
|
(dist release)))
|
|
(system-files release))))
|
|
|
|
(defmethod slot-unbound (class (dist dist) (slot (eql 'system-index)))
|
|
(declare (ignore class))
|
|
(setf (slot-value dist 'system-index)
|
|
(make-hash-table :test 'equal)))
|
|
|
|
(defun make-system-from-line (line dist)
|
|
(let ((system (make-line-instance line 'system
|
|
:release
|
|
:system-file-name
|
|
:name
|
|
:required-systems)))
|
|
(setf (dist system) dist)
|
|
(setf (release system)
|
|
(find-release-in-dist (release system) dist))
|
|
system))
|
|
|
|
(defmethod find-system-in-dist (system-name (dist dist))
|
|
(let* ((index (system-index dist))
|
|
(system (gethash system-name index)))
|
|
(or system
|
|
(let ((line (cdb-lookup dist system-name
|
|
(ensure-system-cdb-file dist))))
|
|
(when line
|
|
(setf (gethash system-name index)
|
|
(make-system-from-line line dist)))))))
|
|
|
|
(defmethod preference ((system system))
|
|
(if (probe-file (preference-file system))
|
|
(call-next-method)
|
|
(preference (release system))))
|
|
|
|
(defun thing-name-designator (designator)
|
|
"Convert DESIGNATOR to a string naming a thing. Strings are used
|
|
as-is, symbols are converted to their downcased symbol-name."
|
|
(typecase designator
|
|
(string designator)
|
|
(symbol (string-downcase designator))
|
|
(t
|
|
(error "~S is not a valid designator for a system or release"
|
|
designator))))
|
|
|
|
(defun find-thing-named (find-fun name)
|
|
(setf name (thing-name-designator name))
|
|
(let ((result '()))
|
|
(dolist (dist (enabled-dists) (sort result #'> :key #'preference))
|
|
(let ((thing (funcall find-fun name dist)))
|
|
(when thing
|
|
(push thing result))))))
|
|
|
|
(defmethod find-systems-named (name)
|
|
(find-thing-named #'find-system-in-dist name))
|
|
|
|
(defmethod find-releases-named (name)
|
|
(find-thing-named #'find-release-in-dist name))
|
|
|
|
(defmethod find-system (name)
|
|
(first (find-systems-named name)))
|
|
|
|
(defmethod find-release (name)
|
|
(first (find-releases-named name)))
|
|
|
|
(defmethod install ((system system))
|
|
(ensure-installed (release system)))
|
|
|
|
|
|
(defmethod install-metadata-file ((system system))
|
|
(relative-to (dist system)
|
|
(make-pathname :name (system-file-name system)
|
|
:type "txt"
|
|
:directory '(:relative "installed" "systems"))))
|
|
|
|
(defmethod installed-asdf-system-file ((system system))
|
|
(let ((metadata-file (install-metadata-file system)))
|
|
(when (probe-file metadata-file)
|
|
(with-open-file (stream metadata-file)
|
|
(let* ((relative (read-line stream))
|
|
(full (qmerge relative)))
|
|
(when (probe-file full)
|
|
full))))))
|
|
|
|
(defmethod installedp ((system system))
|
|
(installed-asdf-system-file system))
|
|
|
|
(defmethod uninstall ((system system))
|
|
(uninstall (release system)))
|
|
|
|
(defun find-asdf-system-file (name)
|
|
"Return the ASDF system file in which the system named NAME is defined."
|
|
(let ((system (find-system name)))
|
|
(when system
|
|
(installed-asdf-system-file system))))
|
|
|
|
(defun system-definition-searcher (name)
|
|
"Like FIND-ASDF-SYSTEM-FILE, but this function can be used in
|
|
ASDF:*SYSTEM-DEFINITION-SEARCH-FUNCTIONS*; it will only return system
|
|
file names if they match NAME."
|
|
(let ((system-file (find-asdf-system-file name)))
|
|
(when (and system-file
|
|
(string= (pathname-name system-file) name))
|
|
system-file)))
|
|
|
|
(defun call-with-consistent-dists (fun)
|
|
"Take a snapshot of the available dists and return the same list
|
|
consistently each time ALL-DISTS is called in the dynamic scope of
|
|
FUN."
|
|
(let* ((all-dists (all-dists))
|
|
(*dist-enumeration-functions* (list (constantly all-dists))))
|
|
(funcall fun)))
|
|
|
|
(defmacro with-consistent-dists (&body body)
|
|
"See CALL-WITH-CONSISTENT-DISTS."
|
|
`(call-with-consistent-dists (lambda () ,@body)))
|
|
|
|
|
|
(defgeneric dependency-tree (system)
|
|
(:method ((symbol symbol))
|
|
(dependency-tree (string-downcase symbol)))
|
|
(:method ((string string))
|
|
(let ((system (find-system string)))
|
|
(when system
|
|
(dependency-tree system))))
|
|
(:method ((system system))
|
|
(with-consistent-dists
|
|
(list* system
|
|
(remove nil
|
|
(mapcar 'dependency-tree (required-systems system)))))))
|
|
|
|
(defmethod provided-systems ((object (eql t)))
|
|
(let ((systems (loop for dist in (enabled-dists)
|
|
appending (provided-systems dist))))
|
|
(sort systems #'string< :key #'name)))
|
|
|
|
(defmethod provided-releases ((object (eql t)))
|
|
(let ((releases (loop for dist in (enabled-dists)
|
|
appending (provided-releases dist))))
|
|
(sort releases #'string< :key #'name)))
|
|
|
|
|
|
(defgeneric system-apropos-list (term)
|
|
(:method ((term symbol))
|
|
(system-apropos-list (symbol-name term)))
|
|
(:method ((term string))
|
|
(setf term (string-downcase term))
|
|
(let ((result '()))
|
|
(dolist (system (provided-systems t) (nreverse result))
|
|
(when (or (search term (name system))
|
|
(search term (name (release system))))
|
|
(push system result))))))
|
|
|
|
(defgeneric system-apropos (term)
|
|
(:method (term)
|
|
(map nil (lambda (system)
|
|
(format t "~A~%" system))
|
|
(system-apropos-list term))
|
|
(values)))
|
|
|
|
|
|
;;;
|
|
;;; Clean up things
|
|
;;;
|
|
|
|
(defgeneric clean (object)
|
|
(:documentation "Remove any unneeded files or directories related to
|
|
OBJECT."))
|
|
|
|
(defmethod clean ((dist dist))
|
|
(let* ((releases (provided-releases dist))
|
|
(known-archives (mapcar 'local-archive-file releases))
|
|
(known-directories (mapcar 'base-directory releases))
|
|
(present-archives (mapcar 'truename
|
|
(directory-entries
|
|
(relative-to dist "archives/"))))
|
|
(present-directories (mapcar 'truename
|
|
(directory-entries
|
|
(relative-to dist "software/"))))
|
|
(garbage-archives
|
|
(set-difference present-archives known-archives
|
|
:test 'equalp))
|
|
(garbage-directories
|
|
;; Use the namestring here on the theory that pathnames with
|
|
;; equalp namestrings are sufficiently the same. On
|
|
;; LispWorks, for example, identical namestrings can still
|
|
;; differ in :name, :type, and more.
|
|
(set-difference present-directories known-directories
|
|
:test 'equalp
|
|
:key 'namestring)))
|
|
(map nil 'delete-file garbage-archives)
|
|
(map nil 'delete-directory-tree garbage-directories)))
|
|
|
|
|
|
;;;
|
|
;;; Available versions
|
|
;;;
|
|
|
|
(defmethod available-versions ((dist dist))
|
|
(let ((temp (qmerge "tmp/dist-versions.txt"))
|
|
(versions '())
|
|
(url (available-versions-url dist)))
|
|
(when url
|
|
(ensure-directories-exist temp)
|
|
(delete-file-if-exists temp)
|
|
(handler-case
|
|
(fetch url temp)
|
|
(unexpected-http-status ()
|
|
(return-from available-versions nil)))
|
|
(with-open-file (stream temp)
|
|
(loop for line = (read-line stream nil)
|
|
while line do
|
|
(destructuring-bind (version url)
|
|
(split-spaces line)
|
|
(setf versions (acons version url versions)))))
|
|
versions)))
|
|
|
|
|
|
;;;
|
|
;;; User interface bits to re-export from QL
|
|
;;;
|
|
|
|
(define-condition unknown-dist (error)
|
|
((name
|
|
:initarg :name
|
|
:reader unknown-dist-name))
|
|
(:report (lambda (condition stream)
|
|
(format stream "No dist known by that name -- ~S"
|
|
(unknown-dist-name condition)))))
|
|
|
|
(defun find-dist-or-lose (name)
|
|
(let ((dist (find-dist name)))
|
|
(or dist
|
|
(error 'unknown-dist :name name))))
|
|
|
|
(defun dist-url (name)
|
|
(canonical-distinfo-url (find-dist-or-lose name)))
|
|
|
|
(defun dist-version (name)
|
|
(version (find-dist-or-lose name)))
|