push sheeet

pkgs/development/lisp-modules/import/api.lisp

@@ -0,0 +1,18 @@
+(defpackage org.lispbuilds.nix/api
+  (:documentation "Public interface of org.lispbuilds.nix")
+  (:use :cl)
+  (:export
+   :import-lisp-packages
+   :database->nix-expression))
+
+(in-package org.lispbuilds.nix/api)
+
+(defgeneric import-lisp-packages (repository database)
+  (:documentation
+   "Import Lisp packages (ASDF systems) from repository (Quicklisp,
+   Ultralisp etc.) into a package database."))
+
+(defgeneric database->nix-expression (database outfile)
+  (:documentation
+   "Generate a nix expression from the package database and write it
+   into outfile."))

pkgs/development/lisp-modules/import/database/sqlite.lisp

@@ -0,0 +1,175 @@
+(defpackage org.lispbuilds.nix/database/sqlite
+  (:use :cl)
+  (:import-from :str)
+  (:import-from :sqlite)
+  (:import-from :alexandria :read-file-into-string)
+  (:import-from :alexandria-2 :line-up-first)
+  (:import-from :arrow-macros :->>)
+  (:import-from
+   :org.lispbuilds.nix/util
+   :replace-regexes)
+  (:import-from
+   :org.lispbuilds.nix/nix
+   :nix-eval
+   :nixify-symbol
+   :system-master
+   :make-pname
+   :*nix-attrs-depth*)
+  (:import-from
+   :org.lispbuilds.nix/api
+   :database->nix-expression)
+  (:export :sqlite-database :init-db)
+  (:local-nicknames
+   (:hydra :org.lispbuilds.nix/hydra)
+   (:json :com.inuoe.jzon)))
+
+(in-package org.lispbuilds.nix/database/sqlite)
+
+(defclass sqlite-database ()
+  ((url :initarg :url
+        :reader database-url
+        :initform (error "url required"))
+   (init-file :initarg :init-file
+              :reader init-file
+              :initform (error "init file required"))))
+
+(defun init-db (db init-file)
+  (let ((statements (->> (read-file-into-string init-file)
+                         (replace-regexes '(".*--.*") '(""))
+                         (substitute #\Space #\Newline)
+                         (str:collapse-whitespaces)
+                         (str:split #\;)
+                         (mapcar #'str:trim)
+                         (remove-if #'str:emptyp))))
+    (sqlite:with-transaction db
+      (dolist (s statements)
+        (sqlite:execute-non-query db s)))))
+
+
+;; Writing Nix
+
+(defparameter prelude "
+# This file was auto-generated by nix-quicklisp.lisp
+
+{ runCommand, pkgs, lib, fetchzip, build-asdf-system, ... }:
+
+let
+
+ inherit (builtins) getAttr;
+
+# Ensures that every non-slashy `system` exists in a unique .asd file.
+# (Think cl-async-base being declared in cl-async.asd upstream)
+#
+# This is required because we're building and loading a system called
+# `system`, not `asd`, so otherwise `system` would not be loadable
+# without building and loading `asd` first.
+#
+ createAsd = { url, sha256, asd, system }:
+   let
+     src = fetchzip { inherit url sha256; };
+   in
+     if asd == system
+     then src
+     else runCommand \"source\" {} ''
+       mkdir -pv $out
+       cp -r ${src}/* $out
+       find $out -name \"${asd}.asd\" | while read f; do mv -fv $f $(dirname $f)/${system}.asd || true; done
+     '';
+in lib.makeScope pkgs.newScope (self: {")
+
+;; Random compilation errors
+(defparameter +broken-packages+
+  (list
+   ;; no dispatch function defined for #\t
+   "hu.dwim.logger"
+   "hu.dwim.serializer"
+   "hu.dwim.quasi-quote"
+   ;; Tries to write in $HOME
+   "ubiquitous"
+   ;; Upstream bad packaging, multiple systems in clml.blas.asd
+   "clml.blas.hompack"
+   ;; Fails on SBCL due to heap exhaustion
+   "magicl"
+   ;; Missing dependency on c2ffi cffi extension
+   "hu.dwim.zlib"
+   ;; These require libRmath.so, but I don't know where to get it from
+   "cl-random"
+   "cl-random-tests"
+   ))
+
+(defmethod database->nix-expression ((database sqlite-database) outfile)
+  (sqlite:with-open-database (db (database-url database))
+    (with-open-file (f outfile
+                       :direction :output
+                       :if-exists :supersede)
+
+      ;; Fix known problematic packages before dumping the nix file.
+      (sqlite:execute-non-query db
+       "create temp table fixed_systems as select * from system_view")
+
+      (sqlite:execute-non-query db
+       "alter table fixed_systems add column systems")
+
+      (sqlite:execute-non-query db
+       "update fixed_systems set systems = json_array(name)")
+
+      (sqlite:execute-non-query db
+       "alter table fixed_systems add column asds")
+
+      (sqlite:execute-non-query db
+       "update fixed_systems set asds = json_array(name)")
+
+      (sqlite:execute-non-query db
+       "delete from fixed_systems where name in ('asdf', 'uiop')")
+
+      (sqlite:execute-non-query db
+       "delete from fixed_systems where instr(name, '/')")
+
+      (format f prelude)
+
+      (dolist (p (sqlite:execute-to-list db "select * from fixed_systems"))
+        (destructuring-bind (name version asd url sha256 deps systems asds) p
+          (format f "~%  ")
+          (let ((*nix-attrs-depth* 1))
+            (format
+             f
+             "~a = ~a;"
+             (nix-eval `(:symbol ,name))
+             (nix-eval
+              `(:funcall
+                "build-asdf-system"
+                (:attrs
+                 ("pname" (:string ,(make-pname name)))
+                 ("version" (:string ,version))
+                 ("asds" (:list
+                          ,@(mapcar (lambda (asd)
+                                      `(:string ,(system-master asd)))
+                                    (coerce (json:parse asds) 'list))))
+                 ("src" (:funcall
+                         "createAsd"
+                         (:attrs
+                          ("url" (:string ,url))
+                          ("sha256" (:string ,sha256))
+                          ("system" (:string ,(system-master name)))
+                          ("asd" (:string ,asd)))))
+                 ("systems" (:list
+                             ,@(mapcar (lambda (sys)
+                                         `(:string ,sys))
+                                       (coerce (json:parse systems) 'list))))
+                 ("lispLibs" (:list
+                              ,@(mapcar (lambda (dep)
+                                          `(:funcall
+                                            "getAttr"
+                                            (:string ,(nixify-symbol dep))
+                                            (:symbol "self")))
+                                        (line-up-first
+                                         (str:split-omit-nulls #\, deps)
+                                         (set-difference '("asdf" "uiop") :test #'string=)
+                                         (sort #'string<)))))
+                 ("meta" (:attrs
+                          ,@(when (or (find #\/ name)
+                                      (find name +broken-packages+ :test #'string=))
+                              '(("broken" (:symbol "true"))))
+                          ,@(unless (find name hydra:+allowlist+ :test #'string=)
+                              '(("hydraPlatforms" (:list)))))))))))))
+      (format f "~%})~%"))))

pkgs/development/lisp-modules/import/hydra.lisp

@@ -0,0 +1,416 @@
+(defpackage org.lispbuilds.nix/hydra
+  (:documentation "List of packages allowed to be build on Hydra")
+  (:use :cl)
+  (:export
+   :+allowlist+))
+
+(in-package org.lispbuilds.nix/hydra)
+
+(defparameter +allowlist+
+  (list
+   "_1am"
+   "_3bmd"
+   "_3bmd-ext-code-blocks"
+   "access"
+   "acclimation"
+   "agutil"
+   "alexandria"
+   "anaphora"
+   "arnesi"
+   "array-operations"
+   "array-utils"
+   "arrows"
+   "asdf-package-system"
+   "asdf-system-connections"
+   "babel"
+   "binomial-heap"
+   "binpack"
+   "blackbird"
+   "bordeaux-threads"
+   "buildnode"
+   "buildnode-xhtml"
+   "calispel"
+   "cffi"
+   "cffi-grovel"
+   "cffi-toolchain"
+   "cffi-uffi-compat"
+   "chanl"
+   "check-it"
+   "chipz"
+   "chunga"
+   "circular-streams"
+   "cl-aa"
+   "cl-ana"
+   "cl-annot"
+   "cl-anonfun"
+   "cl-ansi-text"
+   "cl-async"
+   "cl-async-base"
+   "cl-async-repl"
+   "cl-async-ssl"
+   "cl-async-util"
+   "cl-avro"
+   "cl-base64"
+   "cl-cairo2"
+   "cl-cairo2"
+   "cl-cairo2-xlib"
+   "cl-cffi-gtk"
+   "cl-cffi-gtk-cairo"
+   "cl-cffi-gtk-gdk"
+   "cl-cffi-gtk-gdk-pixbuf"
+   "cl-cffi-gtk-gio"
+   "cl-cffi-gtk-glib"
+   "cl-cffi-gtk-gobject"
+   "cl-cffi-gtk-pango"
+   "cl-change-case"
+   "cl-cli"
+   "cl-colors"
+   "cl-colors2"
+   "cl-containers"
+   "cl-cookie"
+   "cl-css"
+   "cl-csv"
+   "cl-cuda"
+   "cl-custom-hash-table"
+   "cl-dbi"
+   "cl-difflib"
+   "cl-digraph"
+   "cl-dot"
+   "cl-emb"
+   "cl-environments"
+   "cl-fad"
+   "cl-form-types"
+   "cl-freetype2"
+   "cl-fuse"
+   "cl-fuse-meta-fs"
+   "cl-fuzz"
+   "cl-geometry"
+   "cl-gobject-introspection"
+   "cl-gtk2-gdk"
+   "cl-gtk2-glib"
+   "cl-gtk2-pango"
+   "cl-gtk4"
+   "cl-gtk4.adw"
+   "cl-gtk4.webkit2"
+   "cl-heap"
+   "cl-hooks"
+   "cl-html-diff"
+   "cl-html-parse"
+   "cl-html5-parser"
+   "cl-interpol"
+   "cl-jpeg"
+   "cl-json"
+   "cl-l10n"
+   "cl-l10n-cldr"
+   "cl-libuv"
+   "cl-libxml2"
+   "cl-libyaml"
+   "cl-locale"
+   "cl-markup"
+   "cl-mustache"
+   "cl-mysql"
+   "cl-num-utils"
+   "cl-pango"
+   "cl-paths"
+   "cl-paths-ttf"
+   "cl-pattern"
+   "cl-pdf"
+   "cl-postgres"
+   "cl-postgres+local-time"
+   "cl-ppcre"
+   "cl-ppcre-template"
+   "cl-ppcre-unicode"
+   "cl-prevalence"
+   "cl-qprint"
+   "cl-qrencode"
+   "cl-readline"
+   "cl-reexport"
+   "cl-rsvg2"
+   "cl-sat"
+   "cl-sat.glucose"
+   "cl-sat.minisat"
+   "cl-shellwords"
+   "cl-slice"
+   "cl-smt-lib"
+   "cl-smtp"
+   "cl-speedy-queue"
+   "cl-store"
+   "cl-svg"
+   "cl-syntax"
+   "cl-syntax-annot"
+   "cl-syntax-anonfun"
+   "cl-syntax-markup"
+   "cl-syslog"
+   "cl-test-more"
+   "cl-typesetting"
+   "cl-unicode"
+   "cl-unification"
+   "cl-utilities"
+   "cl-vectors"
+   "cl-webkit2"
+   "cl-who"
+   "cl-xmlspam"
+   "cl+ssl"
+   "clack"
+   "clack-socket"
+   "classowary"
+   "clfswm"
+   "closer-mop"
+   "closure-common"
+   "closure-html"
+   "clsql"
+   "clsql-postgresql"
+   "clsql-postgresql-socket"
+   "clsql-sqlite3"
+   "clsql-uffi"
+   "clss"
+   "cluffer"
+   "clump"
+   "clump-2-3-tree"
+   "clump-binary-tree"
+   "clunit"
+   "clunit2"
+   "clx"
+   "clx-truetype"
+   "collectors"
+   "colorize"
+   "com.inuoe.jzon"
+   "command-line-arguments"
+   "css-lite"
+   "css-selectors"
+   "css-selectors-simple-tree"
+   "css-selectors-stp"
+   "cxml"
+   "cxml-stp"
+   "data-table"
+   "dbd-mysql"
+   "dbd-postgres"
+   "dbd-sqlite3"
+   "dbi"
+   "dbi-test"
+   "dbus"
+   "defclass-std"
+   "dexador"
+   "dissect"
+   "djula"
+   "do-urlencode"
+   "documentation-utils"
+   "drakma"
+   "eager-future2"
+   "enchant"
+   "esrap"
+   "esrap-peg"
+   "external-program"
+   "fare-csv"
+   "fare-mop"
+   "fare-quasiquote"
+   "fare-quasiquote-extras"
+   "fare-quasiquote-optima"
+   "fare-quasiquote-readtable"
+   "fare-utils"
+   "fast-http"
+   "fast-io"
+   "fiasco"
+   "file-attributes"
+   "fiveam"
+   "flexi-streams"
+   "float-features"
+   "flow"
+   "fn"
+   "form-fiddle"
+   "fset"
+   "generic-cl"
+   "gettext"
+   "global-vars"
+   "glsl-docs"
+   "glsl-spec"
+   "glsl-symbols"
+   "gsll"
+   "heap"
+   "html-encode"
+   "http-body"
+   "hu.dwim.asdf"
+   "hu.dwim.common"
+   "hu.dwim.common-lisp"
+   "hu.dwim.def"
+   "hu.dwim.def+swank"
+   "hu.dwim.defclass-star"
+   "hu.dwim.stefil"
+   "hu.dwim.stefil+hu.dwim.def"
+   "hu.dwim.stefil+hu.dwim.def+swank"
+   "hu.dwim.stefil+swank"
+   "hunchensocket"
+   "hunchentoot"
+   "idna"
+   "ieee-floats"
+   "inferior-shell"
+   "introspect-environment"
+   "iolib"
+   "iolib.asdf"
+   "iolib.base"
+   "iolib.common-lisp"
+   "iolib.conf"
+   "ironclad"
+   "iterate"
+   "jonathan"
+   "jpl-queues"
+   "jpl-util"
+   "jsown"
+   "kmrcl"
+   "lack"
+   "lack-component"
+   "lack-middleware-backtrace"
+   "lack-util"
+   "lambda-fiddle"
+   "legit"
+   "let-plus"
+   "lev"
+   "lfarm-client"
+   "lfarm-common"
+   "lfarm-server"
+   "lfarm-ssl"
+   "lift"
+   "lisp-binary"
+   "lisp-namespace"
+   "lisp-unit"
+   "lisp-unit2"
+   "lla"
+   "local-time"
+   "log4cl"
+   "lparallel"
+   "lquery"
+   "ltk"
+   "marshal"
+   "md5"
+   "metabang-bind"
+   "metatilities-base"
+   "mgl"
+   "mgl-mat"
+   "mgl-pax"
+   "minheap"
+   "misc-extensions"
+   "mk-string-metrics"
+   "mmap"
+   "moptilities"
+   "more-conditions"
+   "mt19937"
+   "named-readtables"
+   "nbd"
+   "net-telent-date"
+   "net.didierverna.asdf-flv"
+   "nibbles"
+   "nyxt"
+   "optima"
+   "osicat"
+   "parachute"
+   "parenscript"
+   "parse-declarations-1.0"
+   "parse-float"
+   "parse-number"
+   "parseq"
+   "parser-combinators"
+   "parser.common-rules"
+   "pcall"
+   "pcall-queue"
+   "physical-quantities"
+   "plump"
+   "postmodern"
+   "proc-parse"
+   "prove"
+   "prove-asdf"
+   "ptester"
+   "puri"
+   "pythonic-string-reader"
+   "pzmq"
+   "pzmq-compat"
+   "pzmq-examples"
+   "pzmq-test"
+   "qt"
+   "qt-libs"
+   "qtools"
+   "quasiquote-2.0"
+   "query-fs"
+   "quri"
+   "rfc2388"
+   "rove"
+   "rt"
+   "s-sql"
+   "s-sysdeps"
+   "s-xml"
+   "salza2"
+   "serapeum"
+   "simple-date"
+   "simple-date-time"
+   "simple-inferiors"
+   "simple-tasks"
+   "slynk"
+   "smart-buffer"
+   "smug"
+   "spinneret"
+   "split-sequence"
+   "sqlite"
+   "static-dispatch"
+   "static-vectors"
+   "stefil"
+   "str"
+   "string-case"
+   "stumpwm"
+   "swank"
+   "swap-bytes"
+   "sycamore"
+   "symbol-munger"
+   "trees"
+   "trivia"
+   "trivia.balland2006"
+   "trivia.level0"
+   "trivia.level1"
+   "trivia.level2"
+   "trivia.quasiquote"
+   "trivia.trivial"
+   "trivial-arguments"
+   "trivial-backtrace"
+   "trivial-clipboard"
+   "trivial-cltl2"
+   "trivial-features"
+   "trivial-file-size"
+   "trivial-garbage"
+   "trivial-gray-streams"
+   "trivial-indent"
+   "trivial-macroexpand-all"
+   "trivial-main-thread"
+   "trivial-mimes"
+   "trivial-package-local-nicknames"
+   "trivial-package-manager"
+   "trivial-shell"
+   "trivial-types"
+   "trivial-utf-8"
+   "trivial-with-current-source-form"
+   "type-i"
+   "uax-15"
+   "uffi"
+   "unit-test"
+   "unix-options"
+   "unix-opts"
+   "usocket"
+   "usocket-server"
+   "utilities.print-items"
+   "utilities.print-tree"
+   "uuid"
+   "varjo"
+   "vas-string-metrics"
+   "vecto"
+   "vom"
+   "wild-package-inferred-system"
+   "woo"
+   "wookie"
+   "xembed"
+   "xkeyboard"
+   "xml.location"
+   "xmls"
+   "xpath"
+   "xsubseq"
+   "yacc"
+   "yason"
+   "zpb-ttf"
+   "zpng"
+   ))

pkgs/development/lisp-modules/import/init.sql

@@ -0,0 +1,41 @@
+CREATE TABLE IF NOT EXISTS sha256 (
+       id        integer PRIMARY KEY AUTOINCREMENT,
+       url       text    UNIQUE,
+       hash      text    NOT NULL,
+       created   real    DEFAULT (julianday('now'))
+);
+
+CREATE TABLE IF NOT EXISTS system (
+       id        integer PRIMARY KEY AUTOINCREMENT,
+       name      text NOT NULL,
+       version   text NOT NULL,
+       asd       text NOT NULL,
+       created   real    DEFAULT (julianday('now')),
+       UNIQUE(name, version)
+);
+
+CREATE TABLE IF NOT EXISTS dep (
+       system_id integer NOT NULL REFERENCES system(id),
+       dep_id    integer NOT NULL REFERENCES system(id),
+       PRIMARY KEY (system_id, dep_id)
+);
+
+CREATE TABLE IF NOT EXISTS src (
+       sha256_id integer REFERENCES sha256(id),
+       system_id integer UNIQUE REFERENCES system(id)
+);
+
+DROP VIEW IF EXISTS system_view;
+CREATE VIEW IF NOT EXISTS system_view AS
+  SELECT
+    sys.name,
+    sys.version,
+    sys.asd,
+    sha.url,
+    sha.hash,
+    group_concat((SELECT name FROM system WHERE id = dep.dep_id)) as deps
+  FROM system sys
+  JOIN src ON src.system_id = sys.id
+  JOIN sha256 sha ON sha.id = src.sha256_id
+  LEFT JOIN dep ON dep.system_id = sys.id
+  GROUP BY sys.name;

pkgs/development/lisp-modules/import/main.lisp

@@ -0,0 +1,59 @@
+(defpackage org.lispbuilds.nix/main
+  (:use :common-lisp
+        :org.lispbuilds.nix/database/sqlite
+        :org.lispbuilds.nix/repository/quicklisp
+        :org.lispbuilds.nix/api)
+  (:local-nicknames
+   (:http :dexador)))
+
+(in-package org.lispbuilds.nix/main)
+
+(defun resource (name type)
+  (make-pathname
+   :defaults (asdf:system-source-directory :org.lispbuilds.nix)
+   :name name
+   :type type))
+
+(defvar *sqlite*
+  (make-instance
+   'sqlite-database
+   :init-file (resource "init" "sql")
+   :url "packages.sqlite"))
+
+(defvar *quicklisp* nil)
+
+(defun get-quicklisp-version ()
+  (let ((response (http:get "http://beta.quicklisp.org/dist/quicklisp.txt")))
+    (subseq
+     (second (uiop:split-string response :separator '(#\Newline)))
+     9)))
+
+(defun init-quicklisp ()
+  (setf *quicklisp*
+        (make-instance
+         'quicklisp-repository
+         :dist-url
+         (format nil
+                 "https://beta.quicklisp.org/dist/quicklisp/~a/"
+                 (get-quicklisp-version)))))
+
+(defun run-importers ()
+  (ignore-errors (delete-file "packages.sqlite"))
+  (import-lisp-packages *quicklisp* *sqlite*)
+  (format t "Imported packages from quicklisp to ~A~%"
+          (truename "packages.sqlite")))
+
+(defun gen-nix-file ()
+  (database->nix-expression *sqlite* "imported.nix")
+  (format t "Dumped nix file to ~a~%"
+          (truename "imported.nix")))
+
+(defun run-nix-formatter ()
+  (uiop:run-program '("nixfmt" "imported.nix")))
+
+(defun main ()
+  (format t "~%")
+  (init-quicklisp)
+  (run-importers)
+  (gen-nix-file)
+  (run-nix-formatter))

pkgs/development/lisp-modules/import/nix.lisp

@@ -0,0 +1,83 @@
+(defpackage org.lispbuilds.nix/nix
+  (:documentation "Utilities for generating Nix code")
+  (:use :cl)
+  (:import-from :str)
+  (:import-from :ppcre)
+  (:import-from :arrow-macros :->>)
+  (:import-from :org.lispbuilds.nix/util :replace-regexes)
+  (:export
+   :nix-eval
+   :nixify-symbol
+   :system-master
+   :make-pname
+   :*nix-attrs-depth*))
+
+(in-package org.lispbuilds.nix/nix)
+
+;; Path names are alphanumeric and can include the symbols +-._?= and
+;; must not begin with a period.
+(defun make-pname (string)
+  (replace-regexes '("^[.]" "[^a-zA-Z0-9+-._?=]")
+                   '("_" "_")
+                   string))
+
+(defun system-master (system)
+  (first (str:split "/" system)))
+
+;;;; Nix generation
+
+(defun nix-eval (exp)
+  (assert (consp exp))
+  (ecase (car exp)
+    (:string (nix-string (cadr exp)))
+    (:list (apply #'nix-list (rest exp)))
+    (:funcall (apply #'nix-funcall (rest exp)))
+    (:attrs (nix-attrs (cdr exp)))
+    (:merge (apply #'nix-merge (cdr exp)))
+    (:symbol (nix-symbol (cadr exp)))))
+
+(defun nix-string (object)
+  (format nil "\"~a\"" object))
+
+(defun nixify-symbol (string)
+  (flet ((fix-special-chars (str)
+           (replace-regexes '("[_]" "[+]$" "[+][/]" "[+]" "[.]" "[/]")
+                            '("__" "_plus" "_plus/" "_plus_" "_dot_" "_slash_")
+                            str)))
+    (if (ppcre:scan "^[0-9]" string)
+        (str:concat "_" (fix-special-chars string))
+        (fix-special-chars string))))
+
+
+(defun nix-symbol (object)
+  (nixify-symbol (format nil "~a" object)))
+
+(defun nix-list (&rest things)
+  (format nil "[ ~{~A~^ ~} ]" (mapcar 'nix-eval things)))
+(defvar *nix-attrs-depth* 0)
+
+(defun nix-attrs (keyvals)
+  (when (null keyvals)
+    (return-from nix-attrs "{}"))
+  (let ((*nix-attrs-depth* (1+ *nix-attrs-depth*)))
+    (format
+     nil
+     (->> "{~%*depth*~{~{~A = ~A;~}~^~%*depth*~}~%*depth-1*}"
+          (str:replace-all "*depth*" (str:repeat *nix-attrs-depth* "  "))
+          (str:replace-all "*depth-1*" (str:repeat (1- *nix-attrs-depth*) "  ")))
+     (mapcar (lambda (keyval)
+               (let ((key (car keyval))
+                     (val (cadr keyval)))
+                 (list (nix-symbol key)
+                       (nix-eval val))))
+             keyvals))))
+
+(defun nix-funcall (fun &rest args)
+  (format nil "(~a ~{~a~^ ~})"
+          (nixify-symbol fun)
+          (mapcar 'nix-eval args)))
+
+(defun nix-merge (a b)
+  (format nil "(~a // ~b)"
+          (nix-eval a)
+          (nix-eval b)))

pkgs/development/lisp-modules/import/org.lispbuilds.nix.asd

@@ -0,0 +1,28 @@
+(defsystem org.lispbuilds.nix
+  :class :package-inferred-system
+  :description "Utilities for importing ASDF systems into Nix"
+  :depends-on (
+               :alexandria
+               :str
+               :cl-ppcre
+               :sqlite
+               :dexador
+               :arrow-macros
+               :com.inuoe.jzon
+               :org.lispbuilds.nix/api
+               :org.lispbuilds.nix/repository/quicklisp
+               :org.lispbuilds.nix/database/sqlite
+               ))
+
+
+(register-system-packages
+ "cl-ppcre"
+ '(:ppcre))
+
+(register-system-packages
+ "dexador"
+ '(:dex))
+
+(register-system-packages
+ "alexandria"
+ '(:alexandria :alexandria-2))

pkgs/development/lisp-modules/import/repository/quicklisp.lisp

@@ -0,0 +1,240 @@
+(defpackage org.lispbuilds.nix/repository/quicklisp
+  (:use :cl)
+  (:import-from :dex)
+  (:import-from :alexandria :read-file-into-string :ensure-list)
+  (:import-from :arrow-macros :->>)
+  (:import-from :str)
+  (:import-from
+   :org.lispbuilds.nix/database/sqlite
+   :sqlite-database
+   :init-db
+   :database-url
+   :init-file)
+  (:import-from
+   :org.lispbuilds.nix/api
+   :import-lisp-packages)
+  (:import-from
+   :org.lispbuilds.nix/util
+   :replace-regexes)
+  (:export :quicklisp-repository)
+  (:local-nicknames
+   (:json :com.inuoe.jzon)))
+
+(in-package org.lispbuilds.nix/repository/quicklisp)
+
+(defclass quicklisp-repository ()
+  ((dist-url :initarg :dist-url
+             :reader dist-url
+             :initform (error "dist url required"))))
+
+(defun clear-line ()
+  (write-char #\Return *error-output*)
+  (write-char #\Escape *error-output*)
+  (write-char #\[ *error-output*)
+  (write-char #\K *error-output*))
+
+(defun status (&rest format-args)
+  (clear-line)
+  (apply #'format (list* *error-output* format-args))
+  (force-output *error-output*))
+
+;; TODO: This should not know about the imported.nix file.
+(defun init-tarball-hashes (database)
+  (status "no packages.sqlite - will pre-fill tarball hashes from ~A to save time~%"
+          (truename "imported.nix"))
+  (let* ((lines (uiop:read-file-lines "imported.nix"))
+         (lines (remove-if-not
+                  (lambda (line)
+                    (let ((trimmed (str:trim-left line)))
+                      (or (str:starts-with-p "url = " trimmed)
+                          (str:starts-with-p "sha256 = " trimmed))))
+                  lines))
+         (lines (mapcar
+                 (lambda (line)
+                   (multiple-value-bind (whole groups)
+                       (ppcre:scan-to-strings "\"\(.*\)\"" line)
+                     (declare (ignore whole))
+                     (svref groups 0)))
+                 lines)))
+    (sqlite:with-open-database (db (database-url database))
+      (init-db db (init-file database))
+      (sqlite:with-transaction db
+        (loop while lines do
+          (sqlite:execute-non-query db
+            "insert or ignore into sha256(url,hash) values (?,?)"
+            (prog1 (first lines) (setf lines (rest lines)))
+            (prog1 (first lines) (setf lines (rest lines))))))
+      (status "OK, imported ~A hashes into DB.~%"
+              (sqlite:execute-single db
+                 "select count(*) from sha256")))))
+
+(defparameter *broken-systems*
+  '(
+    ;; Infinite recursion through dependencies in 2024-10-12 dist
+    "cl-quil" "qvm"
+    )
+  "List of broken systems, which should be omitted from the package graph")
+
+(defmethod import-lisp-packages ((repository quicklisp-repository)
+                                 (database sqlite-database))
+
+  ;; If packages.sqlite is missing, we should populate the sha256
+  ;; table to speed things up.
+  (unless (probe-file (database-url database))
+    (init-tarball-hashes database))
+
+  (let* ((db (sqlite:connect (database-url database)))
+         (systems-url (str:concat (dist-url repository) "systems.txt"))
+         (releases-url (str:concat (dist-url repository) "releases.txt"))
+         (systems-lines (rest (butlast (str:split #\Newline (dex:get systems-url)))))
+         (releases-lines (rest (butlast (str:split #\Newline (dex:get releases-url))))))
+
+    (flet ((sql-query (sql &rest params)
+             (apply #'sqlite:execute-to-list (list* db sql params))))
+
+      ;; Ensure database schema
+      (init-db db (init-file database))
+
+      ;; Prepare temporary tables for efficient access
+      (sql-query "create temp table if not exists quicklisp_system
+                  (project, asd, name unique, deps)")
+
+      (sql-query "create temp table if not exists quicklisp_release
+                  (project unique, url, size, md5, sha1, prefix not null, asds)")
+
+      (sqlite:with-transaction db
+        (dolist (line systems-lines)
+          (destructuring-bind (project asd name &rest deps)
+              (str:words line)
+            (sql-query
+             "insert or ignore into quicklisp_system values(?,?,?,?)"
+             project asd name (json:stringify (coerce deps 'vector))))))
+
+      (sqlite:with-transaction db
+        (dolist (line releases-lines)
+          (destructuring-bind (project http-url size md5 sha1 prefix &rest asds)
+              (str:words line)
+            ;; quicklisp does not support TLS
+            ;; https://github.com/quicklisp/quicklisp-client/issues/167
+            ;; but since we fetch systems using nix we can adapt the url.
+            (let ((url (str:replace-first "http://" "https://" http-url)))
+              (sql-query
+               "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
+               project url size md5 sha1 prefix (json:stringify (coerce
+                                                                 asds
+                                                                 'vector)))))))
+
+      ;; Weed out circular dependencies from the package graph.
+      (sqlite:with-transaction db
+        (sql-query "create temp table will_delete (root,name)")
+        (loop for (system) in (sql-query "select name from quicklisp_system") do
+          (when (sql-query
+                  "with recursive dep(root, name) as (
+                    select s.name, d.value
+                    from quicklisp_system s
+                    cross join json_each(s.deps) d
+                    where s.name = ?
+                    union
+                    select dep.root, d.value
+                    from quicklisp_system s, dep
+                    cross join json_each(s.deps) d
+                    where s.name = dep.name
+                  ) select 1 from dep where name = root"
+                 system)
+            (sql-query
+             "with recursive broken(name) as (
+                select ?
+                union
+                select s.name from quicklisp_system s, broken b
+                where b.name in (select value from json_each(s.deps))
+              ) insert into will_delete select ?, name from broken"
+             system system)))
+        (loop for (root name) in (sql-query "select root, name from will_delete") do
+          (warn "Circular dependency in '~a': Omitting '~a'" root name)
+          (sql-query "delete from quicklisp_system where name = ?" name)))
+
+      (sqlite:with-transaction db
+        ;; Should these be temp tables, that then get queried by
+        ;; system name? This looks like it uses a lot of memory.
+        (let ((systems
+                (sql-query
+                 "with pkgs as (
+                    select
+                      name, asd, url, deps,
+                      ltrim(replace(prefix, r.project, ''), '-_') as version
+                    from quicklisp_system s, quicklisp_release r
+                    where s.project = r.project
+                  )
+                  select
+                    name, version, asd, url,
+                    (select json_group_array(
+                       json_array(value, (select version from pkgs where name=value))
+                     )
+                     from json_each(deps)
+                     where value <> 'asdf') as deps
+                  from pkgs"
+                 )))
+
+          ;; First pass: insert system and source tarball informaton.
+          ;; Can't insert dependency information, because this works
+          ;; on system ids in the database and they don't exist
+          ;; yet. Could it be better to just base dependencies on
+          ;; names? But then ACID is lost.
+          (dolist (system systems)
+            (destructuring-bind (name version asd url deps) system
+              (declare (ignore deps))
+              (status "importing system '~a-~a'" name version)
+              (let ((hash (nix-prefetch-tarball url db)))
+                (sql-query
+                 "insert or ignore into system(name,version,asd) values (?,?,?)"
+                 name version asd)
+                (sql-query
+                 "insert or ignore into sha256(url,hash) values (?,?)"
+                 url hash)
+                (sql-query
+                 "insert or ignore into src values
+                  ((select id from sha256 where url=?),
+                   (select id from system where name=? and version=?))"
+                 url name version))))
+
+          ;; Second pass: connect the in-database systems with
+          ;; dependency information
+          (dolist (system systems)
+            (destructuring-bind (name version asd url deps) system
+              (declare (ignore asd url))
+              (dolist (dep (coerce (json:parse deps) 'list))
+                (destructuring-bind (dep-name dep-version) (coerce dep 'list)
+                  (if (eql dep-version 'NULL)
+                    (warn "Bad data in Quicklisp: ~a has no version" dep-name)
+                  (sql-query
+                    "insert or ignore into dep values
+                     ((select id from system where name=? and version=?),
+                      (select id from system where name=? and version=?))"
+                    name version
+                    dep-name dep-version))))))))))
+
+  (write-char #\Newline *error-output*))
+
+(defun shell-command-to-string (cmd)
+  ;; Clearing the library path is needed to prevent a bug, where the
+  ;; called subprocess uses a different glibc than the SBCL process
+  ;; is. In that case, the call to execve attempts to load the
+  ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
+  ;; glibc than they expect, which errors out.
+  (let ((ld-library-path  (uiop:getenv "LD_LIBRARY_PATH")))
+    (setf (uiop:getenv "LD_LIBRARY_PATH") "")
+    (unwind-protect
+         (uiop:run-program cmd :output '(:string :stripped t))
+      (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
+
+(defun nix-prefetch-tarball (url db)
+  (restart-case
+      (compute-sha256 url db)
+    (try-again ()
+      :report "Try downloading again"
+      (nix-prefetch-tarball url db))))
+
+(defun compute-sha256 (url db)
+  (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
+      (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
+        sha256)))

pkgs/development/lisp-modules/import/util.lisp

@@ -0,0 +1,16 @@
+(defpackage org.lispbuilds.nix/util
+  (:use :cl)
+  (:import-from :ppcre)
+  (:export
+   :replace-regexes))
+
+(in-package org.lispbuilds.nix/util)
+
+(defun replace-regexes (from to str)
+  (assert (= (length from) (length to)))
+  (if (null from)
+      str
+      (replace-regexes
+       (rest from)
+       (rest to)
+       (ppcre:regex-replace-all (first from) str (first to)))))