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.
 
 
 
 
 
 

445 lines
18 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2013 Mark H Weaver <mhw@netris.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 scripts build)
  20. #:use-module (guix ui)
  21. #:use-module (guix store)
  22. #:use-module (guix derivations)
  23. #:use-module (guix packages)
  24. #:use-module (guix utils)
  25. #:use-module (guix monads)
  26. #:use-module (guix gexp)
  27. #:use-module (ice-9 format)
  28. #:use-module (ice-9 match)
  29. #:use-module (ice-9 vlist)
  30. #:use-module (srfi srfi-1)
  31. #:use-module (srfi srfi-11)
  32. #:use-module (srfi srfi-26)
  33. #:use-module (srfi srfi-34)
  34. #:use-module (srfi srfi-37)
  35. #:autoload (gnu packages) (specification->package %package-module-path)
  36. #:autoload (guix download) (download-to-store)
  37. #:export (%standard-build-options
  38. set-build-options-from-command-line
  39. show-build-options-help
  40. guix-build))
  41. (define (register-root store paths root)
  42. "Register ROOT as an indirect GC root for all of PATHS."
  43. (let* ((root (string-append (canonicalize-path (dirname root))
  44. "/" root)))
  45. (catch 'system-error
  46. (lambda ()
  47. (match paths
  48. ((path)
  49. (symlink path root)
  50. (add-indirect-root store root))
  51. ((paths ...)
  52. (fold (lambda (path count)
  53. (let ((root (string-append root
  54. "-"
  55. (number->string count))))
  56. (symlink path root)
  57. (add-indirect-root store root))
  58. (+ 1 count))
  59. 0
  60. paths))))
  61. (lambda args
  62. (leave (_ "failed to create GC root `~a': ~a~%")
  63. root (strerror (system-error-errno args)))))))
  64. (define (package-with-source store p uri)
  65. "Return a package based on P but with its source taken from URI. Extract
  66. the new package's version number from URI."
  67. (define (numeric-extension? file-name)
  68. ;; Return true if FILE-NAME ends with digits.
  69. (string-every char-set:hex-digit (file-extension file-name)))
  70. (define (tarball-base-name file-name)
  71. ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
  72. ;; extensions.
  73. ;; TODO: Factorize.
  74. (cond ((numeric-extension? file-name)
  75. file-name)
  76. ((string=? (file-extension file-name) "tar")
  77. (file-sans-extension file-name))
  78. (else
  79. (tarball-base-name (file-sans-extension file-name)))))
  80. (let ((base (tarball-base-name (basename uri))))
  81. (let-values (((name version)
  82. (package-name->name+version base)))
  83. (package (inherit p)
  84. (version (or version (package-version p)))
  85. (source (download-to-store store uri))))))
  86. ;;;
  87. ;;; Standard command-line build options.
  88. ;;;
  89. (define (show-build-options-help)
  90. "Display on the current output port help about the standard command-line
  91. options handled by 'set-build-options-from-command-line', and listed in
  92. '%standard-build-options'."
  93. (display (_ "
  94. -L, --load-path=DIR prepend DIR to the package module search path"))
  95. (display (_ "
  96. -K, --keep-failed keep build tree of failed builds"))
  97. (display (_ "
  98. -n, --dry-run do not build the derivations"))
  99. (display (_ "
  100. --fallback fall back to building when the substituter fails"))
  101. (display (_ "
  102. --no-substitutes build instead of resorting to pre-built substitutes"))
  103. (display (_ "
  104. --no-build-hook do not attempt to offload builds via the build hook"))
  105. (display (_ "
  106. --max-silent-time=SECONDS
  107. mark the build as failed after SECONDS of silence"))
  108. (display (_ "
  109. --timeout=SECONDS mark the build as failed after SECONDS of activity"))
  110. (display (_ "
  111. --verbosity=LEVEL use the given verbosity LEVEL"))
  112. (display (_ "
  113. -c, --cores=N allow the use of up to N CPU cores for the build")))
  114. (define (set-build-options-from-command-line store opts)
  115. "Given OPTS, an alist as returned by 'args-fold' given
  116. '%standard-build-options', set the corresponding build options on STORE."
  117. ;; TODO: Add more options.
  118. (set-build-options store
  119. #:keep-failed? (assoc-ref opts 'keep-failed?)
  120. #:build-cores (or (assoc-ref opts 'cores) 0)
  121. #:fallback? (assoc-ref opts 'fallback?)
  122. #:use-substitutes? (assoc-ref opts 'substitutes?)
  123. #:use-build-hook? (assoc-ref opts 'build-hook?)
  124. #:max-silent-time (assoc-ref opts 'max-silent-time)
  125. #:timeout (assoc-ref opts 'timeout)
  126. #:print-build-trace (assoc-ref opts 'print-build-trace?)
  127. #:verbosity (assoc-ref opts 'verbosity)))
  128. (define %standard-build-options
  129. ;; List of standard command-line options for tools that build something.
  130. (list (option '(#\L "load-path") #t #f
  131. (lambda (opt name arg result . rest)
  132. ;; XXX: Imperatively modify the search paths.
  133. (%package-module-path (cons arg (%package-module-path)))
  134. (set! %load-path (cons arg %load-path))
  135. (set! %load-compiled-path (cons arg %load-compiled-path))
  136. (apply values (cons result rest))))
  137. (option '(#\K "keep-failed") #f #f
  138. (lambda (opt name arg result . rest)
  139. (apply values
  140. (alist-cons 'keep-failed? #t result)
  141. rest)))
  142. (option '("fallback") #f #f
  143. (lambda (opt name arg result . rest)
  144. (apply values
  145. (alist-cons 'fallback? #t
  146. (alist-delete 'fallback? result))
  147. rest)))
  148. (option '("no-substitutes") #f #f
  149. (lambda (opt name arg result . rest)
  150. (apply values
  151. (alist-cons 'substitutes? #f
  152. (alist-delete 'substitutes? result))
  153. rest)))
  154. (option '("no-build-hook") #f #f
  155. (lambda (opt name arg result . rest)
  156. (apply values
  157. (alist-cons 'build-hook? #f
  158. (alist-delete 'build-hook? result))
  159. rest)))
  160. (option '("max-silent-time") #t #f
  161. (lambda (opt name arg result . rest)
  162. (apply values
  163. (alist-cons 'max-silent-time (string->number* arg)
  164. result)
  165. rest)))
  166. (option '("timeout") #t #f
  167. (lambda (opt name arg result . rest)
  168. (apply values
  169. (alist-cons 'timeout (string->number* arg) result)
  170. rest)))
  171. (option '("verbosity") #t #f
  172. (lambda (opt name arg result . rest)
  173. (let ((level (string->number arg)))
  174. (apply values
  175. (alist-cons 'verbosity level
  176. (alist-delete 'verbosity result))
  177. rest))))
  178. (option '(#\c "cores") #t #f
  179. (lambda (opt name arg result . rest)
  180. (let ((c (false-if-exception (string->number arg))))
  181. (if c
  182. (apply values (alist-cons 'cores c result) rest)
  183. (leave (_ "~a: not a number~%") arg)))))))
  184. ;;;
  185. ;;; Command-line options.
  186. ;;;
  187. (define %default-options
  188. ;; Alist of default option values.
  189. `((system . ,(%current-system))
  190. (substitutes? . #t)
  191. (build-hook? . #t)
  192. (print-build-trace? . #t)
  193. (max-silent-time . 3600)
  194. (verbosity . 0)))
  195. (define (show-help)
  196. (display (_ "Usage: guix build [OPTION]... PACKAGE-OR-DERIVATION...
  197. Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  198. (display (_ "
  199. -e, --expression=EXPR build the package or derivation EXPR evaluates to"))
  200. (display (_ "
  201. -S, --source build the packages' source derivations"))
  202. (display (_ "
  203. -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
  204. (display (_ "
  205. --target=TRIPLET cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
  206. (display (_ "
  207. --with-source=SOURCE
  208. use SOURCE when building the corresponding package"))
  209. (display (_ "
  210. -d, --derivations return the derivation paths of the given packages"))
  211. (display (_ "
  212. -r, --root=FILE make FILE a symlink to the result, and register it
  213. as a garbage collector root"))
  214. (display (_ "
  215. --log-file return the log file names for the given derivations"))
  216. (newline)
  217. (show-build-options-help)
  218. (newline)
  219. (display (_ "
  220. -h, --help display this help and exit"))
  221. (display (_ "
  222. -V, --version display version information and exit"))
  223. (newline)
  224. (show-bug-report-information))
  225. (define %options
  226. ;; Specifications of the command-line options.
  227. (cons* (option '(#\h "help") #f #f
  228. (lambda args
  229. (show-help)
  230. (exit 0)))
  231. (option '(#\V "version") #f #f
  232. (lambda args
  233. (show-version-and-exit "guix build")))
  234. (option '(#\S "source") #f #f
  235. (lambda (opt name arg result)
  236. (alist-cons 'source? #t result)))
  237. (option '(#\s "system") #t #f
  238. (lambda (opt name arg result)
  239. (alist-cons 'system arg
  240. (alist-delete 'system result eq?))))
  241. (option '("target") #t #f
  242. (lambda (opt name arg result)
  243. (alist-cons 'target arg
  244. (alist-delete 'target result eq?))))
  245. (option '(#\d "derivations") #f #f
  246. (lambda (opt name arg result)
  247. (alist-cons 'derivations-only? #t result)))
  248. (option '(#\e "expression") #t #f
  249. (lambda (opt name arg result)
  250. (alist-cons 'expression arg result)))
  251. (option '(#\n "dry-run") #f #f
  252. (lambda (opt name arg result)
  253. (alist-cons 'dry-run? #t result)))
  254. (option '(#\r "root") #t #f
  255. (lambda (opt name arg result)
  256. (alist-cons 'gc-root arg result)))
  257. (option '("log-file") #f #f
  258. (lambda (opt name arg result)
  259. (alist-cons 'log-file? #t result)))
  260. (option '("with-source") #t #f
  261. (lambda (opt name arg result)
  262. (alist-cons 'with-source arg result)))
  263. %standard-build-options))
  264. (define (options->derivations store opts)
  265. "Given OPTS, the result of 'args-fold', return a list of derivations to
  266. build."
  267. (define package->derivation
  268. (match (assoc-ref opts 'target)
  269. (#f package-derivation)
  270. (triplet
  271. (cut package-cross-derivation <> <> triplet <>))))
  272. (define src? (assoc-ref opts 'source?))
  273. (define sys (assoc-ref opts 'system))
  274. (let ((opts (options/with-source store
  275. (options/resolve-packages store opts))))
  276. (filter-map (match-lambda
  277. (('argument . (? package? p))
  278. (if src?
  279. (let ((s (package-source p)))
  280. (package-source-derivation store s))
  281. (package->derivation store p sys)))
  282. (('argument . (? derivation? drv))
  283. drv)
  284. (('argument . (? derivation-path? drv))
  285. (call-with-input-file drv read-derivation))
  286. (('argument . (? store-path?))
  287. ;; Nothing to do; maybe for --log-file.
  288. #f)
  289. (_ #f))
  290. opts)))
  291. (define (options/resolve-packages store opts)
  292. "Return OPTS with package specification strings replaced by actual
  293. packages."
  294. (define system
  295. (or (assoc-ref opts 'system) (%current-system)))
  296. (map (match-lambda
  297. (('argument . (? string? spec))
  298. (if (store-path? spec)
  299. `(argument . ,spec)
  300. `(argument . ,(specification->package spec))))
  301. (('expression . str)
  302. (match (read/eval str)
  303. ((? package? p)
  304. `(argument . ,p))
  305. ((? procedure? proc)
  306. (let ((drv (run-with-store store (proc) #:system system)))
  307. `(argument . ,drv)))
  308. ((? gexp? gexp)
  309. (let ((drv (run-with-store store
  310. (gexp->derivation "gexp" gexp
  311. #:system system))))
  312. `(argument . ,drv)))))
  313. (opt opt))
  314. opts))
  315. (define (options/with-source store opts)
  316. "Process with 'with-source' options in OPTS, replacing the relevant package
  317. arguments with packages that use the specified source."
  318. (define new-sources
  319. (filter-map (match-lambda
  320. (('with-source . uri)
  321. (cons (package-name->name+version (basename uri))
  322. uri))
  323. (_ #f))
  324. opts))
  325. (let loop ((opts opts)
  326. (sources new-sources)
  327. (result '()))
  328. (match opts
  329. (()
  330. (unless (null? sources)
  331. (warning (_ "sources do not match any package:~{ ~a~}~%")
  332. (match sources
  333. (((name . uri) ...)
  334. uri))))
  335. (reverse result))
  336. ((('argument . (? package? p)) tail ...)
  337. (let ((source (assoc-ref sources (package-name p))))
  338. (loop tail
  339. (alist-delete (package-name p) sources)
  340. (alist-cons 'argument
  341. (if source
  342. (package-with-source store p source)
  343. p)
  344. result))))
  345. ((('with-source . _) tail ...)
  346. (loop tail sources result))
  347. ((head tail ...)
  348. (loop tail sources (cons head result))))))
  349. ;;;
  350. ;;; Entry point.
  351. ;;;
  352. (define (guix-build . args)
  353. (define (parse-options)
  354. ;; Return the alist of option values.
  355. (args-fold* args %options
  356. (lambda (opt name arg result)
  357. (leave (_ "~A: unrecognized option~%") name))
  358. (lambda (arg result)
  359. (alist-cons 'argument arg result))
  360. %default-options))
  361. (with-error-handling
  362. ;; Ask for absolute file names so that .drv file names passed from the
  363. ;; user to 'read-derivation' are absolute when it returns.
  364. (with-fluids ((%file-port-name-canonicalization 'absolute))
  365. (let* ((opts (parse-options))
  366. (store (open-connection))
  367. (drv (options->derivations store opts))
  368. (roots (filter-map (match-lambda
  369. (('gc-root . root) root)
  370. (_ #f))
  371. opts)))
  372. (set-build-options-from-command-line store opts)
  373. (unless (assoc-ref opts 'log-file?)
  374. (show-what-to-build store drv
  375. #:use-substitutes? (assoc-ref opts 'substitutes?)
  376. #:dry-run? (assoc-ref opts 'dry-run?)))
  377. (cond ((assoc-ref opts 'log-file?)
  378. (for-each (lambda (file)
  379. (let ((log (log-file store file)))
  380. (if log
  381. (format #t "~a~%" log)
  382. (leave (_ "no build log for '~a'~%")
  383. file))))
  384. (delete-duplicates
  385. (append (map derivation-file-name drv)
  386. (filter-map (match-lambda
  387. (('argument
  388. . (? store-path? file))
  389. file)
  390. (_ #f))
  391. opts)))))
  392. ((assoc-ref opts 'derivations-only?)
  393. (format #t "~{~a~%~}" (map derivation-file-name drv))
  394. (for-each (cut register-root store <> <>)
  395. (map (compose list derivation-file-name) drv)
  396. roots))
  397. ((not (assoc-ref opts 'dry-run?))
  398. (and (build-derivations store drv)
  399. (for-each (lambda (d)
  400. (format #t "~{~a~%~}"
  401. (map (match-lambda
  402. ((out-name . out)
  403. (derivation->output-path
  404. d out-name)))
  405. (derivation-outputs d))))
  406. drv)
  407. (for-each (cut register-root store <> <>)
  408. (map (lambda (drv)
  409. (map cdr
  410. (derivation->output-paths drv)))
  411. drv)
  412. roots))))))))