depot/third_party/nixpkgs/pkgs/development/lisp-modules/quicklisp-to-nix/ql-to-nix.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_")
          (#\+ "_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))