Something went wrong. Try again.
What happens if I push all of nixpkgs
Something went wrong. Try again.
10 kB · 240 lines
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241(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)))