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.
 
 
 
 
 
 

1113 lines
47 KiB

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