diff options
Diffstat (limited to 'pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp')
| -rw-r--r-- | pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp | 327 |
1 files changed, 327 insertions, 0 deletions
diff --git a/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp new file mode 100644 index 000000000000..4a82b6cafa6f --- /dev/null +++ b/pkgs/development/lisp-modules-obsolete/quicklisp-to-nix/ql-to-nix.lisp @@ -0,0 +1,327 @@ +(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_") + (#\+ "_plus_") + (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 (escape-filename (string 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>] [--cacheFaslDir <path>] <work-dir> +Arguments: + --cacheSystemInfoDir Store computed system info in the given directory + --cacheFaslDir Store intermediate fast load files 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" + (dolist (system *required-systems*) + (asdf:make 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)) |