tjh.dev
1(defpackage org.lispbuilds.nix/repository/quicklisp
2 (:use :cl)
3 (:import-from :dex)
4 (:import-from :alexandria :read-file-into-string :ensure-list)
5 (:import-from :arrow-macros :->>)
6 (:import-from :str)
7 (:import-from
8 :org.lispbuilds.nix/database/sqlite
9 :sqlite-database
10 :init-db
11 :database-url
12 :init-file)
13 (:import-from
14 :org.lispbuilds.nix/api
15 :import-lisp-packages)
16 (:import-from
17 :org.lispbuilds.nix/util
18 :replace-regexes)
19 (:export :quicklisp-repository)
20 (:local-nicknames
21 (:json :com.inuoe.jzon)))
22
23(in-package org.lispbuilds.nix/repository/quicklisp)
24
25(defclass quicklisp-repository ()
26 ((dist-url :initarg :dist-url
27 :reader dist-url
28 :initform (error "dist url required"))))
29
30(defun clear-line ()
31 (write-char #\Return *error-output*)
32 (write-char #\Escape *error-output*)
33 (write-char #\[ *error-output*)
34 (write-char #\K *error-output*))
35
36(defun status (&rest format-args)
37 (clear-line)
38 (apply #'format (list* *error-output* format-args))
39 (force-output *error-output*))
40
41;; TODO: This should not know about the imported.nix file.
42(defun init-tarball-hashes (database)
43 (status "no packages.sqlite - will pre-fill tarball hashes from ~A to save time~%"
44 (truename "imported.nix"))
45 (let* ((lines (uiop:read-file-lines "imported.nix"))
46 (lines (remove-if-not
47 (lambda (line)
48 (let ((trimmed (str:trim-left line)))
49 (or (str:starts-with-p "url = " trimmed)
50 (str:starts-with-p "sha256 = " trimmed))))
51 lines))
52 (lines (mapcar
53 (lambda (line)
54 (multiple-value-bind (whole groups)
55 (ppcre:scan-to-strings "\"\(.*\)\"" line)
56 (declare (ignore whole))
57 (svref groups 0)))
58 lines)))
59 (sqlite:with-open-database (db (database-url database))
60 (init-db db (init-file database))
61 (sqlite:with-transaction db
62 (loop while lines do
63 (sqlite:execute-non-query db
64 "insert or ignore into sha256(url,hash) values (?,?)"
65 (prog1 (first lines) (setf lines (rest lines)))
66 (prog1 (first lines) (setf lines (rest lines))))))
67 (status "OK, imported ~A hashes into DB.~%"
68 (sqlite:execute-single db
69 "select count(*) from sha256")))))
70
71(defparameter *broken-systems*
72 '(
73 ;; Infinite recursion through dependencies in 2024-10-12 dist
74 "cl-quil" "qvm"
75 )
76 "List of broken systems, which should be omitted from the package graph")
77
78(defmethod import-lisp-packages ((repository quicklisp-repository)
79 (database sqlite-database))
80
81 ;; If packages.sqlite is missing, we should populate the sha256
82 ;; table to speed things up.
83 (unless (probe-file (database-url database))
84 (init-tarball-hashes database))
85
86 (let* ((db (sqlite:connect (database-url database)))
87 (systems-url (str:concat (dist-url repository) "systems.txt"))
88 (releases-url (str:concat (dist-url repository) "releases.txt"))
89 (systems-lines (rest (butlast (str:split #\Newline (dex:get systems-url)))))
90 (releases-lines (rest (butlast (str:split #\Newline (dex:get releases-url))))))
91
92 (flet ((sql-query (sql &rest params)
93 (apply #'sqlite:execute-to-list (list* db sql params))))
94
95 ;; Ensure database schema
96 (init-db db (init-file database))
97
98 ;; Prepare temporary tables for efficient access
99 (sql-query "create temp table if not exists quicklisp_system
100 (project, asd, name unique, deps)")
101
102 (sql-query "create temp table if not exists quicklisp_release
103 (project unique, url, size, md5, sha1, prefix not null, asds)")
104
105 (sqlite:with-transaction db
106 (dolist (line systems-lines)
107 (destructuring-bind (project asd name &rest deps)
108 (str:words line)
109 (sql-query
110 "insert or ignore into quicklisp_system values(?,?,?,?)"
111 project asd name (json:stringify (coerce deps 'vector))))))
112
113 (sqlite:with-transaction db
114 (dolist (line releases-lines)
115 (destructuring-bind (project url size md5 sha1 prefix &rest asds)
116 (str:words line)
117 (sql-query
118 "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
119 project url size md5 sha1 prefix (json:stringify (coerce
120 asds
121 'vector))))))
122
123 ;; Weed out circular dependencies from the package graph.
124 (sqlite:with-transaction db
125 (sql-query "create temp table will_delete (root,name)")
126 (loop for (system) in (sql-query "select name from quicklisp_system") do
127 (when (sql-query
128 "with recursive dep(root, name) as (
129 select s.name, d.value
130 from quicklisp_system s
131 cross join json_each(s.deps) d
132 where s.name = ?
133 union
134 select dep.root, d.value
135 from quicklisp_system s, dep
136 cross join json_each(s.deps) d
137 where s.name = dep.name
138 ) select 1 from dep where name = root"
139 system)
140 (sql-query
141 "with recursive broken(name) as (
142 select ?
143 union
144 select s.name from quicklisp_system s, broken b
145 where b.name in (select value from json_each(s.deps))
146 ) insert into will_delete select ?, name from broken"
147 system system)))
148 (loop for (root name) in (sql-query "select root, name from will_delete") do
149 (warn "Circular dependency in '~a': Omitting '~a'" root name)
150 (sql-query "delete from quicklisp_system where name = ?" name)))
151
152 (sqlite:with-transaction db
153 ;; Should these be temp tables, that then get queried by
154 ;; system name? This looks like it uses a lot of memory.
155 (let ((systems
156 (sql-query
157 "with pkgs as (
158 select
159 name, asd, url, deps,
160 ltrim(replace(prefix, r.project, ''), '-_') as version
161 from quicklisp_system s, quicklisp_release r
162 where s.project = r.project
163 )
164 select
165 name, version, asd, url,
166 (select json_group_array(
167 json_array(value, (select version from pkgs where name=value))
168 )
169 from json_each(deps)
170 where value <> 'asdf') as deps
171 from pkgs"
172 )))
173
174 ;; First pass: insert system and source tarball informaton.
175 ;; Can't insert dependency information, because this works
176 ;; on system ids in the database and they don't exist
177 ;; yet. Could it be better to just base dependencies on
178 ;; names? But then ACID is lost.
179 (dolist (system systems)
180 (destructuring-bind (name version asd url deps) system
181 (declare (ignore deps))
182 (status "importing system '~a-~a'" name version)
183 (let ((hash (nix-prefetch-tarball url db)))
184 (sql-query
185 "insert or ignore into system(name,version,asd) values (?,?,?)"
186 name version asd)
187 (sql-query
188 "insert or ignore into sha256(url,hash) values (?,?)"
189 url hash)
190 (sql-query
191 "insert or ignore into src values
192 ((select id from sha256 where url=?),
193 (select id from system where name=? and version=?))"
194 url name version))))
195
196 ;; Second pass: connect the in-database systems with
197 ;; dependency information
198 (dolist (system systems)
199 (destructuring-bind (name version asd url deps) system
200 (declare (ignore asd url))
201 (dolist (dep (coerce (json:parse deps) 'list))
202 (destructuring-bind (dep-name dep-version) (coerce dep 'list)
203 (if (eql dep-version 'NULL)
204 (warn "Bad data in Quicklisp: ~a has no version" dep-name)
205 (sql-query
206 "insert or ignore into dep values
207 ((select id from system where name=? and version=?),
208 (select id from system where name=? and version=?))"
209 name version
210 dep-name dep-version))))))))))
211
212 (write-char #\Newline *error-output*))
213
214(defun shell-command-to-string (cmd)
215 ;; Clearing the library path is needed to prevent a bug, where the
216 ;; called subprocess uses a different glibc than the SBCL process
217 ;; is. In that case, the call to execve attempts to load the
218 ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
219 ;; glibc than they expect, which errors out.
220 (let ((ld-library-path (uiop:getenv "LD_LIBRARY_PATH")))
221 (setf (uiop:getenv "LD_LIBRARY_PATH") "")
222 (unwind-protect
223 (uiop:run-program cmd :output '(:string :stripped t))
224 (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
225
226(defun nix-prefetch-tarball (url db)
227 (restart-case
228 (compute-sha256 url db)
229 (try-again ()
230 :report "Try downloading again"
231 (nix-prefetch-tarball url db))))
232
233(defun compute-sha256 (url db)
234 (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
235 (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
236 sha256)))