You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 
 
 
 
 

1292 lines
54 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2016, 2017 Mathieu Lirzin <mthl@gnu.org>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix derivations)
  20. #:use-module (srfi srfi-1)
  21. #:use-module (srfi srfi-9)
  22. #:use-module (srfi srfi-9 gnu)
  23. #:use-module (srfi srfi-26)
  24. #:use-module (srfi srfi-34)
  25. #:use-module (srfi srfi-35)
  26. #:use-module (ice-9 binary-ports)
  27. #:use-module (rnrs bytevectors)
  28. #:use-module (ice-9 match)
  29. #:use-module (ice-9 rdelim)
  30. #:use-module (ice-9 vlist)
  31. #:use-module (guix store)
  32. #:use-module (guix utils)
  33. #:use-module (guix base16)
  34. #:use-module (guix memoization)
  35. #:use-module (guix combinators)
  36. #:use-module (guix monads)
  37. #:use-module (gcrypt hash)
  38. #:use-module (guix base32)
  39. #:use-module (guix records)
  40. #:use-module (guix sets)
  41. #:export (<derivation>
  42. derivation?
  43. derivation-outputs
  44. derivation-inputs
  45. derivation-sources
  46. derivation-system
  47. derivation-builder
  48. derivation-builder-arguments
  49. derivation-builder-environment-vars
  50. derivation-file-name
  51. derivation-prerequisites
  52. derivation-prerequisites-to-build
  53. <derivation-output>
  54. derivation-output?
  55. derivation-output-path
  56. derivation-output-hash-algo
  57. derivation-output-hash
  58. derivation-output-recursive?
  59. <derivation-input>
  60. derivation-input?
  61. derivation-input-path
  62. derivation-input-sub-derivations
  63. derivation-input-output-paths
  64. valid-derivation-input?
  65. &derivation-error
  66. derivation-error?
  67. derivation-error-derivation
  68. &derivation-missing-output-error
  69. derivation-missing-output-error?
  70. derivation-missing-output
  71. derivation-name
  72. derivation-output-names
  73. fixed-output-derivation?
  74. offloadable-derivation?
  75. substitutable-derivation?
  76. substitution-oracle
  77. derivation-hash
  78. read-derivation
  79. read-derivation-from-file
  80. write-derivation
  81. derivation->output-path
  82. derivation->output-paths
  83. derivation-path->output-path
  84. derivation-path->output-paths
  85. derivation
  86. raw-derivation
  87. invalidate-derivation-caches!
  88. map-derivation
  89. build-derivations
  90. built-derivations
  91. file-search-error?
  92. file-search-error-file-name
  93. file-search-error-search-path
  94. search-path*
  95. module->source-file-name
  96. build-expression->derivation)
  97. ;; Re-export it from here for backward compatibility.
  98. #:re-export (%guile-for-build))
  99. ;;;
  100. ;;; Error conditions.
  101. ;;;
  102. (define-condition-type &derivation-error &nix-error
  103. derivation-error?
  104. (derivation derivation-error-derivation))
  105. (define-condition-type &derivation-missing-output-error &derivation-error
  106. derivation-missing-output-error?
  107. (output derivation-missing-output))
  108. ;;;
  109. ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
  110. ;;;
  111. (define-immutable-record-type <derivation>
  112. (make-derivation outputs inputs sources system builder args env-vars
  113. file-name)
  114. derivation?
  115. (outputs derivation-outputs) ; list of name/<derivation-output> pairs
  116. (inputs derivation-inputs) ; list of <derivation-input>
  117. (sources derivation-sources) ; list of store paths
  118. (system derivation-system) ; string
  119. (builder derivation-builder) ; store path
  120. (args derivation-builder-arguments) ; list of strings
  121. (env-vars derivation-builder-environment-vars) ; list of name/value pairs
  122. (file-name derivation-file-name)) ; the .drv file name
  123. (define-immutable-record-type <derivation-output>
  124. (make-derivation-output path hash-algo hash recursive?)
  125. derivation-output?
  126. (path derivation-output-path) ; store path
  127. (hash-algo derivation-output-hash-algo) ; symbol | #f
  128. (hash derivation-output-hash) ; bytevector | #f
  129. (recursive? derivation-output-recursive?)) ; Boolean
  130. (define-immutable-record-type <derivation-input>
  131. (make-derivation-input path sub-derivations)
  132. derivation-input?
  133. (path derivation-input-path) ; store path
  134. (sub-derivations derivation-input-sub-derivations)) ; list of strings
  135. (set-record-type-printer! <derivation>
  136. (lambda (drv port)
  137. (format port "#<derivation ~a => ~a ~a>"
  138. (derivation-file-name drv)
  139. (string-join
  140. (map (match-lambda
  141. ((_ . output)
  142. (derivation-output-path output)))
  143. (derivation-outputs drv)))
  144. (number->string (object-address drv) 16))))
  145. (define (derivation-name drv)
  146. "Return the base name of DRV."
  147. (let ((base (store-path-package-name (derivation-file-name drv))))
  148. (string-drop-right base 4)))
  149. (define (derivation-output-names drv)
  150. "Return the names of the outputs of DRV."
  151. (match (derivation-outputs drv)
  152. (((names . _) ...)
  153. names)))
  154. (define (fixed-output-derivation? drv)
  155. "Return #t if DRV is a fixed-output derivation, such as the result of a
  156. download with a fixed hash (aka. `fetchurl')."
  157. (match drv
  158. (($ <derivation>
  159. (("out" . ($ <derivation-output> _ (? symbol?) (? bytevector?)))))
  160. #t)
  161. (_ #f)))
  162. (define (derivation-input<? input1 input2)
  163. "Compare INPUT1 and INPUT2, two <derivation-input>."
  164. (string<? (derivation-input-path input1)
  165. (derivation-input-path input2)))
  166. (define (derivation-input-output-paths input)
  167. "Return the list of output paths corresponding to INPUT, a
  168. <derivation-input>."
  169. (match input
  170. (($ <derivation-input> path sub-drvs)
  171. (map (cut derivation-path->output-path path <>)
  172. sub-drvs))))
  173. (define (valid-derivation-input? store input)
  174. "Return true if INPUT is valid--i.e., if all the outputs it requests are in
  175. the store."
  176. (every (cut valid-path? store <>)
  177. (derivation-input-output-paths input)))
  178. (define (coalesce-duplicate-inputs inputs)
  179. "Return a list of inputs, such that when INPUTS contains the same DRV twice,
  180. they are coalesced, with their sub-derivations merged. This is needed because
  181. Nix itself keeps only one of them."
  182. (fold (lambda (input result)
  183. (match input
  184. (($ <derivation-input> path sub-drvs)
  185. ;; XXX: quadratic
  186. (match (find (match-lambda
  187. (($ <derivation-input> p s)
  188. (string=? p path)))
  189. result)
  190. (#f
  191. (cons input result))
  192. ((and dup ($ <derivation-input> _ sub-drvs2))
  193. ;; Merge DUP with INPUT.
  194. (let ((sub-drvs (delete-duplicates
  195. (append sub-drvs sub-drvs2))))
  196. (cons (make-derivation-input path
  197. (sort sub-drvs string<?))
  198. (delq dup result))))))))
  199. '()
  200. inputs))
  201. (define* (derivation-prerequisites drv #:optional (cut? (const #f)))
  202. "Return the list of derivation-inputs required to build DRV, recursively.
  203. CUT? is a predicate that is passed a derivation-input and returns true to
  204. eliminate the given input and its dependencies from the search. An example of
  205. such a predicate is 'valid-derivation-input?'; when it is used as CUT?, the
  206. result is the set of prerequisites of DRV not already in valid."
  207. (let loop ((drv drv)
  208. (result '())
  209. (input-set (set)))
  210. (let ((inputs (remove (lambda (input)
  211. (or (set-contains? input-set input)
  212. (cut? input)))
  213. (derivation-inputs drv))))
  214. (fold2 loop
  215. (append inputs result)
  216. (fold set-insert input-set inputs)
  217. (map (lambda (i)
  218. (read-derivation-from-file (derivation-input-path i)))
  219. inputs)))))
  220. (define (offloadable-derivation? drv)
  221. "Return true if DRV can be offloaded, false otherwise."
  222. (match (assoc "preferLocalBuild"
  223. (derivation-builder-environment-vars drv))
  224. (("preferLocalBuild" . "1") #f)
  225. (_ #t)))
  226. (define (substitutable-derivation? drv)
  227. "Return #t if DRV can be substituted."
  228. (match (assoc "allowSubstitutes"
  229. (derivation-builder-environment-vars drv))
  230. (("allowSubstitutes" . value)
  231. (string=? value "1"))
  232. (_ #t)))
  233. (define (derivation-output-paths drv sub-drvs)
  234. "Return the output paths of outputs SUB-DRVS of DRV."
  235. (match drv
  236. (($ <derivation> outputs)
  237. (map (lambda (sub-drv)
  238. (derivation-output-path (assoc-ref outputs sub-drv)))
  239. sub-drvs))))
  240. (define* (substitution-oracle store drv
  241. #:key (mode (build-mode normal)))
  242. "Return a one-argument procedure that, when passed a store file name,
  243. returns a 'substitutable?' if it's substitutable and #f otherwise.
  244. The returned procedure
  245. knows about all substitutes for all the derivations listed in DRV, *except*
  246. those that are already valid (that is, it won't bother checking whether an
  247. item is substitutable if it's already on disk); it also knows about their
  248. prerequisites, unless they are themselves substitutable.
  249. Creating a single oracle (thus making a single 'substitutable-path-info' call) and
  250. reusing it is much more efficient than calling 'has-substitutes?' or similar
  251. repeatedly, because it avoids the costs associated with launching the
  252. substituter many times."
  253. (define valid?
  254. (cut valid-path? store <>))
  255. (define valid-input?
  256. (cut valid-derivation-input? store <>))
  257. (define (dependencies drv)
  258. ;; Skip prerequisite sub-trees of DRV whose root is valid. This allows us
  259. ;; to ask the substituter for just as much as needed, instead of asking it
  260. ;; for the whole world, which can be significantly faster when substitute
  261. ;; info is not already in cache.
  262. ;; Also, skip derivations marked as non-substitutable.
  263. (append-map (lambda (input)
  264. (let ((drv (read-derivation-from-file
  265. (derivation-input-path input))))
  266. (if (substitutable-derivation? drv)
  267. (derivation-input-output-paths input)
  268. '())))
  269. (derivation-prerequisites drv valid-input?)))
  270. (let* ((paths (delete-duplicates
  271. (concatenate
  272. (fold (lambda (drv result)
  273. (let ((self (match (derivation->output-paths drv)
  274. (((names . paths) ...)
  275. paths))))
  276. (cond ((eqv? mode (build-mode check))
  277. (cons (dependencies drv) result))
  278. ((not (substitutable-derivation? drv))
  279. (cons (dependencies drv) result))
  280. ((every valid? self)
  281. result)
  282. (else
  283. (cons* self (dependencies drv) result)))))
  284. '()
  285. drv))))
  286. (subst (fold (lambda (subst vhash)
  287. (vhash-cons (substitutable-path subst) subst
  288. vhash))
  289. vlist-null
  290. (substitutable-path-info store paths))))
  291. (lambda (item)
  292. (match (vhash-assoc item subst)
  293. (#f #f)
  294. ((key . value) value)))))
  295. (define* (derivation-prerequisites-to-build store drv
  296. #:key
  297. (mode (build-mode normal))
  298. (outputs
  299. (derivation-output-names drv))
  300. (substitutable-info
  301. (substitution-oracle store
  302. (list drv)
  303. #:mode mode)))
  304. "Return two values: the list of derivation-inputs required to build the
  305. OUTPUTS of DRV and not already available in STORE, recursively, and the list
  306. of required store paths that can be substituted. SUBSTITUTABLE-INFO must be a
  307. one-argument procedure similar to that returned by 'substitution-oracle'."
  308. (define built?
  309. (cut valid-path? store <>))
  310. (define input-built?
  311. (compose (cut any built? <>) derivation-input-output-paths))
  312. (define input-substitutable?
  313. ;; Return true if and only if all of SUB-DRVS are subsitutable. If at
  314. ;; least one is missing, then everything must be rebuilt.
  315. (compose (cut every substitutable-info <>) derivation-input-output-paths))
  316. (define (derivation-built? drv* sub-drvs)
  317. ;; In 'check' mode, assume that DRV is not built.
  318. (and (not (and (eqv? mode (build-mode check))
  319. (eq? drv* drv)))
  320. (every built? (derivation-output-paths drv* sub-drvs))))
  321. (define (derivation-substitutable-info drv sub-drvs)
  322. (and (substitutable-derivation? drv)
  323. (let ((info (filter-map substitutable-info
  324. (derivation-output-paths drv sub-drvs))))
  325. (and (= (length info) (length sub-drvs))
  326. info))))
  327. (let loop ((drv drv)
  328. (sub-drvs outputs)
  329. (build '()) ;list of <derivation-input>
  330. (substitute '())) ;list of <substitutable>
  331. (cond ((derivation-built? drv sub-drvs)
  332. (values build substitute))
  333. ((derivation-substitutable-info drv sub-drvs)
  334. =>
  335. (lambda (substitutables)
  336. (values build
  337. (append substitutables substitute))))
  338. (else
  339. (let ((build (if (substitutable-derivation? drv)
  340. build
  341. (cons (make-derivation-input
  342. (derivation-file-name drv) sub-drvs)
  343. build)))
  344. (inputs (remove (lambda (i)
  345. (or (member i build) ; XXX: quadratic
  346. (input-built? i)
  347. (input-substitutable? i)))
  348. (derivation-inputs drv))))
  349. (fold2 loop
  350. (append inputs build)
  351. (append (append-map (lambda (input)
  352. (if (and (not (input-built? input))
  353. (input-substitutable? input))
  354. (map substitutable-info
  355. (derivation-input-output-paths
  356. input))
  357. '()))
  358. (derivation-inputs drv))
  359. substitute)
  360. (map (lambda (i)
  361. (read-derivation-from-file
  362. (derivation-input-path i)))
  363. inputs)
  364. (map derivation-input-sub-derivations inputs)))))))
  365. (define (read-derivation drv-port)
  366. "Read the derivation from DRV-PORT and return the corresponding <derivation>
  367. object. Most of the time you'll want to use 'read-derivation-from-file',
  368. which caches things as appropriate and is thus more efficient."
  369. (define comma (string->symbol ","))
  370. (define (ununquote x)
  371. (match x
  372. (('unquote x) (ununquote x))
  373. ((x ...) (map ununquote x))
  374. (_ x)))
  375. (define (outputs->alist x)
  376. (fold-right (lambda (output result)
  377. (match output
  378. ((name path "" "")
  379. (alist-cons name
  380. (make-derivation-output path #f #f #f)
  381. result))
  382. ((name path hash-algo hash)
  383. ;; fixed-output
  384. (let* ((rec? (string-prefix? "r:" hash-algo))
  385. (algo (string->symbol
  386. (if rec?
  387. (string-drop hash-algo 2)
  388. hash-algo)))
  389. (hash (base16-string->bytevector hash)))
  390. (alist-cons name
  391. (make-derivation-output path algo
  392. hash rec?)
  393. result)))))
  394. '()
  395. x))
  396. (define (make-input-drvs x)
  397. (fold-right (lambda (input result)
  398. (match input
  399. ((path (sub-drvs ...))
  400. (cons (make-derivation-input path sub-drvs)
  401. result))))
  402. '()
  403. x))
  404. ;; The contents of a derivation are typically ASCII, but choosing
  405. ;; UTF-8 allows us to take the fast path for Guile's `scm_getc'.
  406. (set-port-encoding! drv-port "UTF-8")
  407. (let loop ((exp (read drv-port))
  408. (result '()))
  409. (match exp
  410. ((? eof-object?)
  411. (let ((result (reverse result)))
  412. (match result
  413. (('Derive ((outputs ...) (input-drvs ...)
  414. (input-srcs ...)
  415. (? string? system)
  416. (? string? builder)
  417. ((? string? args) ...)
  418. ((var value) ...)))
  419. (make-derivation (outputs->alist outputs)
  420. (make-input-drvs input-drvs)
  421. input-srcs
  422. system builder args
  423. (fold-right alist-cons '() var value)
  424. (port-filename drv-port)))
  425. (_
  426. (error "failed to parse derivation" drv-port result)))))
  427. ((? (cut eq? <> comma))
  428. (loop (read drv-port) result))
  429. (_
  430. (loop (read drv-port)
  431. (cons (ununquote exp) result))))))
  432. (define %derivation-cache
  433. ;; Maps derivation file names to <derivation> objects.
  434. ;; XXX: This is redundant with 'atts-cache' in the store.
  435. (make-weak-value-hash-table 200))
  436. (define (read-derivation-from-file file)
  437. "Read the derivation in FILE, a '.drv' file, and return the corresponding
  438. <derivation> object."
  439. ;; Memoize that operation because 'read-derivation' is quite expensive,
  440. ;; and because the same argument is read more than 15 times on average
  441. ;; during something like (package-derivation s gdb).
  442. (or (and file (hash-ref %derivation-cache file))
  443. (let ((drv (call-with-input-file file read-derivation)))
  444. (hash-set! %derivation-cache file drv)
  445. drv)))
  446. (define-inlinable (write-sequence lst write-item port)
  447. ;; Write each element of LST with WRITE-ITEM to PORT, separating them with a
  448. ;; comma.
  449. (match lst
  450. (()
  451. #t)
  452. ((prefix (... ...) last)
  453. (for-each (lambda (item)
  454. (write-item item port)
  455. (display "," port))
  456. prefix)
  457. (write-item last port))))
  458. (define-inlinable (write-list lst write-item port)
  459. ;; Write LST as a derivation list to PORT, using WRITE-ITEM to write each
  460. ;; element.
  461. (display "[" port)
  462. (write-sequence lst write-item port)
  463. (display "]" port))
  464. (define-inlinable (write-tuple lst write-item port)
  465. ;; Same, but write LST as a tuple.
  466. (display "(" port)
  467. (write-sequence lst write-item port)
  468. (display ")" port))
  469. (define (write-derivation drv port)
  470. "Write the ATerm-like serialization of DRV to PORT. See Section 2.4 of
  471. Eelco Dolstra's PhD dissertation for an overview of a previous version of
  472. that form."
  473. ;; Make sure we're using the faster implementation.
  474. (define format simple-format)
  475. (define (write-string-list lst)
  476. (write-list lst write port))
  477. (define (write-output output port)
  478. (match output
  479. ((name . ($ <derivation-output> path hash-algo hash recursive?))
  480. (write-tuple (list name path
  481. (if hash-algo
  482. (string-append (if recursive? "r:" "")
  483. (symbol->string hash-algo))
  484. "")
  485. (or (and=> hash bytevector->base16-string)
  486. ""))
  487. write
  488. port))))
  489. (define (write-input input port)
  490. (match input
  491. (($ <derivation-input> path sub-drvs)
  492. (display "(\"" port)
  493. (display path port)
  494. (display "\"," port)
  495. (write-string-list sub-drvs)
  496. (display ")" port))))
  497. (define (write-env-var env-var port)
  498. (match env-var
  499. ((name . value)
  500. (display "(" port)
  501. (write name port)
  502. (display "," port)
  503. (write value port)
  504. (display ")" port))))
  505. ;; Assume all the lists we are writing are already sorted.
  506. (match drv
  507. (($ <derivation> outputs inputs sources
  508. system builder args env-vars)
  509. (display "Derive(" port)
  510. (write-list outputs write-output port)
  511. (display "," port)
  512. (write-list inputs write-input port)
  513. (display "," port)
  514. (write-string-list sources)
  515. (simple-format port ",\"~a\",\"~a\"," system builder)
  516. (write-string-list args)
  517. (display "," port)
  518. (write-list env-vars write-env-var port)
  519. (display ")" port))))
  520. (define derivation->bytevector
  521. (mlambda (drv)
  522. "Return the external representation of DRV as a UTF-8-encoded string."
  523. (with-fluids ((%default-port-encoding "UTF-8"))
  524. (call-with-values open-bytevector-output-port
  525. (lambda (port get-bytevector)
  526. (write-derivation drv port)
  527. (get-bytevector))))))
  528. (define* (derivation->output-path drv #:optional (output "out"))
  529. "Return the store path of its output OUTPUT. Raise a
  530. '&derivation-missing-output-error' condition if OUTPUT is not an output of
  531. DRV."
  532. (let ((output* (assoc-ref (derivation-outputs drv) output)))
  533. (if output*
  534. (derivation-output-path output*)
  535. (raise (condition (&derivation-missing-output-error
  536. (derivation drv)
  537. (output output)))))))
  538. (define (derivation->output-paths drv)
  539. "Return the list of name/path pairs of the outputs of DRV."
  540. (map (match-lambda
  541. ((name . output)
  542. (cons name (derivation-output-path output))))
  543. (derivation-outputs drv)))
  544. (define derivation-path->output-path
  545. ;; This procedure is called frequently, so memoize it.
  546. (let ((memoized (mlambda (path output)
  547. (derivation->output-path (read-derivation-from-file path)
  548. output))))
  549. (lambda* (path #:optional (output "out"))
  550. "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
  551. path of its output OUTPUT."
  552. (memoized path output))))
  553. (define (derivation-path->output-paths path)
  554. "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
  555. list of name/path pairs of its outputs."
  556. (derivation->output-paths (read-derivation-from-file path)))
  557. ;;;
  558. ;;; Derivation primitive.
  559. ;;;
  560. (define derivation-path->base16-hash
  561. (mlambda (file)
  562. "Return a string containing the base16 representation of the hash of the
  563. derivation at FILE."
  564. (bytevector->base16-string
  565. (derivation-hash (read-derivation-from-file file)))))
  566. (define (derivation/masked-inputs drv)
  567. "Assuming DRV is a regular derivation (not fixed-output), replace the file
  568. name of each input with that input's hash."
  569. (match drv
  570. (($ <derivation> outputs inputs sources
  571. system builder args env-vars)
  572. (let ((inputs (map (match-lambda
  573. (($ <derivation-input> path sub-drvs)
  574. (let ((hash (derivation-path->base16-hash path)))
  575. (make-derivation-input hash sub-drvs))))
  576. inputs)))
  577. (make-derivation outputs
  578. (sort (coalesce-duplicate-inputs inputs)
  579. derivation-input<?)
  580. sources
  581. system builder args env-vars
  582. #f)))))
  583. (define derivation-hash ; `hashDerivationModulo' in derivations.cc
  584. (lambda (drv)
  585. "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
  586. (match drv
  587. (($ <derivation> ((_ . ($ <derivation-output> path
  588. (? symbol? hash-algo) (? bytevector? hash)
  589. (? boolean? recursive?)))))
  590. ;; A fixed-output derivation.
  591. (sha256
  592. (string->utf8
  593. (string-append "fixed:out:"
  594. (if recursive? "r:" "")
  595. (symbol->string hash-algo)
  596. ":" (bytevector->base16-string hash)
  597. ":" path))))
  598. (_
  599. ;; XXX: At this point this remains faster than `port-sha256', because
  600. ;; the SHA256 port's `write' method gets called for every single
  601. ;; character.
  602. (sha256 (derivation->bytevector (derivation/masked-inputs drv)))))))
  603. (define* (derivation store name builder args
  604. #:key
  605. (system (%current-system)) (env-vars '())
  606. (inputs '()) (outputs '("out"))
  607. hash hash-algo recursive?
  608. references-graphs
  609. allowed-references disallowed-references
  610. leaked-env-vars local-build?
  611. (substitutable? #t))
  612. "Build a derivation with the given arguments, and return the resulting
  613. <derivation> object. When HASH and HASH-ALGO are given, a
  614. fixed-output derivation is created---i.e., one whose result is known in
  615. advance, such as a file download. If, in addition, RECURSIVE? is true, then
  616. that fixed output may be an executable file or a directory and HASH must be
  617. the hash of an archive containing this output.
  618. When REFERENCES-GRAPHS is true, it must be a list of file name/store path
  619. pairs. In that case, the reference graph of each store path is exported in
  620. the build environment in the corresponding file, in a simple text format.
  621. When ALLOWED-REFERENCES is true, it must be a list of store items or outputs
  622. that the derivation's outputs may refer to. Likewise, DISALLOWED-REFERENCES,
  623. if true, must be a list of things the outputs may not refer to.
  624. When LEAKED-ENV-VARS is true, it must be a list of strings denoting
  625. environment variables that are allowed to \"leak\" from the daemon's
  626. environment to the build environment. This is only applicable to fixed-output
  627. derivations--i.e., when HASH is true. The main use is to allow variables such
  628. as \"http_proxy\" to be passed to derivations that download files.
  629. When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
  630. for offloading and should rather be built locally. This is the case for small
  631. derivations where the costs of data transfers would outweigh the benefits.
  632. When SUBSTITUTABLE? is false, declare that substitutes of the derivation's
  633. output should not be used."
  634. (define (add-output-paths drv)
  635. ;; Return DRV with an actual store path for each of its output and the
  636. ;; corresponding environment variable.
  637. (match drv
  638. (($ <derivation> outputs inputs sources
  639. system builder args env-vars)
  640. (let* ((drv-hash (derivation-hash drv))
  641. (outputs (map (match-lambda
  642. ((output-name . ($ <derivation-output>
  643. _ algo hash rec?))
  644. (let ((path
  645. (if hash
  646. (fixed-output-path name hash
  647. #:hash-algo algo
  648. #:output output-name
  649. #:recursive? rec?)
  650. (output-path output-name
  651. drv-hash name))))
  652. (cons output-name
  653. (make-derivation-output path algo
  654. hash rec?)))))
  655. outputs)))
  656. (make-derivation outputs inputs sources system builder args
  657. (map (match-lambda
  658. ((name . value)
  659. (cons name
  660. (or (and=> (assoc-ref outputs name)
  661. derivation-output-path)
  662. value))))
  663. env-vars)
  664. #f)))))
  665. (define (user+system-env-vars)
  666. ;; Some options are passed to the build daemon via the env. vars of
  667. ;; derivations (urgh!). We hide that from our API, but here is the place
  668. ;; where we kludgify those options.
  669. (let ((env-vars `(,@(if local-build?
  670. `(("preferLocalBuild" . "1"))
  671. '())
  672. ,@(if (not substitutable?)
  673. `(("allowSubstitutes" . "0"))
  674. '())
  675. ,@(if allowed-references
  676. `(("allowedReferences"
  677. . ,(string-join allowed-references)))
  678. '())
  679. ,@(if disallowed-references
  680. `(("disallowedReferences"
  681. . ,(string-join disallowed-references)))
  682. '())
  683. ,@(if leaked-env-vars
  684. `(("impureEnvVars"
  685. . ,(string-join leaked-env-vars)))
  686. '())
  687. ,@env-vars)))
  688. (match references-graphs
  689. (((file . path) ...)
  690. (let ((value (map (cut string-append <> " " <>)
  691. file path)))
  692. ;; XXX: This all breaks down if an element of FILE or PATH contains
  693. ;; white space.
  694. `(("exportReferencesGraph" . ,(string-join value " "))
  695. ,@env-vars)))
  696. (#f
  697. env-vars))))
  698. (define (env-vars-with-empty-outputs env-vars)
  699. ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
  700. ;; empty string, even outputs that do not appear in ENV-VARS.
  701. (let ((e (map (match-lambda
  702. ((name . val)
  703. (if (member name outputs)
  704. (cons name "")
  705. (cons name val))))
  706. env-vars)))
  707. (fold (lambda (output-name env-vars)
  708. (if (assoc output-name env-vars)
  709. env-vars
  710. (append env-vars `((,output-name . "")))))
  711. e
  712. outputs)))
  713. (define input->derivation-input
  714. (match-lambda
  715. (((? derivation? drv))
  716. (make-derivation-input (derivation-file-name drv) '("out")))
  717. (((? derivation? drv) sub-drvs ...)
  718. (make-derivation-input (derivation-file-name drv) sub-drvs))
  719. (((? direct-store-path? input))
  720. (make-derivation-input input '("out")))
  721. (((? direct-store-path? input) sub-drvs ...)
  722. (make-derivation-input input sub-drvs))
  723. ((input . _)
  724. (let ((path (add-to-store store (basename input)
  725. #t "sha256" input)))
  726. (make-derivation-input path '())))))
  727. ;; Note: lists are sorted alphabetically, to conform with the behavior of
  728. ;; C++ `std::map' in Nix itself.
  729. (let* ((outputs (map (lambda (name)
  730. ;; Return outputs with an empty path.
  731. (cons name
  732. (make-derivation-output "" hash-algo
  733. hash recursive?)))
  734. (sort outputs string<?)))
  735. (inputs (sort (coalesce-duplicate-inputs
  736. (map input->derivation-input
  737. (delete-duplicates inputs)))
  738. derivation-input<?))
  739. (env-vars (sort (env-vars-with-empty-outputs
  740. (user+system-env-vars))
  741. (lambda (e1 e2)
  742. (string<? (car e1) (car e2)))))
  743. (drv-masked (make-derivation outputs
  744. (filter (compose derivation-path?
  745. derivation-input-path)
  746. inputs)
  747. (filter-map (lambda (i)
  748. (let ((p (derivation-input-path i)))
  749. (and (not (derivation-path? p))
  750. p)))
  751. inputs)
  752. system builder args env-vars #f))
  753. (drv (add-output-paths drv-masked)))
  754. (let* ((file (add-data-to-store store (string-append name ".drv")
  755. (derivation->bytevector drv)
  756. (map derivation-input-path inputs)))
  757. (drv* (set-field drv (derivation-file-name) file)))
  758. (hash-set! %derivation-cache file drv*)
  759. drv*)))
  760. (define (invalidate-derivation-caches!)
  761. "Invalidate internal derivation caches. This is mostly useful for
  762. long-running processes that know what they're doing. Use with care!"
  763. ;; Typically this is meant to be used by Cuirass and Hydra, which can clear
  764. ;; caches when they start evaluating packages for another architecture.
  765. (invalidate-memoization! derivation->bytevector)
  766. (invalidate-memoization! derivation-path->base16-hash)
  767. (hash-clear! %derivation-cache))
  768. (define* (map-derivation store drv mapping
  769. #:key (system (%current-system)))
  770. "Given MAPPING, a list of pairs of derivations, return a derivation based on
  771. DRV where all the 'car's of MAPPING have been replaced by its 'cdr's,
  772. recursively."
  773. (define (substitute str initial replacements)
  774. (fold (lambda (path replacement result)
  775. (string-replace-substring result path
  776. replacement))
  777. str
  778. initial replacements))
  779. (define (substitute-file file initial replacements)
  780. (define contents
  781. (with-fluids ((%default-port-encoding #f))
  782. (call-with-input-file file read-string)))
  783. (let ((updated (substitute contents initial replacements)))
  784. (if (string=? updated contents)
  785. file
  786. ;; XXX: permissions aren't preserved.
  787. (add-text-to-store store (store-path-package-name file)
  788. updated))))
  789. (define input->output-paths
  790. (match-lambda
  791. (((? derivation? drv))
  792. (list (derivation->output-path drv)))
  793. (((? derivation? drv) sub-drvs ...)
  794. (map (cut derivation->output-path drv <>)
  795. sub-drvs))
  796. ((file)
  797. (list file))))
  798. (let ((mapping (fold (lambda (pair result)
  799. (match pair
  800. (((? derivation? orig) . replacement)
  801. (vhash-cons (derivation-file-name orig)
  802. replacement result))
  803. ((file . replacement)
  804. (vhash-cons file replacement result))))
  805. vlist-null
  806. mapping)))
  807. (define rewritten-input
  808. ;; Rewrite the given input according to MAPPING, and return an input
  809. ;; in the format used in 'derivation' calls.
  810. (mlambda (input loop)
  811. (match input
  812. (($ <derivation-input> path (sub-drvs ...))
  813. (match (vhash-assoc path mapping)
  814. ((_ . (? derivation? replacement))
  815. (cons replacement sub-drvs))
  816. ((_ . replacement)
  817. (list replacement))
  818. (#f
  819. (let* ((drv (loop (read-derivation-from-file path))))
  820. (cons drv sub-drvs))))))))
  821. (let loop ((drv drv))
  822. (let* ((inputs (map (cut rewritten-input <> loop)
  823. (derivation-inputs drv)))
  824. (initial (append-map derivation-input-output-paths
  825. (derivation-inputs drv)))
  826. (replacements (append-map input->output-paths inputs))
  827. ;; Sources typically refer to the output directories of the
  828. ;; original inputs, INITIAL. Rewrite them by substituting
  829. ;; REPLACEMENTS.
  830. (sources (map (lambda (source)
  831. (match (vhash-assoc source mapping)
  832. ((_ . replacement)
  833. replacement)
  834. (#f
  835. (substitute-file source
  836. initial replacements))))
  837. (derivation-sources drv)))
  838. ;; Now augment the lists of initials and replacements.
  839. (initial (append (derivation-sources drv) initial))
  840. (replacements (append sources replacements))
  841. (name (store-path-package-name
  842. (string-drop-right (derivation-file-name drv)
  843. 4))))
  844. (derivation store name
  845. (substitute (derivation-builder drv)
  846. initial replacements)
  847. (map (cut substitute <> initial replacements)
  848. (derivation-builder-arguments drv))
  849. #:system system
  850. #:env-vars (map (match-lambda
  851. ((var . value)
  852. `(,var
  853. . ,(substitute value initial
  854. replacements))))
  855. (derivation-builder-environment-vars drv))
  856. #:inputs (append (map list sources) inputs)
  857. #:outputs (derivation-output-names drv)
  858. #:hash (match (derivation-outputs drv)
  859. ((($ <derivation-output> _ algo hash))
  860. hash)
  861. (_ #f))
  862. #:hash-algo (match (derivation-outputs drv)
  863. ((($ <derivation-output> _ algo hash))
  864. algo)
  865. (_ #f)))))))
  866. ;;;
  867. ;;; Store compatibility layer.
  868. ;;;
  869. (define* (build-derivations store derivations
  870. #:optional (mode (build-mode normal)))
  871. "Build DERIVATIONS, a list of <derivation> objects or .drv file names, using
  872. the specified MODE."
  873. (build-things store (map (match-lambda
  874. ((? string? file) file)
  875. ((and drv ($ <derivation>))
  876. (derivation-file-name drv)))
  877. derivations)
  878. mode))
  879. ;;;
  880. ;;; Guile-based builders.
  881. ;;;
  882. (define (parent-directories file-name)
  883. "Return the list of parent dirs of FILE-NAME, in the order in which an
  884. `mkdir -p' implementation would make them."
  885. (let ((not-slash (char-set-complement (char-set #\/))))
  886. (reverse
  887. (fold (lambda (dir result)
  888. (match result
  889. (()
  890. (list dir))
  891. ((prev _ ...)
  892. (cons (string-append prev "/" dir)
  893. result))))
  894. '()
  895. (remove (cut string=? <> ".")
  896. (string-tokenize (dirname file-name) not-slash))))))
  897. (define* (imported-files store files ;deprecated
  898. #:key (name "file-import")
  899. (system (%current-system))
  900. (guile (%guile-for-build)))
  901. "Return a derivation that imports FILES into STORE. FILES must be a list
  902. of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
  903. system, imported, and appears under FINAL-PATH in the resulting store path."
  904. (let* ((files (map (match-lambda
  905. ((final-path . file-name)
  906. (list final-path
  907. (add-to-store store (basename final-path) #f
  908. "sha256" file-name))))
  909. files))
  910. (builder
  911. `(begin
  912. (mkdir %output) (chdir %output)
  913. ,@(append-map (match-lambda
  914. ((final-path store-path)
  915. (append (match (parent-directories final-path)
  916. (() '())
  917. ((head ... tail)
  918. (append (map (lambda (d)
  919. `(false-if-exception
  920. (mkdir ,d)))
  921. head)
  922. `((or (file-exists? ,tail)
  923. (mkdir ,tail))))))
  924. `((symlink ,store-path ,final-path)))))
  925. files))))
  926. (build-expression->derivation store name builder
  927. #:system system
  928. #:inputs files
  929. #:guile-for-build guile
  930. #:local-build? #t)))
  931. ;; The "file not found" error condition.
  932. (define-condition-type &file-search-error &error
  933. file-search-error?
  934. (file file-search-error-file-name)
  935. (path file-search-error-search-path))
  936. (define search-path*
  937. ;; A memoizing version of 'search-path' so 'imported-modules' does not end
  938. ;; up looking for the same files over and over again.
  939. (mlambda (path file)
  940. "Search for FILE in PATH and memoize the result. Raise a
  941. '&file-search-error' condition if it could not be found."
  942. (or (search-path path file)
  943. (raise (condition
  944. (&file-search-error (file file)
  945. (path path)))))))
  946. (define (module->source-file-name module)
  947. "Return the file name corresponding to MODULE, a Guile module name (a list
  948. of symbols.)"
  949. (string-append (string-join (map symbol->string module) "/")
  950. ".scm"))
  951. (define* (%imported-modules store modules ;deprecated
  952. #:key (name "module-import")
  953. (system (%current-system))
  954. (guile (%guile-for-build))
  955. (module-path %load-path))
  956. "Return a derivation that contains the source files of MODULES, a list of
  957. module names such as `(ice-9 q)'. All of MODULES must be in the MODULE-PATH
  958. search path."
  959. ;; TODO: Determine the closure of MODULES, build the `.go' files,
  960. ;; canonicalize the source files through read/write, etc.
  961. (let ((files (map (lambda (m)
  962. (let ((f (module->source-file-name m)))
  963. (cons f (search-path* module-path f))))
  964. modules)))
  965. (imported-files store files #:name name #:system system
  966. #:guile guile)))
  967. (define* (%compiled-modules store modules ;deprecated
  968. #:key (name "module-import-compiled")
  969. (system (%current-system))
  970. (guile (%guile-for-build))
  971. (module-path %load-path))
  972. "Return a derivation that builds a tree containing the `.go' files
  973. corresponding to MODULES. All the MODULES are built in a context where
  974. they can refer to each other."
  975. (let* ((module-drv (%imported-modules store modules
  976. #:system system
  977. #:guile guile
  978. #:module-path module-path))
  979. (module-dir (derivation->output-path module-drv))
  980. (files (map (lambda (m)
  981. (let ((f (string-join (map symbol->string m)
  982. "/")))
  983. (cons (string-append f ".go")
  984. (string-append module-dir "/" f ".scm"))))
  985. modules)))
  986. (define builder
  987. `(begin
  988. (use-modules (system base compile))
  989. (let ((out (assoc-ref %outputs "out")))
  990. (mkdir out)
  991. (chdir out))
  992. (set! %load-path
  993. (cons ,module-dir %load-path))
  994. ,@(map (match-lambda
  995. ((output . input)
  996. (let ((make-parent-dirs (map (lambda (dir)
  997. `(unless (file-exists? ,dir)
  998. (mkdir ,dir)))
  999. (parent-directories output))))
  1000. `(begin
  1001. ,@make-parent-dirs
  1002. (compile-file ,input
  1003. #:output-file ,output
  1004. #:opts %auto-compilation-options)))))
  1005. files)))
  1006. (build-expression->derivation store name builder
  1007. #:inputs `(("modules" ,module-drv))
  1008. #:system system
  1009. #:guile-for-build guile
  1010. #:local-build? #t)))
  1011. (define* (build-expression->derivation store name exp ;deprecated
  1012. #:key
  1013. (system (%current-system))
  1014. (inputs '())
  1015. (outputs '("out"))
  1016. hash hash-algo recursive?
  1017. (env-vars '())
  1018. (modules '())
  1019. guile-for-build
  1020. references-graphs
  1021. allowed-references
  1022. disallowed-references
  1023. local-build? (substitutable? #t))
  1024. "Return a derivation that executes Scheme expression EXP as a builder
  1025. for derivation NAME. INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
  1026. tuples; when SUB-DRV is omitted, \"out\" is assumed. MODULES is a list
  1027. of names of Guile modules from the current search path to be copied in
  1028. the store, compiled, and made available in the load path during the
  1029. execution of EXP.
  1030. EXP is evaluated in an environment where %OUTPUT is bound to the main
  1031. output path, %OUTPUTS is bound to a list of output/path pairs, and where
  1032. %BUILD-INPUTS is bound to an alist of string/output-path pairs made from
  1033. INPUTS. Optionally, ENV-VARS is a list of string pairs specifying the
  1034. name and value of environment variables visible to the builder. The
  1035. builder terminates by passing the result of EXP to `exit'; thus, when
  1036. EXP returns #f, the build is considered to have failed.
  1037. EXP is built using GUILE-FOR-BUILD (a derivation). When GUILE-FOR-BUILD is
  1038. omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
  1039. See the `derivation' procedure for the meaning of REFERENCES-GRAPHS,
  1040. ALLOWED-REFERENCES, DISALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
  1041. (define guile-drv
  1042. (or guile-for-build (%guile-for-build)))
  1043. (define guile
  1044. (string-append (derivation->output-path guile-drv)
  1045. "/bin/guile"))
  1046. (define module-form?
  1047. (match-lambda
  1048. (((or 'define-module 'use-modules) _ ...) #t)
  1049. (_ #f)))
  1050. (define source-path
  1051. ;; When passed an input that is a source, return its path; otherwise
  1052. ;; return #f.
  1053. (match-lambda
  1054. ((_ (? derivation?) _ ...)
  1055. #f)
  1056. ((_ path _ ...)
  1057. (and (not (derivation-path? path))
  1058. path))))
  1059. (let* ((prologue `(begin
  1060. ,@(match exp
  1061. ((_ ...)
  1062. ;; Module forms must appear at the top-level so
  1063. ;; that any macros they export can be expanded.
  1064. (filter module-form? exp))
  1065. (_ `(,exp)))
  1066. (define %output (getenv "out"))
  1067. (define %outputs
  1068. (map (lambda (o)
  1069. (cons o (getenv o)))
  1070. ',outputs))
  1071. (define %build-inputs
  1072. ',(map (match-lambda
  1073. ((name drv . rest)
  1074. (let ((sub (match rest
  1075. (() "out")
  1076. ((x) x))))
  1077. (cons name
  1078. (cond
  1079. ((derivation? drv)
  1080. (derivation->output-path drv sub))
  1081. ((derivation-path? drv)
  1082. (derivation-path->output-path drv
  1083. sub))
  1084. (else drv))))))
  1085. inputs))
  1086. ,@(if (null? modules)
  1087. '()
  1088. ;; Remove our own settings.
  1089. '((unsetenv "GUILE_LOAD_COMPILED_PATH")))
  1090. ;; Guile sets it, but remove it to avoid conflicts when
  1091. ;; building Guile-using packages.
  1092. (unsetenv "LD_LIBRARY_PATH")))
  1093. (builder (add-text-to-store store
  1094. (string-append name "-guile-builder")
  1095. ;; Explicitly use UTF-8 for determinism,
  1096. ;; and also because UTF-8 output is faster.
  1097. (with-fluids ((%default-port-encoding
  1098. "UTF-8"))
  1099. (call-with-output-string
  1100. (lambda (port)
  1101. (write prologue port)
  1102. (write
  1103. `(exit
  1104. ,(match exp
  1105. ((_ ...)
  1106. (remove module-form? exp))
  1107. (_ `(,exp))))
  1108. port))))
  1109. ;; The references don't really matter
  1110. ;; since the builder is always used in
  1111. ;; conjunction with the drv that needs
  1112. ;; it. For clarity, we add references
  1113. ;; to the subset of INPUTS that are
  1114. ;; sources, avoiding references to other
  1115. ;; .drv; otherwise, BUILDER's hash would
  1116. ;; depend on those, even if they are
  1117. ;; fixed-output.
  1118. (filter-map source-path inputs)))
  1119. (mod-drv (and (pair? modules)
  1120. (%imported-modules store modules
  1121. #:guile guile-drv
  1122. #:system system)))
  1123. (mod-dir (and mod-drv
  1124. (derivation->output-path mod-drv)))
  1125. (go-drv (and (pair? modules)
  1126. (%compiled-modules store modules
  1127. #:guile guile-drv
  1128. #:system system)))
  1129. (go-dir (and go-drv
  1130. (derivation->output-path go-drv))))
  1131. (derivation store name guile
  1132. `("--no-auto-compile"
  1133. ,@(if mod-dir `("-L" ,mod-dir) '())
  1134. ,builder)
  1135. #:system system
  1136. #:inputs `((,(or guile-for-build (%guile-for-build)))
  1137. (,builder)
  1138. ,@(map cdr inputs)
  1139. ,@(if mod-drv `((,mod-drv) (,go-drv)) '()))
  1140. ;; When MODULES is non-empty, shamelessly clobber
  1141. ;; $GUILE_LOAD_COMPILED_PATH.
  1142. #:env-vars (if go-dir
  1143. `(("GUILE_LOAD_COMPILED_PATH" . ,go-dir)
  1144. ,@(alist-delete "GUILE_LOAD_COMPILED_PATH"
  1145. env-vars))
  1146. env-vars)
  1147. #:hash hash #:hash-algo hash-algo
  1148. #:recursive? recursive?
  1149. #:outputs outputs
  1150. #:references-graphs references-graphs
  1151. #:allowed-references allowed-references
  1152. #:disallowed-references disallowed-references
  1153. #:local-build? local-build?
  1154. #:substitutable? substitutable?)))
  1155. ;;;
  1156. ;;; Monadic interface.
  1157. ;;;
  1158. (define built-derivations
  1159. (store-lift build-derivations))
  1160. (define raw-derivation
  1161. (store-lift derivation))