1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
(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")))))
(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 url size md5 sha1 prefix &rest asds)
(str:words line)
(sql-query
"insert or ignore into quicklisp_release values(?,?,?,?,?,?,?)"
project url size md5 sha1 prefix (json:stringify (coerce
asds
'vector))))))
(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 pkg 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 pkg where name=value))
)
from json_each(deps)) as deps
from pkg"
)))
;; 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)))
|
