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
|
;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of Guix.
;;;
;;; 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.
;;;
;;; 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 Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix derivations)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:export (derivation?
derivation-outputs
derivation-inputs
derivation-sources
derivation-system
derivation-builder-arguments
derivation-builder-environment-vars
derivation-output?
derivation-output-path
derivation-output-hash-algo
derivation-output-hash
derivation-input?
derivation-input-path
derivation-input-sub-derivations
fixed-output-derivation?
derivation-hash))
;;;
;;; Nix derivations, as implemented in Nix's `derivations.cc'.
;;;
(define-record-type <derivation>
(make-derivation outputs inputs sources system builder args env-vars)
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
(define-record-type <derivation-output>
(make-derivation-output path hash-algo hash)
derivation-output?
(path derivation-output-path) ; store path
(hash-algo derivation-output-hash-algo) ; symbol | #f
(hash derivation-output-hash)) ; symbol | #f
(define-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
(define (fixed-output-derivation? drv)
"Return #t if DRV is a fixed-output derivation, such as the result of a
download with a fixed hash (aka. `fetchurl')."
(match drv
(($ <derivation>
(($ <derivation-output> _ (? symbol?) (? string?))))
#t)
(_ #f)))
(define (read-derivation drv-port)
"Read the derivation from DRV-PORT and return the corresponding
<derivation> object."
(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)
result))
((name path hash-algo hash)
;; fixed-output
(let ((algo (string->symbol hash-algo)))
(alist-cons name
(make-derivation-output path algo hash)
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))
(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)))
(_
(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 (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."
(define (list->string lst)
(string-append "[" (string-join lst ",") "]"))
(define (write-list lst)
(display (list->string lst) port))
(match drv
(($ <derivation> outputs inputs sources
system builder args env-vars)
(display "Derive(" port)
(write-list (map (match-lambda
((name . ($ <derivation-output> path hash-algo hash))
(format #f "(~s,~s,~s,~s)"
name path (or hash-algo "")
(or hash ""))))
outputs))
(display "," port)
(write-list (map (match-lambda
(($ <derivation-input> path sub-drvs)
(format #f "(~s,~a)" path
(list->string (map object->string sub-drvs)))))
inputs))
(display "," port)
(write-list sources)
(format port ",~s,~s," system builder)
(write-list (map object->string args))
(display "," port)
(write-list (map (match-lambda
((name . value)
(format #f "(~s,~s)" name value)))
env-vars))
(display ")" port))))
(define (sha256 bv)
"Return the SHA256 of BV as an string of hexadecimal digits."
;; XXX: Poor programmer's implementation that uses Coreutils.
(let ((in (pipe))
(out (pipe))
(pid (primitive-fork)))
(if (= 0 pid)
(begin ; child
(close (cdr in))
(close (car out))
(close 0)
(close 1)
(dup2 (fileno (car in)) 0)
(dup2 (fileno (cdr out)) 1)
(execlp "sha256sum" "sha256sum"))
(begin ; parent
(close (car in))
(close (cdr out))
(put-bytevector (cdr in) bv)
(close (cdr in)) ; EOF
(let ((line (car (string-tokenize (read-line (car out))))))
(close (car out))
(and (and=> (status:exit-val (cdr (waitpid pid)))
zero?)
line))))))
(define (derivation-hash drv) ; `hashDerivationModulo' in derivations.cc
(match drv
(($ <derivation> ((_ . ($ <derivation-output> path
(? symbol? hash-algo) (? string? hash)))))
;; A fixed-output derivation.
(sha256
(string->utf8
(string-append "fixed:out:" hash-algo ":" hash ":" path))))
(($ <derivation> outputs inputs sources
system builder args env-vars)
;; A regular derivation: replace that path of each input with that
;; inputs hash; return the hash of serialization of the resulting
;; derivation.
(let* ((inputs (map (match-lambda
(($ <derivation-input> path sub-drvs)
(let ((hash (call-with-input-file path
(compose derivation-hash
read-derivation))))
(make-derivation-input hash sub-drvs))))
inputs))
(drv (make-derivation outputs inputs sources
system builder args env-vars)))
(sha256
(string->utf8 (call-with-output-string
(cut write-derivation drv <>))))))))
(define (instantiate server derivation)
#f
)
|