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.

276 lines
11 KiB

  1. #!/bin/sh
  2. # aside from this initial boilerplate, this is actually -*- scheme -*- code
  3. prefix="@prefix@"
  4. datarootdir="@datarootdir@"
  5. GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
  6. export GUILE_LOAD_COMPILED_PATH
  7. main='(module-ref (resolve-interface '\''(guix-build)) '\'guix-build')'
  8. exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \
  9. -c "(apply $main (cdr (command-line)))" "$@"
  10. !#
  11. ;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*-
  12. ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  13. ;;;
  14. ;;; This file is part of Guix.
  15. ;;;
  16. ;;; Guix is free software; you can redistribute it and/or modify it
  17. ;;; under the terms of the GNU General Public License as published by
  18. ;;; the Free Software Foundation; either version 3 of the License, or (at
  19. ;;; your option) any later version.
  20. ;;;
  21. ;;; Guix is distributed in the hope that it will be useful, but
  22. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  23. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  24. ;;; GNU General Public License for more details.
  25. ;;;
  26. ;;; You should have received a copy of the GNU General Public License
  27. ;;; along with Guix. If not, see <http://www.gnu.org/licenses/>.
  28. (define-module (guix-build)
  29. #:use-module (guix ui)
  30. #:use-module (guix store)
  31. #:use-module (guix derivations)
  32. #:use-module (guix packages)
  33. #:use-module (guix utils)
  34. #:use-module (ice-9 format)
  35. #:use-module (ice-9 match)
  36. #:use-module (srfi srfi-1)
  37. #:use-module (srfi srfi-26)
  38. #:use-module (srfi srfi-34)
  39. #:use-module (srfi srfi-37)
  40. #:autoload (distro) (find-packages-by-name)
  41. #:export (guix-build))
  42. (define %store
  43. (open-connection))
  44. (define (derivations-from-package-expressions exp system source?)
  45. "Eval EXP and return the corresponding derivation path for SYSTEM.
  46. When SOURCE? is true, return the derivations of the package sources."
  47. (let ((p (eval exp (current-module))))
  48. (if (package? p)
  49. (if source?
  50. (package-source-derivation %store (package-source p))
  51. (package-derivation %store p system))
  52. (begin
  53. (format (current-error-port)
  54. (_ "expression `~s' does not evaluate to a package")
  55. exp)
  56. (exit 1)))))
  57. ;;;
  58. ;;; Command-line options.
  59. ;;;
  60. (define %default-options
  61. ;; Alist of default option values.
  62. `((system . ,(%current-system))
  63. (substitutes? . #t)))
  64. (define (show-version)
  65. (display "guix-build (@PACKAGE_NAME@) @PACKAGE_VERSION@\n"))
  66. (define (show-help)
  67. (display (_ "Usage: guix-build [OPTION]... PACKAGE-OR-DERIVATION...
  68. Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
  69. (display (_ "
  70. -e, --expression=EXPR build the package EXPR evaluates to"))
  71. (display (_ "
  72. -S, --source build the packages' source derivations"))
  73. (display (_ "
  74. -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\""))
  75. (display (_ "
  76. -d, --derivations return the derivation paths of the given packages"))
  77. (display (_ "
  78. -K, --keep-failed keep build tree of failed builds"))
  79. (display (_ "
  80. -n, --dry-run do not build the derivations"))
  81. (display (_ "
  82. --no-substitutes build instead of resorting to pre-built substitutes"))
  83. (display (_ "
  84. -c, --cores=N allow the use of up to N CPU cores for the build"))
  85. (display (_ "
  86. -r, --root=FILE make FILE a symlink to the result, and register it
  87. as a garbage collector root"))
  88. (newline)
  89. (display (_ "
  90. -h, --help display this help and exit"))
  91. (display (_ "
  92. -V, --version display version information and exit"))
  93. (newline)
  94. (format #t (_ "
  95. Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
  96. (define %options
  97. ;; Specifications of the command-line options.
  98. (list (option '(#\h "help") #f #f
  99. (lambda args
  100. (show-help)
  101. (exit 0)))
  102. (option '(#\V "version") #f #f
  103. (lambda args
  104. (show-version)
  105. (exit 0)))
  106. (option '(#\S "source") #f #f
  107. (lambda (opt name arg result)
  108. (alist-cons 'source? #t result)))
  109. (option '(#\s "system") #t #f
  110. (lambda (opt name arg result)
  111. (alist-cons 'system arg
  112. (alist-delete 'system result eq?))))
  113. (option '(#\d "derivations") #f #f
  114. (lambda (opt name arg result)
  115. (alist-cons 'derivations-only? #t result)))
  116. (option '(#\e "expression") #t #f
  117. (lambda (opt name arg result)
  118. (alist-cons 'expression
  119. (call-with-input-string arg read)
  120. result)))
  121. (option '(#\K "keep-failed") #f #f
  122. (lambda (opt name arg result)
  123. (alist-cons 'keep-failed? #t result)))
  124. (option '(#\c "cores") #t #f
  125. (lambda (opt name arg result)
  126. (let ((c (false-if-exception (string->number arg))))
  127. (if c
  128. (alist-cons 'cores c result)
  129. (leave (_ "~a: not a number~%") arg)))))
  130. (option '(#\n "dry-run") #f #f
  131. (lambda (opt name arg result)
  132. (alist-cons 'dry-run? #t result)))
  133. (option '("no-substitutes") #f #f
  134. (lambda (opt name arg result)
  135. (alist-cons 'substitutes? #f
  136. (alist-delete 'substitutes? result))))
  137. (option '(#\r "root") #t #f
  138. (lambda (opt name arg result)
  139. (alist-cons 'gc-root arg result)))))
  140. ;;;
  141. ;;; Entry point.
  142. ;;;
  143. (define (guix-build . args)
  144. (define (parse-options)
  145. ;; Return the alist of option values.
  146. (args-fold args %options
  147. (lambda (opt name arg result)
  148. (leave (_ "~A: unrecognized option~%") name))
  149. (lambda (arg result)
  150. (alist-cons 'argument arg result))
  151. %default-options))
  152. (define (register-root drv root)
  153. ;; Register ROOT as an indirect GC root for DRV's outputs.
  154. (let* ((root (string-append (canonicalize-path (dirname root))
  155. "/" root))
  156. (drv* (call-with-input-file drv read-derivation))
  157. (outputs (derivation-outputs drv*))
  158. (outputs* (map (compose derivation-output-path cdr) outputs)))
  159. (catch 'system-error
  160. (lambda ()
  161. (match outputs*
  162. ((output)
  163. (symlink output root)
  164. (add-indirect-root %store root))
  165. ((outputs ...)
  166. (fold (lambda (output count)
  167. (let ((root (string-append root "-" (number->string count))))
  168. (symlink output root)
  169. (add-indirect-root %store root))
  170. (+ 1 count))
  171. 0
  172. outputs))))
  173. (lambda args
  174. (format (current-error-port)
  175. (_ "failed to create GC root `~a': ~a~%")
  176. root (strerror (system-error-errno args)))
  177. (exit 1)))))
  178. (setlocale LC_ALL "")
  179. (textdomain "guix")
  180. (setvbuf (current-output-port) _IOLBF)
  181. (setvbuf (current-error-port) _IOLBF)
  182. (with-error-handling
  183. (let* ((opts (parse-options))
  184. (src? (assoc-ref opts 'source?))
  185. (sys (assoc-ref opts 'system))
  186. (drv (filter-map (match-lambda
  187. (('expression . exp)
  188. (derivations-from-package-expressions exp sys
  189. src?))
  190. (('argument . (? derivation-path? drv))
  191. drv)
  192. (('argument . (? string? x))
  193. (match (find-packages-by-name x)
  194. ((p _ ...)
  195. (if src?
  196. (let ((s (package-source p)))
  197. (package-source-derivation %store s))
  198. (package-derivation %store p sys)))
  199. (_
  200. (leave (_ "~A: unknown package~%") x))))
  201. (_ #f))
  202. opts))
  203. (req (append-map (lambda (drv-path)
  204. (let ((d (call-with-input-file drv-path
  205. read-derivation)))
  206. (derivation-prerequisites-to-build %store d)))
  207. drv))
  208. (req* (delete-duplicates
  209. (append (remove (compose (cut valid-path? %store <>)
  210. derivation-path->output-path)
  211. drv)
  212. (map derivation-input-path req)))))
  213. (if (assoc-ref opts 'dry-run?)
  214. (format (current-error-port)
  215. (N_ "~:[the following derivation would be built:~%~{ ~a~%~}~;~]"
  216. "~:[the following derivations would be built:~%~{ ~a~%~}~;~]"
  217. (length req*))
  218. (null? req*) req*)
  219. (format (current-error-port)
  220. (N_ "~:[the following derivation will be built:~%~{ ~a~%~}~;~]"
  221. "~:[the following derivations will be built:~%~{ ~a~%~}~;~]"
  222. (length req*))
  223. (null? req*) req*))
  224. ;; TODO: Add more options.
  225. (set-build-options %store
  226. #:keep-failed? (assoc-ref opts 'keep-failed?)
  227. #:build-cores (or (assoc-ref opts 'cores) 0)
  228. #:use-substitutes? (assoc-ref opts 'substitutes?))
  229. (if (assoc-ref opts 'derivations-only?)
  230. (format #t "~{~a~%~}" drv)
  231. (or (assoc-ref opts 'dry-run?)
  232. (and (build-derivations %store drv)
  233. (for-each (lambda (d)
  234. (let ((drv (call-with-input-file d
  235. read-derivation)))
  236. (format #t "~{~a~%~}"
  237. (map (match-lambda
  238. ((out-name . out)
  239. (derivation-path->output-path
  240. d out-name)))
  241. (derivation-outputs drv)))))
  242. drv)
  243. (let ((roots (filter-map (match-lambda
  244. (('gc-root . root)
  245. root)
  246. (_ #f))
  247. opts)))
  248. (when roots
  249. (for-each (cut register-root <> <>)
  250. drv roots)
  251. #t))))))))
  252. ;; Local Variables:
  253. ;; eval: (put 'guard 'scheme-indent-function 1)
  254. ;; End: