tjh.dev
Clone of https://github.com/NixOS/nixpkgs.git (to stress-test knotserver)
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(defmethod import-lisp-packages ((repository quicklisp-repository)
72 (database sqlite-database))
73
74 ;; If packages.sqlite is missing, we should populate the sha256
75 ;; table to speed things up.
76 (unless (probe-file (database-url database))
77 (init-tarball-hashes database))
78
79 (let* ((db (sqlite:connect (database-url database)))
80 (systems-url (str:concat (dist-url repository) "systems.txt"))
81 (releases-url (str:concat (dist-url repository) "releases.txt"))
82 (systems-lines (rest (butlast (str:split #\Newline (dex:get systems-url)))))
83 (releases-lines (rest (butlast (str:split #\Newline (dex:get releases-url))))))
84
85 (flet ((sql-query (sql &rest params)
86 (apply #'sqlite:execute-to-list (list* db sql params))))
87
88 ;; Ensure database schema
89 (init-db db (init-file database))
90
91 ;; Prepare temporary tables for efficient access
92 (sql-query "create temp table if not exists quicklisp_system
93 (project, asd, name unique, deps)")
94
95 (sql-query "create temp table if not exists quicklisp_release
96 (project unique, url, size, md5, sha1, prefix not null, asds)")
97
98 (sqlite:with-transaction db
99 (dolist (line systems-lines)
100 (destructuring-bind (project asd name &rest deps)
101 (str:words line)
102 (sql-query
103 "insert or ignore into quicklisp_system values(?,?,?,?)"
104 project asd name (json:stringify (coerce deps 'vector))))))
105
106 (sqlite:with-transaction db
107 (dolist (line releases-lines)
108 (destructuring-bind (project url size md5 sha1 prefix &rest asds)
109 (str:words line)
110 (sql-query
111 "insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
112 project url size md5 sha1 prefix (json:stringify (coerce
113 asds
114 'vector))))))
115
116 (sqlite:with-transaction db
117 ;; Should these be temp tables, that then get queried by
118 ;; system name? This looks like it uses a lot of memory.
119 (let ((systems
120 (sql-query
121 "with pkgs as (
122 select
123 name, asd, url, deps,
124 ltrim(replace(prefix, r.project, ''), '-_') as version
125 from quicklisp_system s, quicklisp_release r
126 where s.project = r.project
127 )
128 select
129 name, version, asd, url,
130 (select json_group_array(
131 json_array(value, (select version from pkgs where name=value))
132 )
133 from json_each(deps)
134 where value <> 'asdf') as deps
135 from pkgs"
136 )))
137
138 ;; First pass: insert system and source tarball informaton.
139 ;; Can't insert dependency information, because this works
140 ;; on system ids in the database and they don't exist
141 ;; yet. Could it be better to just base dependencies on
142 ;; names? But then ACID is lost.
143 (dolist (system systems)
144 (destructuring-bind (name version asd url deps) system
145 (declare (ignore deps))
146 (status "importing system '~a-~a'" name version)
147 (let ((hash (nix-prefetch-tarball url db)))
148 (sql-query
149 "insert or ignore into system(name,version,asd) values (?,?,?)"
150 name version asd)
151 (sql-query
152 "insert or ignore into sha256(url,hash) values (?,?)"
153 url hash)
154 (sql-query
155 "insert or ignore into src values
156 ((select id from sha256 where url=?),
157 (select id from system where name=? and version=?))"
158 url name version))))
159
160 ;; Second pass: connect the in-database systems with
161 ;; dependency information
162 (dolist (system systems)
163 (destructuring-bind (name version asd url deps) system
164 (declare (ignore asd url))
165 (dolist (dep (coerce (json:parse deps) 'list))
166 (destructuring-bind (dep-name dep-version) (coerce dep 'list)
167 (if (eql dep-version 'NULL)
168 (warn "Bad data in Quicklisp: ~a has no version" dep-name)
169 (sql-query
170 "insert or ignore into dep values
171 ((select id from system where name=? and version=?),
172 (select id from system where name=? and version=?))"
173 name version
174 dep-name dep-version))))))))))
175
176 (write-char #\Newline *error-output*))
177
178(defun shell-command-to-string (cmd)
179 ;; Clearing the library path is needed to prevent a bug, where the
180 ;; called subprocess uses a different glibc than the SBCL process
181 ;; is. In that case, the call to execve attempts to load the
182 ;; libraries used by SBCL from LD_LIBRARY_PATH using a different
183 ;; glibc than they expect, which errors out.
184 (let ((ld-library-path (uiop:getenv "LD_LIBRARY_PATH")))
185 (setf (uiop:getenv "LD_LIBRARY_PATH") "")
186 (unwind-protect
187 (uiop:run-program cmd :output '(:string :stripped t))
188 (setf (uiop:getenv "LD_LIBRARY_PATH") ld-library-path))))
189
190(defun nix-prefetch-tarball (url db)
191 (restart-case
192 (compute-sha256 url db)
193 (try-again ()
194 :report "Try downloading again"
195 (nix-prefetch-tarball url db))))
196
197(defun compute-sha256 (url db)
198 (or (sqlite:execute-single db "select hash from sha256 where url=?" url)
199 (let ((sha256 (shell-command-to-string (str:concat "nix-prefetch-url --unpack " url))))
200 sha256)))