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
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
;;; Copyright © 2019 Caleb Ristvedt <caleb.ristvedt@cune.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix store derivations)
#:use-module (ice-9 match)
#:use-module (rnrs io ports)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:use-module (guix base16)
#:use-module (guix memoization)
#:export (<derivation>
make-derivation
derivation?
derivation-outputs
derivation-inputs
derivation-sources
derivation-system
derivation-builder
derivation-builder-arguments
derivation-builder-environment-vars
derivation-file-name
<derivation-output>
make-derivation-output
derivation-output?
derivation-output-path
derivation-output-hash-algo
derivation-output-hash
derivation-output-recursive?
<derivation-input>
make-derivation-input
derivation-input?
derivation-input-path
derivation-input-sub-derivations
read-derivation
read-derivation-from-file
derivation->bytevector
%derivation-cache
write-derivation))
;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
;;;
(define-immutable-record-type <derivation>
(make-derivation outputs inputs sources system builder args env-vars
file-name)
derivation?
(outputs derivation-outputs) ; list of name/<derivation-output> pairs
(inputs derivation-inputs) ; list of <derivation-input>
(sources derivation-sources) ; list of store paths
(system derivation-system) ; string
(builder derivation-builder) ; store path
(args derivation-builder-arguments) ; list of strings
(env-vars derivation-builder-environment-vars) ; list of name/value pairs
(file-name derivation-file-name)) ; the .drv file name
(define-immutable-record-type <derivation-output>
(make-derivation-output path hash-algo hash recursive?)
derivation-output?
(path derivation-output-path) ; store path
(hash-algo derivation-output-hash-algo) ; symbol | #f
(hash derivation-output-hash) ; bytevector | #f
(recursive? derivation-output-recursive?)) ; Boolean
(define-immutable-record-type <derivation-input>
(make-derivation-input path sub-derivations)
derivation-input?
(path derivation-input-path) ; store path
(sub-derivations derivation-input-sub-derivations)) ; list of strings
(set-record-type-printer! <derivation>
(lambda (drv port)
(format port "#<derivation ~a => ~a ~a>"
(derivation-file-name drv)
(string-join
(map (match-lambda
((_ . output)
(derivation-output-path output)))
(derivation-outputs drv)))
(number->string (object-address drv) 16))))
(define (read-derivation drv-port)
"Read the derivation from DRV-PORT and return the corresponding <derivation>
object. Most of the time you'll want to use 'read-derivation-from-file',
which caches things as appropriate and is thus more efficient."
(define comma (string->symbol ","))
(define (ununquote x)
(match x
(('unquote x) (ununquote x))
((x ...) (map ununquote x))
(_ x)))
(define (outputs->alist x)
(fold-right (lambda (output result)
(match output
((name path "" "")
(alist-cons name
(make-derivation-output path #f #f #f)
result))
((name path hash-algo hash)
;; fixed-output
(let* ((rec? (string-prefix? "r:" hash-algo))
(algo (string->symbol
(if rec?
(string-drop hash-algo 2)
hash-algo)))
(hash (base16-string->bytevector hash)))
(alist-cons name
(make-derivation-output path algo
hash rec?)
result)))))
'()
x))
(define (make-input-drvs x)
(fold-right (lambda (input result)
(match input
((path (sub-drvs ...))
(cons (make-derivation-input path sub-drvs)
result))))
'()
x))
;; The contents of a derivation are typically ASCII, but choosing
;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
(set-port-encoding! drv-port "UTF-8")
(let loop ((exp (read drv-port))
(result '()))
(match exp
((? eof-object?)
(let ((result (reverse result)))
(match result
(('Derive ((outputs ...) (input-drvs ...)
(input-srcs ...)
(? string? system)
(? string? builder)
((? string? args) ...)
((var value) ...)))
(make-derivation (outputs->alist outputs)
(make-input-drvs input-drvs)
input-srcs
system builder args
(fold-right alist-cons '() var value)
(port-filename drv-port)))
(_
(error "failed to parse derivation" drv-port result)))))
((? (cut eq? <> comma))
(loop (read drv-port) result))
(_
(loop (read drv-port)
(cons (ununquote exp) result))))))
(define %derivation-cache
;; Maps derivation file names to <derivation> objects.
;; XXX: This is redundant with 'atts-cache' in the store.
(make-weak-value-hash-table 200))
(define (read-derivation-from-file file)
"Read the derivation in FILE, a '.drv' file, and return the corresponding
<derivation> object."
;; Memoize that operation because 'read-derivation' is quite expensive,
;; and because the same argument is read more than 15 times on average
;; during something like (package-derivation s gdb).
(or (and file (hash-ref %derivation-cache file))
(let ((drv (call-with-input-file file read-derivation)))
(hash-set! %derivation-cache file drv)
drv)))
(define-inlinable (write-sequence lst write-item port)
;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
;; comma.
(match lst
(()
#t)
((prefix (... ...) last)
(for-each (lambda (item)
(write-item item port)
(display "," port))
prefix)
(write-item last port))))
(define-inlinable (write-list lst write-item port)
;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
;; element.
(display "[" port)
(write-sequence lst write-item port)
(display "]" port))
(define-inlinable (write-tuple lst write-item port)
;; Same, but write LST as a tuple.
(display "(" port)
(write-sequence lst write-item port)
(display ")" port))
(define (write-derivation drv port)
"Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
Eelco Dolstra's PhD dissertation for an overview of a previous version of
that form."
;; Make sure we're using the faster implementation.
(define format simple-format)
(define (write-string-list lst)
(write-list lst write port))
(define (write-output output port)
(match output
((name . ($ <derivation-output> path hash-algo hash recursive?))
(write-tuple (list name path
(if hash-algo
(string-append (if recursive? "r:" "")
(symbol->string hash-algo))
"")
(or (and=> hash bytevector->base16-string)
""))
write
port))))
(define (write-input input port)
(match input
(($ <derivation-input> path sub-drvs)
(display "(\"" port)
(display path port)
(display "\"," port)
(write-string-list sub-drvs)
(display ")" port))))
(define (write-env-var env-var port)
(match env-var
((name . value)
(display "(" port)
(write name port)
(display "," port)
(write value port)
(display ")" port))))
;; Assume all the lists we are writing are already sorted.
(match drv
(($ <derivation> outputs inputs sources
system builder args env-vars)
(display "Derive(" port)
(write-list outputs write-output port)
(display "," port)
(write-list inputs write-input port)
(display "," port)
(write-string-list sources)
(simple-format port ",\"~a\",\"~a\"," system builder)
(write-string-list args)
(display "," port)
(write-list env-vars write-env-var port)
(display ")" port))))
(define derivation->bytevector
(mlambda (drv)
"Return the external representation of DRV as a UTF-8-encoded string."
(with-fluids ((%default-port-encoding "UTF-8"))
(call-with-values open-bytevector-output-port
(lambda (port get-bytevector)
(write-derivation drv port)
(get-bytevector))))))
|