f0c8027ae3
1. Detect (and automatically handle) parasitic systems. 2. Each nix package has only one asd, and (almost) every parasitic package inside it builds. 3. Ensure that parasitic systems are compiled. 4. Remove unnecessary testnames lisp override mechanism (the testnae/testSystem is replaced by parasites/buildSystems). 5. Parasitic systems (if included in the system closure) become aliases to their host package. 6. Support caching fasl files in a known directory (for faster re-generation after modifying quicklisp-to-nix-system-info). 7. Eliminate unnecessary overrides. We're going to determine ALL lisp dependencies correctly. 8. Don't try to "build" lisp packages with make. lispPackages should be about bringing in a lisp library. 9. Eliminate the hand-maintained list of aliases. Parasites should become aliases. Everything else should be a real package.
325 lines
11 KiB
Common Lisp
325 lines
11 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
|
|
(:use :common-lisp :ql-to-nix-util :ql-to-nix-quicklisp-bootstrap))
|
|
(in-package :ql-to-nix)
|
|
|
|
;; We're going to pull in our dependencies at image dumping time in an
|
|
;; isolated quicklisp installation. Unfortunately, that means that we
|
|
;; can't yet access the symbols for our dependencies. We can probably
|
|
;; do better (by, say, loading these dependencies before this file),
|
|
;; but...
|
|
|
|
(defvar *required-systems* nil)
|
|
|
|
(push :cl-emb *required-systems*)
|
|
(wrap :cl-emb register-emb)
|
|
(wrap :cl-emb execute-emb)
|
|
|
|
(push :external-program *required-systems*)
|
|
(wrap :external-program run)
|
|
|
|
(push :cl-ppcre *required-systems*)
|
|
(wrap :cl-ppcre split)
|
|
(wrap :cl-ppcre regex-replace-all)
|
|
(wrap :cl-ppcre scan)
|
|
|
|
(push :alexandria *required-systems*)
|
|
(wrap :alexandria read-file-into-string)
|
|
(wrap :alexandria write-string-into-file)
|
|
|
|
(push :md5 *required-systems*)
|
|
(wrap :md5 md5sum-file)
|
|
|
|
(wrap :ql-dist find-system)
|
|
(wrap :ql-dist release)
|
|
(wrap :ql-dist provided-systems)
|
|
(wrap :ql-dist archive-url)
|
|
(wrap :ql-dist local-archive-file)
|
|
(wrap :ql-dist ensure-local-archive-file)
|
|
(wrap :ql-dist archive-md5)
|
|
(wrap :ql-dist name)
|
|
(wrap :ql-dist short-description)
|
|
|
|
(defun escape-filename (s)
|
|
(format
|
|
nil "~a~{~a~}"
|
|
(if (scan "^[a-zA-Z_]" s) "" "_")
|
|
(loop
|
|
for x in (map 'list 'identity s)
|
|
collect
|
|
(case x
|
|
(#\/ "_slash_")
|
|
(#\\ "_backslash_")
|
|
(#\_ "__")
|
|
(#\. "_dot_")
|
|
(t x)))))
|
|
|
|
(defvar *system-info-bin*
|
|
(let* ((path (uiop:getenv "system-info"))
|
|
(path-dir (if (equal #\/ (aref path (1- (length path))))
|
|
path
|
|
(concatenate 'string path "/")))
|
|
(pathname (parse-namestring path-dir)))
|
|
(merge-pathnames #P"bin/quicklisp-to-nix-system-info" pathname))
|
|
"The path to the quicklisp-to-nix-system-info binary.")
|
|
|
|
(defvar *cache-dir* nil
|
|
"The folder where fasls will be cached.")
|
|
|
|
(defun raw-system-info (system-name)
|
|
"Run quicklisp-to-nix-system-info on the given system and return the
|
|
form produced by the program."
|
|
(when *cache-dir*
|
|
(let ((command `(,*system-info-bin* "--cacheDir" ,(namestring *cache-dir*) ,system-name)))
|
|
(handler-case
|
|
(return-from raw-system-info
|
|
(read (make-string-input-stream (uiop:run-program command :output :string))))
|
|
(error (e)
|
|
;; Some systems don't like the funky caching that we're
|
|
;; doing. That's okay. Let's try it uncached before we
|
|
;; give up.
|
|
(warn "Unable to use cache for system ~A.~%~A" system-name e)))))
|
|
(read (make-string-input-stream (uiop:run-program `(,*system-info-bin* ,system-name) :output :string))))
|
|
|
|
(defvar *system-data-memoization-path* nil
|
|
"The path to the folder where fully-resolved system information can
|
|
be cached.
|
|
|
|
If information for a system is found in this directory, `system-data'
|
|
will use it instead of re-computing the system data.")
|
|
|
|
(defvar *system-data-in-memory-memoization*
|
|
(make-hash-table :test #'equalp))
|
|
|
|
(defun memoized-system-data-path (system)
|
|
"Return the path to the file that (if it exists) contains
|
|
pre-computed system data."
|
|
(when *system-data-memoization-path*
|
|
(merge-pathnames (make-pathname :name system :type "txt") *system-data-memoization-path*)))
|
|
|
|
(defun memoized-system-data (system)
|
|
"Attempts to locate memoized system data in the path specified by
|
|
`*system-data-memoization-path*'."
|
|
(multiple-value-bind (value found) (gethash system *system-data-in-memory-memoization*)
|
|
(when found
|
|
(return-from memoized-system-data (values value found))))
|
|
(let ((path (memoized-system-data-path system)))
|
|
(unless path
|
|
(return-from memoized-system-data (values nil nil)))
|
|
(with-open-file (s path :if-does-not-exist nil :direction :input)
|
|
(unless s
|
|
(return-from memoized-system-data (values nil nil)))
|
|
(return-from memoized-system-data (values (read s) t)))))
|
|
|
|
(defun set-memoized-system-data (system data)
|
|
"Store system data in the path specified by
|
|
`*system-data-memoization-path*'."
|
|
(setf (gethash system *system-data-in-memory-memoization*) data)
|
|
(let ((path (memoized-system-data-path system)))
|
|
(unless path
|
|
(return-from set-memoized-system-data data))
|
|
(with-open-file (s path :direction :output :if-exists :supersede)
|
|
(format s "~W" data)))
|
|
data)
|
|
|
|
(defun system-data (system)
|
|
"Examine a quicklisp system name and figure out everything that is
|
|
required to produce a nix package.
|
|
|
|
This function stores results for memoization purposes in files within
|
|
`*system-data-memoization-path*'."
|
|
(multiple-value-bind (value found) (memoized-system-data system)
|
|
(when found
|
|
(return-from system-data value)))
|
|
(format t "Examining system ~A~%" system)
|
|
(let* ((system-info (raw-system-info system))
|
|
(host (getf system-info :host))
|
|
(host-name (getf system-info :host-name))
|
|
(name (getf system-info :name)))
|
|
(when host
|
|
(return-from system-data
|
|
(set-memoized-system-data
|
|
system
|
|
(list
|
|
:system (getf system-info :system)
|
|
:host host
|
|
:filename (escape-filename name)
|
|
:host-filename (escape-filename host-name)))))
|
|
|
|
(let* ((url (getf system-info :url))
|
|
(sha256 (getf system-info :sha256))
|
|
(archive-data (nix-prefetch-url url :expected-sha256 sha256))
|
|
(archive-path (getf archive-data :path))
|
|
(archive-md5 (string-downcase
|
|
(format nil "~{~16,2,'0r~}"
|
|
(map 'list 'identity (md5sum-file archive-path)))))
|
|
(stated-md5 (getf system-info :md5))
|
|
(dependencies (getf system-info :dependencies))
|
|
(deps (mapcar (lambda (x) (list :name x :filename (escape-filename x)))
|
|
dependencies))
|
|
(description (getf system-info :description))
|
|
(siblings (getf system-info :siblings))
|
|
(release-name (getf system-info :release-name))
|
|
(parasites (getf system-info :parasites))
|
|
(version (regex-replace-all
|
|
(format nil "~a-" name) release-name "")))
|
|
(assert (equal archive-md5 stated-md5))
|
|
(set-memoized-system-data
|
|
system
|
|
(list
|
|
:system system
|
|
:description description
|
|
:sha256 sha256
|
|
:url url
|
|
:md5 stated-md5
|
|
:name name
|
|
:filename (escape-filename name)
|
|
:deps deps
|
|
:dependencies dependencies
|
|
:version version
|
|
:siblings siblings
|
|
:parasites parasites)))))
|
|
|
|
(defun parasitic-p (data)
|
|
(getf data :host))
|
|
|
|
(defvar *loaded-from* (or *compile-file-truename* *load-truename*)
|
|
"Where this source file is located.")
|
|
|
|
(defun this-file ()
|
|
"Where this source file is located or an error."
|
|
(or *loaded-from* (error "Not sure where this file is located!")))
|
|
|
|
(defun nix-expression (system)
|
|
(execute-emb
|
|
"nix-package"
|
|
:env (system-data system)))
|
|
|
|
(defun nix-invocation (system)
|
|
(let ((data (system-data system)))
|
|
(if (parasitic-p data)
|
|
(execute-emb
|
|
"parasitic-invocation"
|
|
:env data)
|
|
(execute-emb
|
|
"invocation"
|
|
:env data))))
|
|
|
|
(defun systems-closure (systems)
|
|
(let*
|
|
((seen (make-hash-table :test 'equal)))
|
|
(loop
|
|
with queue := systems
|
|
with res := nil
|
|
while queue
|
|
for next := (pop queue)
|
|
for old := (gethash next seen)
|
|
for data := (unless old (system-data next))
|
|
for deps := (getf data :dependencies)
|
|
for siblings := (getf data :siblings)
|
|
unless old do
|
|
(progn
|
|
(push next res)
|
|
(setf queue (append queue deps)))
|
|
do (setf (gethash next seen) t)
|
|
finally (return res))))
|
|
|
|
(defun ql-to-nix (target-directory)
|
|
(let*
|
|
((systems
|
|
(split
|
|
(format nil "~%")
|
|
(read-file-into-string
|
|
(format nil "~a/quicklisp-to-nix-systems.txt" target-directory))))
|
|
(closure (systems-closure systems))
|
|
(invocations
|
|
(loop for s in closure
|
|
collect (list :code (nix-invocation s)))))
|
|
(loop
|
|
for s in closure
|
|
do (unless (parasitic-p (system-data s))
|
|
(write-string-into-file
|
|
(nix-expression s)
|
|
(format nil "~a/quicklisp-to-nix-output/~a.nix"
|
|
target-directory (escape-filename s))
|
|
:if-exists :supersede)))
|
|
(write-string-into-file
|
|
(execute-emb
|
|
"top-package"
|
|
:env (list :invocations invocations))
|
|
(format nil "~a/quicklisp-to-nix.nix" target-directory)
|
|
:if-exists :supersede)))
|
|
|
|
(defun print-usage-and-quit ()
|
|
"Does what it says on the tin."
|
|
(format *error-output* "Usage:
|
|
~A [--help] [--cacheSystemInfoDir <path>] <work-dir>
|
|
Arguments:
|
|
--cacheSystemInfoDir Store computed system info in the given directory
|
|
--help Print usage and exit
|
|
<work-dir> Path to directory with quicklisp-to-nix-systems.txt
|
|
" (uiop:argv0))
|
|
(uiop:quit 2))
|
|
|
|
(defun main ()
|
|
"Make it go"
|
|
(let ((argv (uiop:command-line-arguments))
|
|
work-directory
|
|
cache-system-info-directory
|
|
cache-fasl-directory)
|
|
(loop :while argv :for arg = (pop argv) :do
|
|
(cond
|
|
((equal arg "--cacheSystemInfoDir")
|
|
(unless argv
|
|
(format *error-output* "--cacheSystemInfoDir requires an argument~%")
|
|
(print-usage-and-quit))
|
|
(setf cache-system-info-directory (pop argv)))
|
|
|
|
((equal arg "--cacheFaslDir")
|
|
(unless argv
|
|
(format *error-output* "--cacheFaslDir requires an argument~%")
|
|
(print-usage-and-quit))
|
|
(setf cache-fasl-directory (pop argv)))
|
|
|
|
((equal arg "--help")
|
|
(print-usage-and-quit))
|
|
|
|
(t
|
|
(when argv
|
|
(format *error-output* "Only one positional argument allowed~%")
|
|
(print-usage-and-quit))
|
|
(setf work-directory arg))))
|
|
|
|
(when cache-system-info-directory
|
|
(setf cache-system-info-directory (pathname-as-directory (pathname cache-system-info-directory)))
|
|
(ensure-directories-exist cache-system-info-directory))
|
|
|
|
(labels
|
|
((make-go (*cache-dir*)
|
|
(format t "Caching fasl files in ~A~%" *cache-dir*)
|
|
|
|
(let ((*system-data-memoization-path* cache-system-info-directory))
|
|
(ql-to-nix work-directory))))
|
|
(if cache-fasl-directory
|
|
(make-go (truename (pathname-as-directory (parse-namestring (ensure-directories-exist cache-fasl-directory)))))
|
|
(with-temporary-directory (*cache-dir*)
|
|
(make-go *cache-dir*))))))
|
|
|
|
(defun dump-image ()
|
|
"Make an executable"
|
|
(with-quicklisp (dir) ()
|
|
(declare (ignore dir))
|
|
(dolist (system *required-systems*)
|
|
(funcall (sym :ql :quickload) system)))
|
|
(register-emb "nix-package" (merge-pathnames #p"nix-package.emb" (this-file)))
|
|
(register-emb "invocation" (merge-pathnames #p"invocation.emb" (this-file)))
|
|
(register-emb "parasitic-invocation" (merge-pathnames #p"parasitic-invocation.emb" (this-file)))
|
|
(register-emb "top-package" (merge-pathnames #p"top-package.emb" (this-file)))
|
|
(setf uiop:*image-entry-point* #'main)
|
|
(setf uiop:*lisp-interaction* nil)
|
|
(setf *loaded-from* nil) ;; Break the link to our source
|
|
(uiop:dump-image "quicklisp-to-nix" :executable t))
|