489 lines
19 KiB
Common Lisp
489 lines
19 KiB
Common Lisp
(unless (find-package :ql-to-nix-util)
|
|
(load "util.lisp"))
|
|
(unless (find-package :ql-to-nix-quicklisp-bootstrap)
|
|
(load "quicklisp-bootstrap.lisp"))
|
|
(defpackage :ql-to-nix-system-info
|
|
(:use :common-lisp :ql-to-nix-quicklisp-bootstrap :ql-to-nix-util)
|
|
(:export #:dump-image))
|
|
(in-package :ql-to-nix-system-info)
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defparameter *implementation-systems*
|
|
(append
|
|
#+sbcl(list :sb-posix :sb-bsd-sockets :sb-rotate-byte :sb-cltl2
|
|
:sb-introspect :sb-rt :sb-concurrency)))
|
|
(mapcar (function require) *implementation-systems*))
|
|
|
|
(declaim (optimize (debug 3) (speed 0) (space 0) (compilation-speed 0) (safety 3)))
|
|
|
|
;; This file cannot have any dependencies beyond quicklisp and asdf.
|
|
;; Otherwise, we'll miss some dependencies!
|
|
|
|
;; (Implementation-provided dependencies are special, though)
|
|
|
|
;; We can't load quicklisp until runtime (at which point we'll create
|
|
;; an isolated quicklisp installation). These wrapper functions are
|
|
;; nicer than funcalling intern'd symbols every time we want to talk
|
|
;; to quicklisp.
|
|
(wrap :ql apply-load-strategy)
|
|
(wrap :ql compute-load-strategy)
|
|
(wrap :ql show-load-strategy)
|
|
(wrap :ql quicklisp-systems)
|
|
(wrap :ql ensure-installed)
|
|
(wrap :ql quicklisp-releases)
|
|
(wrap :ql-dist archive-md5)
|
|
(wrap :ql-dist archive-url)
|
|
(wrap :ql-dist ensure-local-archive-file)
|
|
(wrap :ql-dist find-system)
|
|
(wrap :ql-dist local-archive-file)
|
|
(wrap :ql-dist name)
|
|
(wrap :ql-dist provided-systems)
|
|
(wrap :ql-dist release)
|
|
(wrap :ql-dist short-description)
|
|
(wrap :ql-dist system-file-name)
|
|
(wrap :ql-impl-util call-with-quiet-compilation)
|
|
|
|
(defvar *version* (uiop:getenv "version")
|
|
"The version number of this program")
|
|
|
|
(defvar *main-system* nil
|
|
"The name of the system we're trying to extract info from.")
|
|
|
|
(defvar *found-parasites* (make-hash-table :test #'equalp)
|
|
"Names of systems which have been identified as parasites.
|
|
|
|
A system is parasitic if its name doesn't match the name of the file
|
|
it is defined in. So, for example, if foo and foo-bar are both
|
|
defined in a file named foo.asd, foo would be the host system and
|
|
foo-bar would be a parasitic system.
|
|
|
|
Parasitic systems are not generally loaded without loading the host
|
|
system first.
|
|
|
|
Keys are system names. Values are unspecified.")
|
|
|
|
(defvar *found-dependencies* (make-hash-table :test #'equalp)
|
|
"Hash table containing the set of dependencies discovered while installing a system.
|
|
|
|
Keys are system names. Values are unspecified.")
|
|
|
|
(defun decode-asdf-dependency (name)
|
|
"Translates an asdf system dependency description into a system name.
|
|
|
|
For example, translates (:version :foo \"1.0\") into \"foo\"."
|
|
(etypecase name
|
|
(symbol
|
|
(setf name (symbol-name name)))
|
|
(string)
|
|
(cons
|
|
(ecase (first name)
|
|
(:version
|
|
(warn "Discarding version information ~A" name)
|
|
;; There's nothing we can do about this. If the version we
|
|
;; have around is good enough, then we're golden. If it isn't
|
|
;; good enough, then we'll error out and let a human figure it
|
|
;; out.
|
|
(setf name (second name))
|
|
(return-from decode-asdf-dependency
|
|
(decode-asdf-dependency name)))
|
|
|
|
(:feature
|
|
(if (find (second name) *features*)
|
|
(return-from decode-asdf-dependency
|
|
(decode-asdf-dependency (third name)))
|
|
(progn
|
|
(warn "Dropping dependency due to missing feature: ~A" name)
|
|
(return-from decode-asdf-dependency nil))))
|
|
|
|
(:require
|
|
;; This probably isn't a dependency we can satisfy using
|
|
;; quicklisp, but we might as well try anyway.
|
|
(return-from decode-asdf-dependency
|
|
(decode-asdf-dependency (second name)))))))
|
|
(string-downcase name))
|
|
|
|
(defun found-new-parasite (system-name)
|
|
"Record that the given system has been identified as a parasite."
|
|
(setf system-name (decode-asdf-dependency system-name))
|
|
(setf (gethash system-name *found-parasites*) t)
|
|
(when (nth-value 1 (gethash system-name *found-dependencies*))
|
|
(error "Found dependency on parasite")))
|
|
|
|
(defun known-parasite-p (system-name)
|
|
"Have we previously identified this system as a parasite?"
|
|
(nth-value 1 (gethash system-name *found-parasites*)))
|
|
|
|
(defun found-parasites ()
|
|
"Return a vector containing all identified parasites."
|
|
(let ((systems (make-array (hash-table-size *found-parasites*) :fill-pointer 0)))
|
|
(loop :for system :being :the :hash-keys :of *found-parasites* :do
|
|
(vector-push system systems))
|
|
systems))
|
|
|
|
(defvar *track-dependencies* nil
|
|
"When this variable is nil, found-new-dependency will not record
|
|
depdendencies.")
|
|
|
|
(defun parasitic-relationship-p (potential-host potential-parasite)
|
|
"Returns t if potential-host and potential-parasite have a parasitic relationship.
|
|
|
|
See `*found-parasites*'."
|
|
(let ((host-ql-system (find-system potential-host))
|
|
(parasite-ql-system (find-system potential-parasite)))
|
|
(and host-ql-system parasite-ql-system
|
|
(not (equal (name host-ql-system)
|
|
(name parasite-ql-system)))
|
|
(equal (system-file-name host-ql-system)
|
|
(system-file-name parasite-ql-system)))))
|
|
|
|
(defun found-new-dependency (name)
|
|
"Record that the given system has been identified as a dependency.
|
|
|
|
The named system may not be recorded as a dependency. It may be left
|
|
out for any number of reasons. For example, if `*track-dependencies*'
|
|
is nil then this function does nothing. If the named system isn't a
|
|
quicklisp system, this function does nothing."
|
|
(setf name (decode-asdf-dependency name))
|
|
(unless name
|
|
(return-from found-new-dependency))
|
|
(unless *track-dependencies*
|
|
(return-from found-new-dependency))
|
|
(when (known-parasite-p name)
|
|
(return-from found-new-dependency))
|
|
(when (parasitic-relationship-p *main-system* name)
|
|
(found-new-parasite name)
|
|
(return-from found-new-dependency))
|
|
(unless (find-system name)
|
|
(return-from found-new-dependency))
|
|
(setf (gethash name *found-dependencies*) t))
|
|
|
|
(defun forget-dependency (name)
|
|
"Whoops. Did I say that was a dependency? My bad.
|
|
|
|
Be very careful using this function! You can remove a system from the
|
|
dependency list, but you can't remove other effects associated with
|
|
this system. For example, transitive dependencies might still be in
|
|
the dependency list."
|
|
(setf name (decode-asdf-dependency name))
|
|
(remhash name *found-dependencies*))
|
|
|
|
(defun found-dependencies ()
|
|
"Return a vector containing all identified dependencies."
|
|
(let ((systems (make-array (hash-table-size *found-dependencies*) :fill-pointer 0)))
|
|
(loop :for system :being :the :hash-keys :of *found-dependencies* :do
|
|
(vector-push system systems))
|
|
systems))
|
|
|
|
(defun host-system (system-name)
|
|
"If the given system is a parasite, return the name of the system that is its host.
|
|
|
|
See `*found-parasites*'."
|
|
(let* ((system (find-system system-name))
|
|
(host-file (system-file-name system)))
|
|
(unless (equalp host-file system-name)
|
|
host-file)))
|
|
|
|
(defun get-loaded (system)
|
|
"Try to load the named system using quicklisp and record any
|
|
dependencies quicklisp is aware of.
|
|
|
|
Unlike `our-quickload', this function doesn't attempt to install
|
|
missing dependencies."
|
|
;; Let's get this party started!
|
|
(let* ((strategy (compute-load-strategy system))
|
|
(ql-systems (quicklisp-systems strategy)))
|
|
(dolist (dep ql-systems)
|
|
(found-new-dependency (name dep)))
|
|
(show-load-strategy strategy)
|
|
(labels
|
|
((make-go ()
|
|
(apply-load-strategy strategy)))
|
|
(call-with-quiet-compilation #'make-go)
|
|
(let ((asdf-system (asdf:find-system system)))
|
|
;; If ASDF says that it needed a system, then we should
|
|
;; probably track that.
|
|
(dolist (asdf-dep (asdf:component-sideway-dependencies asdf-system))
|
|
(found-new-dependency asdf-dep))
|
|
(dolist (asdf-dep (asdf:system-defsystem-depends-on asdf-system))
|
|
(found-new-dependency asdf-dep))))))
|
|
|
|
(defun our-quickload (system)
|
|
"Attempt to install a package like quicklisp would, but record any
|
|
dependencies that are detected during the install."
|
|
(setf system (string-downcase system))
|
|
;; Load it quickly, but do it OUR way. Turns out our way is very
|
|
;; similar to the quicklisp way...
|
|
(let ((already-tried (make-hash-table :test #'equalp))) ;; Case insensitive
|
|
(tagbody
|
|
retry
|
|
(handler-case
|
|
(get-loaded system)
|
|
(asdf/find-component:missing-dependency (e)
|
|
(let ((required-by (asdf/find-component:missing-required-by e))
|
|
(missing (asdf/find-component:missing-requires e)))
|
|
(unless (typep required-by 'asdf:system)
|
|
(error e))
|
|
(when (gethash missing already-tried)
|
|
(error "Dependency loop? ~A" missing))
|
|
(setf (gethash missing already-tried) t)
|
|
(let ((parasitic-p (parasitic-relationship-p *main-system* missing)))
|
|
(if parasitic-p
|
|
(found-new-parasite missing)
|
|
(found-new-dependency missing))
|
|
;; We always want to track the dependencies of systems
|
|
;; that share an asd file with the main system. The
|
|
;; whole asd file should be loadable. Otherwise, we
|
|
;; don't want to include transitive dependencies.
|
|
(let ((*track-dependencies* parasitic-p))
|
|
(our-quickload missing)))
|
|
(format t "Attempting to load ~A again~%" system)
|
|
(go retry)))))))
|
|
|
|
(defvar *blacklisted-parasites*
|
|
#("hu.dwim.stefil/documentation" ;; This system depends on :hu.dwim.stefil.test, but it should depend on hu.dwim.stefil/test
|
|
"named-readtables/doc" ;; Dependency cycle between named-readtabes and mgl-pax
|
|
"symbol-munger-test" ;; Dependency cycle between lisp-unit2 and symbol-munger
|
|
"cl-postgres-simple-date-tests" ;; Dependency cycle between cl-postgres and simple-date
|
|
"cl-containers/with-variates") ;; Symbol conflict between cl-variates:next-element, metabang.utilities:next-element
|
|
"A vector of systems that shouldn't be loaded by `quickload-parasitic-systems'.
|
|
|
|
These systems are known to be troublemakers. In some sense, all
|
|
parasites are troublemakers (you shouldn't define parasitic systems!).
|
|
However, these systems prevent us from generating nix packages and are
|
|
thus doubly evil.")
|
|
|
|
(defvar *blacklisted-parasites-table*
|
|
(let ((ht (make-hash-table :test #'equalp)))
|
|
(loop :for system :across *blacklisted-parasites* :do
|
|
(setf (gethash system ht) t))
|
|
ht)
|
|
"A hash table where each entry in `*blacklisted-parasites*' is an
|
|
entry in the table.")
|
|
|
|
(defun blacklisted-parasite-p (system-name)
|
|
"Returns non-nil if the named system is blacklisted"
|
|
(nth-value 1 (gethash system-name *blacklisted-parasites-table*)))
|
|
|
|
(defun quickload-parasitic-systems (system)
|
|
"Attempt to load all the systems defined in the same asd as the named system.
|
|
|
|
Blacklisted systems are skipped. Dependencies of the identified
|
|
parasitic systems will be tracked."
|
|
(let* ((asdf-system (asdf:find-system system))
|
|
(source-file (asdf:system-source-file asdf-system)))
|
|
(cond
|
|
(source-file
|
|
(loop :for system-name :being :the :hash-keys :of asdf/find-system::*registered-systems* :do
|
|
; for an unclear reason, a literal 0 which is not a key in the hash table gets observed
|
|
(when (and (gethash system-name asdf/find-system::*registered-systems*)
|
|
(parasitic-relationship-p system system-name)
|
|
(not (blacklisted-parasite-p system-name)))
|
|
(found-new-parasite system-name)
|
|
(let ((*track-dependencies* t))
|
|
(our-quickload system-name)))))
|
|
(t
|
|
(unless (or (equal "uiop" system)
|
|
(equal "asdf" system))
|
|
(warn "No source file for system ~A. Can't identify parasites." system))))))
|
|
|
|
(defun determine-dependencies (system)
|
|
"Load the named system and return a sorted vector containing all the
|
|
quicklisp systems that were loaded to satisfy dependencies.
|
|
|
|
This function should probably only be called once per process!
|
|
Subsequent calls will miss dependencies identified by earlier calls."
|
|
(tagbody
|
|
retry
|
|
(restart-case
|
|
(let ((*standard-output* (make-broadcast-stream))
|
|
(*trace-output* (make-broadcast-stream))
|
|
(*main-system* system)
|
|
(*track-dependencies* t))
|
|
(our-quickload system)
|
|
(quickload-parasitic-systems system))
|
|
(try-again ()
|
|
:report "Start the quickload over again"
|
|
(go retry))
|
|
(die ()
|
|
:report "Just give up and die"
|
|
(uiop:quit 1))))
|
|
|
|
;; Systems can't depend on themselves!
|
|
(forget-dependency system)
|
|
(values))
|
|
|
|
(defun parasitic-system-data (parasite-system)
|
|
"Return a plist of information about the given known-parastic system.
|
|
|
|
Sometimes we are asked to provide information about a system that is
|
|
actually a parasite. The only correct response is to point them
|
|
toward the host system. The nix package for the host system should
|
|
have all the dependencies for this parasite already recorded.
|
|
|
|
The plist is only meant to be consumed by other parts of
|
|
quicklisp-to-nix."
|
|
(let ((host-system (host-system parasite-system)))
|
|
(list
|
|
:system parasite-system
|
|
:host host-system
|
|
:name (string-downcase (format nil "~a" parasite-system))
|
|
:host-name (string-downcase (format nil "~a" host-system)))))
|
|
|
|
(defun system-data (system)
|
|
"Produce a plist describing a system.
|
|
|
|
The plist is only meant to be consumed by other parts of
|
|
quicklisp-to-nix."
|
|
(when (host-system system)
|
|
(return-from system-data
|
|
(parasitic-system-data system)))
|
|
|
|
(determine-dependencies system)
|
|
(let*
|
|
((dependencies (sort (found-dependencies) #'string<))
|
|
(parasites (coerce (sort (found-parasites) #'string<) 'list))
|
|
(ql-system (find-system system))
|
|
(ql-release (release ql-system))
|
|
(ql-sibling-systems (provided-systems ql-release))
|
|
(url (archive-url ql-release))
|
|
(local-archive (local-archive-file ql-release))
|
|
(local-url (format nil "file://~a" (pathname local-archive)))
|
|
(archive-data
|
|
(progn
|
|
(ensure-local-archive-file ql-release)
|
|
;; Stuff this archive into the nix store. It was almost
|
|
;; certainly going to end up there anyway (since it will
|
|
;; probably be fetchurl'd for a nix package). Also, putting
|
|
;; it into the store also gives us the SHA we need.
|
|
(nix-prefetch-url local-url)))
|
|
(ideal-md5 (archive-md5 ql-release))
|
|
(raw-dependencies (coerce dependencies 'list))
|
|
(name (string-downcase (format nil "~a" system)))
|
|
(ql-sibling-names
|
|
(remove name (mapcar 'name ql-sibling-systems)
|
|
:test 'equal))
|
|
(dependencies raw-dependencies)
|
|
(description
|
|
(or
|
|
(ignore-errors (asdf:system-description (asdf:find-system system)))
|
|
"System lacks description"))
|
|
(release-name (short-description ql-release)))
|
|
(list
|
|
:system system
|
|
:description description
|
|
:sha256 (getf archive-data :sha256)
|
|
:url url
|
|
:md5 ideal-md5
|
|
:name name
|
|
:dependencies dependencies
|
|
:siblings ql-sibling-names
|
|
:release-name release-name
|
|
:parasites parasites)))
|
|
|
|
(defvar *error-escape-valve* *error-output*
|
|
"When `*error-output*' is rebound to inhibit spew, this stream will
|
|
still produce output.")
|
|
|
|
(defun print-usage-and-quit ()
|
|
"Describe how to use this program... and then exit."
|
|
(format *error-output* "Usage:
|
|
~A [--cacheDir <dir>] [--silent] [--debug] [--help|-h] <system-name>
|
|
Arguments:
|
|
--cacheDir Store (and look for) compiled lisp files in the given directory
|
|
--verbose Show compilation output
|
|
--debug Enter the debugger when a fatal error is encountered
|
|
--help Print usage and exit
|
|
<system-name> The quicklisp system to examine
|
|
" (or (uiop:argv0) "quicklisp-to-nix-system-info"))
|
|
(uiop:quit 2))
|
|
|
|
(defun main ()
|
|
"Make it go."
|
|
(let ((argv (uiop:command-line-arguments))
|
|
cache-dir
|
|
target-system
|
|
verbose-p
|
|
debug-p)
|
|
(handler-bind
|
|
((warning
|
|
(lambda (w)
|
|
(format *error-escape-valve* "~A~%" w)))
|
|
(error
|
|
(lambda (e)
|
|
(if debug-p
|
|
(invoke-debugger e)
|
|
(progn
|
|
(format *error-escape-valve* "~
|
|
Failed to extract system info. Details are below. ~
|
|
Run with --debug and/or --verbose for more info.
|
|
~A~%" e)
|
|
(uiop:quit 1))))))
|
|
(loop :while argv :do
|
|
(cond
|
|
((equal "--cacheDir" (first argv))
|
|
(pop argv)
|
|
(unless argv
|
|
(error "--cacheDir expects an argument"))
|
|
(setf cache-dir (first argv))
|
|
(pop argv))
|
|
|
|
((equal "--verbose" (first argv))
|
|
(setf verbose-p t)
|
|
(pop argv))
|
|
|
|
((equal "--debug" (first argv))
|
|
(setf debug-p t)
|
|
(pop argv))
|
|
|
|
((or (equal "--help" (first argv))
|
|
(equal "-h" (first argv)))
|
|
(print-usage-and-quit))
|
|
|
|
(t
|
|
(setf target-system (pop argv))
|
|
(when argv
|
|
(error "Can only operate on one system")))))
|
|
|
|
(unless target-system
|
|
(print-usage-and-quit))
|
|
|
|
(when cache-dir
|
|
(setf cache-dir (pathname-as-directory (parse-namestring cache-dir))))
|
|
|
|
(mapcar (function require) *implementation-systems*)
|
|
|
|
(with-quicklisp (dir) (:cache-dir (or cache-dir :temp))
|
|
(declare (ignore dir))
|
|
|
|
(let (system-data)
|
|
(let ((*error-output* (if verbose-p
|
|
*error-output*
|
|
(make-broadcast-stream)))
|
|
(*standard-output* (if verbose-p
|
|
*standard-output*
|
|
(make-broadcast-stream)))
|
|
(*trace-output* (if verbose-p
|
|
*trace-output*
|
|
(make-broadcast-stream))))
|
|
(format *error-output*
|
|
"quicklisp-to-nix-system-info ~A~%ASDF ~A~%Quicklisp ~A~%Compiler ~A ~A~%"
|
|
*version*
|
|
(asdf:asdf-version)
|
|
(funcall (intern "CLIENT-VERSION" :ql))
|
|
(lisp-implementation-type)
|
|
(lisp-implementation-version))
|
|
(setf system-data (system-data target-system)))
|
|
|
|
(cond
|
|
(system-data
|
|
(format t "~W~%" system-data)
|
|
(uiop:quit 0))
|
|
(t
|
|
(format *error-output* "Failed to determine system data~%")
|
|
(uiop:quit 1))))))))
|
|
|
|
(defun dump-image ()
|
|
"Make an executable"
|
|
(setf uiop:*image-entry-point* #'main)
|
|
(setf uiop:*lisp-interaction* nil)
|
|
(uiop:dump-image "quicklisp-to-nix-system-info" :executable t))
|