pyrox.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 http-url size md5 sha1 prefix &rest asds)
116 (str:words line)
117 ;; quicklisp does not support TLS
118 ;; https://github.com/quicklisp/quicklisp-client/issues/167
119 ;; but since we fetch systems using nix we can adapt the url.
120 (let ((url (str:replace-first "http://" "https://" http-url)))
121 (sql-query
122 "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
123 project url size md5 sha1 prefix (json:stringify (coerce
124 asds
125 'vector)))))))
126
127 ;; Weed out circular dependencies from the package graph.
128 (sqlite:with-transaction db
129 (sql-query "create temp table will_delete (root,name)")
130 (loop for (system) in (sql-query "select name from quicklisp_system") do
131 (when (sql-query
132 "with recursive dep(root, name) as (
133 select s.name, d.value
134 from quicklisp_system s
135 cross join json_each(s.deps) d
136 where s.name = ?
137 union
138 select dep.root, d.value
139 from quicklisp_system s, dep
140 cross join json_each(s.deps) d
141 where s.name = dep.name
142 ) select 1 from dep where name = root"
143 system)
144 (sql-query
145 "with recursive broken(name) as (
146 select ?
147 union
148 select s.name from quicklisp_system s, broken b
149 where b.name in (select value from json_each(s.deps))
150 ) insert into will_delete select ?, name from broken"
151 system system)))
152 (loop for (root name) in (sql-query "select root, name from will_delete") do
153 (warn "Circular dependency in '~a': Omitting '~a'" root name)
154 (sql-query "delete from quicklisp_system where name = ?" name)))
155
156 (sqlite:with-transaction db
157 ;; Should these be temp tables, that then get queried by
158 ;; system name? This looks like it uses a lot of memory.
159 (let ((systems
160 (sql-query
161 "with pkgs as (
162 select
163 name, asd, url, deps,
164 ltrim(replace(prefix, r.project, ''), '-_') as version
165 from quicklisp_system s, quicklisp_release r
166 where s.project = r.project
167 )
168 select
169 name, version, asd, url,
170 (select json_group_array(
171 json_array(value, (select version from pkgs where name=value))
172 )
173 from json_each(deps)
174 where value <> 'asdf') as deps
175 from pkgs"
176 )))
177
178 ;; First pass: insert system and source tarball informaton.
179 ;; Can't insert dependency information, because this works
180 ;; on system ids in the database and they don't exist
181 ;; yet. Could it be better to just base dependencies on
182 ;; names? But then ACID is lost.
183 (dolist (system systems)
184 (destructuring-bind (name version asd url deps) system
185 (declare (ignore deps))
186 (status "importing system '~a-~a'" name version)
187 (let ((hash (nix-prefetch-tarball url db)))
188 (sql-query
189 "insert or ignore into system(name,version,asd) values (?,?,?)"
190 name version asd)
191 (sql-query
192 "insert or ignore into sha256(url,hash) values (?,?)"
193 url hash)
194 (sql-query
195 "insert or ignore into src values
196 ((select id from sha256 where url=?),
197 (select id from system where name=? and version=?))"
198 url name version))))
199
200 ;; Second pass: connect the in-database systems with
201 ;; dependency information
202 (dolist (system systems)
203 (destructuring-bind (name version asd url deps) system
204 (declare (ignore asd url))
205 (dolist (dep (coerce (json:parse deps) 'list))
206 (destructuring-bind (dep-name dep-version) (coerce dep 'list)
207 (if (eql dep-version 'NULL)
208 (warn "Bad data in Quicklisp: ~a has no version" dep-name)
209 (sql-query
210 "insert or ignore into dep values
211 ((select id from system where name=? and version=?),
212 (select id from system where name=? and version=?))"
213 name version
214 dep-name dep-version))))))))))
215
216 (write-char #\Newline *error-output*))
217
218(defun shell-command-to-string (cmd)
219 ;; Clearing the library path is needed to prevent a bug, where the
220 ;; called subprocess uses a different glibc than the SBCL process
221 ;; is. In that case, the call to execve attempts to load the
222 ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
223 ;; glibc than they expect, which errors out.
224 (let ((ld-library-path (uiop:getenv "LD_LIBRARY_PATH")))
225 (setf (uiop:getenv "LD_LIBRARY_PATH") "")
226 (unwind-protect
227 (uiop:run-program cmd :output '(:string :stripped t))
228 (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
229
230(defun nix-prefetch-tarball (url db)
231 (restart-case
232 (compute-sha256 url db)
233 (try-again ()
234 :report "Try downloading again"
235 (nix-prefetch-tarball url db))))
236
237(defun compute-sha256 (url db)
238 (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
239 (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
240 sha256)))