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.
 
 
 
 
 
 

890 lines
36 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2017, 2018 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 self)
  19. #:use-module (guix config)
  20. #:use-module (guix i18n)
  21. #:use-module (guix modules)
  22. #:use-module (guix gexp)
  23. #:use-module (guix store)
  24. #:use-module (guix monads)
  25. #:use-module (guix discovery)
  26. #:use-module (guix packages)
  27. #:use-module (guix sets)
  28. #:use-module (guix utils)
  29. #:use-module (guix modules)
  30. #:use-module (guix build utils)
  31. #:use-module ((guix build compile) #:select (%lightweight-optimizations))
  32. #:use-module (srfi srfi-1)
  33. #:use-module (srfi srfi-9)
  34. #:use-module (ice-9 match)
  35. #:export (make-config.scm
  36. whole-package ;for internal use in 'guix pull'
  37. compiled-guix
  38. guix-derivation
  39. reload-guix))
  40. ;;;
  41. ;;; Dependency handling.
  42. ;;;
  43. (define* (false-if-wrong-guile package
  44. #:optional (guile-version (effective-version)))
  45. "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
  46. 2.0 instead of 2.2), otherwise return PACKAGE."
  47. (let ((guile (any (match-lambda
  48. ((label (? package? dep) _ ...)
  49. (and (string=? (package-name dep) "guile")
  50. dep)))
  51. (package-direct-inputs package))))
  52. (and (or (not guile)
  53. (string-prefix? guile-version
  54. (package-version guile)))
  55. package)))
  56. (define (package-for-guile guile-version . names)
  57. "Return the package with one of the given NAMES that depends on
  58. GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
  59. (let loop ((names names))
  60. (match names
  61. (()
  62. #f)
  63. ((name rest ...)
  64. (match (specification->package name)
  65. (#f
  66. (loop rest))
  67. ((? package? package)
  68. (or (false-if-wrong-guile package guile-version)
  69. (loop rest))))))))
  70. (define specification->package
  71. ;; Use our own variant of that procedure because that of (gnu packages)
  72. ;; would traverse all the .scm files, which is wasteful.
  73. (let ((ref (lambda (module variable)
  74. (module-ref (resolve-interface module) variable))))
  75. (match-lambda
  76. ("guile" (ref '(gnu packages commencement) 'guile-final))
  77. ("guile-json" (ref '(gnu packages guile) 'guile-json))
  78. ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
  79. ("guile-git" (ref '(gnu packages guile) 'guile-git))
  80. ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3))
  81. ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt))
  82. ("zlib" (ref '(gnu packages compression) 'zlib))
  83. ("gzip" (ref '(gnu packages compression) 'gzip))
  84. ("bzip2" (ref '(gnu packages compression) 'bzip2))
  85. ("xz" (ref '(gnu packages compression) 'xz))
  86. ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json))
  87. ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh))
  88. ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git))
  89. ;; XXX: No "guile2.0-sqlite3".
  90. (_ #f)))) ;no such package
  91. ;;;
  92. ;;; Derivations.
  93. ;;;
  94. ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's
  95. ;; easier to express things this way.
  96. (define-record-type <node>
  97. (node name modules source dependencies compiled)
  98. node?
  99. (name node-name) ;string
  100. (modules node-modules) ;list of module names
  101. (source node-source) ;list of source files
  102. (dependencies node-dependencies) ;list of nodes
  103. (compiled node-compiled)) ;node -> lowerable object
  104. (define (node-fold proc init nodes)
  105. (let loop ((nodes nodes)
  106. (visited (setq))
  107. (result init))
  108. (match nodes
  109. (() result)
  110. ((head tail ...)
  111. (if (set-contains? visited head)
  112. (loop tail visited result)
  113. (loop tail (set-insert head visited)
  114. (proc head result)))))))
  115. (define (node-modules/recursive nodes)
  116. (node-fold (lambda (node modules)
  117. (append (node-modules node) modules))
  118. '()
  119. nodes))
  120. (define* (closure modules #:optional (except '()))
  121. (source-module-closure modules
  122. #:select?
  123. (match-lambda
  124. (('guix 'config)
  125. #f)
  126. ((and module
  127. (or ('guix _ ...) ('gnu _ ...)))
  128. (not (member module except)))
  129. (rest #f))))
  130. (define module->import
  131. ;; Return a file-name/file-like object pair for the specified module and
  132. ;; suitable for 'imported-files'.
  133. (match-lambda
  134. ((module '=> thing)
  135. (let ((file (module-name->file-name module)))
  136. (list file thing)))
  137. (module
  138. (let ((file (module-name->file-name module)))
  139. (list file
  140. (local-file (search-path %load-path file)))))))
  141. (define* (scheme-node name modules #:optional (dependencies '())
  142. #:key (extra-modules '()) (extra-files '())
  143. (extensions '())
  144. parallel? guile-for-build)
  145. "Return a node that builds the given Scheme MODULES, and depends on
  146. DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules
  147. added to the source, and EXTRA-FILES is a list of additional files.
  148. EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that
  149. must be present in the search path."
  150. (let* ((modules (append extra-modules
  151. (closure modules
  152. (node-modules/recursive dependencies))))
  153. (module-files (map module->import modules))
  154. (source (imported-files (string-append name "-source")
  155. (append module-files extra-files))))
  156. (node name modules source dependencies
  157. (compiled-modules name source
  158. (map car module-files)
  159. (map node-source dependencies)
  160. (map node-compiled dependencies)
  161. #:extensions extensions
  162. #:parallel? parallel?
  163. #:guile-for-build guile-for-build))))
  164. (define (file-imports directory sub-directory pred)
  165. "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a
  166. list of file-name/file-like objects suitable as inputs to 'imported-files'."
  167. (map (lambda (file)
  168. (list (string-drop file (+ 1 (string-length directory)))
  169. (local-file file #:recursive? #t)))
  170. (find-files (string-append directory "/" sub-directory) pred)))
  171. (define (scheme-modules* directory sub-directory)
  172. "Return the list of module names found under SUB-DIRECTORY in DIRECTORY."
  173. (let ((prefix (string-length directory)))
  174. (map (lambda (file)
  175. (file-name->module-name (string-drop file prefix)))
  176. (scheme-files (string-append directory "/" sub-directory)))))
  177. (define* (sub-directory item sub-directory)
  178. "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like
  179. object."
  180. (match item
  181. ((? string?)
  182. ;; This is the optimal case: we return a new "source". Thus, a
  183. ;; derivation that depends on this sub-directory does not depend on ITEM
  184. ;; itself.
  185. (local-file (string-append item "/" sub-directory)
  186. #:recursive? #t))
  187. ;; TODO: Add 'local-file?' case.
  188. (_
  189. ;; In this case, anything that refers to the result also depends on ITEM,
  190. ;; which isn't great.
  191. (file-append item "/" sub-directory))))
  192. (define* (locale-data source domain
  193. #:optional (directory domain))
  194. "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to
  195. DOMAIN, a gettext domain."
  196. (define gettext
  197. (module-ref (resolve-interface '(gnu packages gettext))
  198. 'gettext-minimal))
  199. (define build
  200. (with-imported-modules '((guix build utils))
  201. #~(begin
  202. (use-modules (guix build utils)
  203. (srfi srfi-26)
  204. (ice-9 match) (ice-9 ftw))
  205. (define po-directory
  206. #+(sub-directory source (string-append "po/" directory)))
  207. (define (compile language)
  208. (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/"
  209. #$domain ".mo")))
  210. (mkdir-p (dirname gmo))
  211. (invoke #+(file-append gettext "/bin/msgfmt")
  212. "-c" "--statistics" "--verbose"
  213. "-o" gmo
  214. (string-append po-directory "/" language ".po"))))
  215. (define (linguas)
  216. ;; Return the list of languages. Note: don't read 'LINGUAS'
  217. ;; because it contains things like 'en@boldquot' that do not have
  218. ;; a corresponding .po file.
  219. (map (cut basename <> ".po")
  220. (scandir po-directory
  221. (cut string-suffix? ".po" <>))))
  222. (for-each compile (linguas)))))
  223. (computed-file (string-append "guix-locale-" domain)
  224. build))
  225. (define (info-manual source)
  226. "Return the Info manual built from SOURCE."
  227. (define texinfo
  228. (module-ref (resolve-interface '(gnu packages texinfo))
  229. 'texinfo))
  230. (define graphviz
  231. (module-ref (resolve-interface '(gnu packages graphviz))
  232. 'graphviz))
  233. (define documentation
  234. (sub-directory source "doc"))
  235. (define examples
  236. (sub-directory source "gnu/system/examples"))
  237. (define build
  238. (with-imported-modules '((guix build utils))
  239. #~(begin
  240. (use-modules (guix build utils))
  241. (mkdir #$output)
  242. ;; Create 'version.texi'.
  243. ;; XXX: Can we use a more meaningful version string yet one that
  244. ;; doesn't change at each commit?
  245. (call-with-output-file "version.texi"
  246. (lambda (port)
  247. (let ((version "0.0-git)"))
  248. (format port "
  249. @set UPDATED 1 January 1970
  250. @set UPDATED-MONTH January 1970
  251. @set EDITION ~a
  252. @set VERSION ~a\n" version version))))
  253. ;; Copy configuration templates that the manual includes.
  254. (for-each (lambda (template)
  255. (copy-file template
  256. (string-append
  257. "os-config-"
  258. (basename template ".tmpl")
  259. ".texi")))
  260. (find-files #$examples "\\.tmpl$"))
  261. ;; Build graphs.
  262. (mkdir-p (string-append #$output "/images"))
  263. (for-each (lambda (dot-file)
  264. (invoke #+(file-append graphviz "/bin/dot")
  265. "-Tpng" "-Gratio=.9" "-Gnodesep=.005"
  266. "-Granksep=.00005" "-Nfontsize=9"
  267. "-Nheight=.1" "-Nwidth=.1"
  268. "-o" (string-append #$output "/images/"
  269. (basename dot-file ".dot")
  270. ".png")
  271. dot-file))
  272. (find-files (string-append #$documentation "/images")
  273. "\\.dot$"))
  274. ;; Copy other PNGs.
  275. (for-each (lambda (png-file)
  276. (install-file png-file
  277. (string-append #$output "/images")))
  278. (find-files (string-append #$documentation "/images")
  279. "\\.png$"))
  280. ;; Finally build the manual. Copy it the Texinfo files to $PWD and
  281. ;; add a symlink to the 'images' directory so that 'makeinfo' can
  282. ;; see those images and produce image references in the Info output.
  283. (copy-recursively #$documentation "."
  284. #:log (%make-void-port "w"))
  285. (delete-file-recursively "images")
  286. (symlink (string-append #$output "/images") "images")
  287. (for-each (lambda (texi)
  288. (unless (string=? "guix.texi" texi)
  289. ;; Create 'version-LL.texi'.
  290. (let* ((base (basename texi ".texi"))
  291. (dot (string-index base #\.))
  292. (tag (string-drop base (+ 1 dot))))
  293. (symlink "version.texi"
  294. (string-append "version-" tag ".texi"))))
  295. (invoke #+(file-append texinfo "/bin/makeinfo")
  296. texi "-I" #$documentation
  297. "-I" "."
  298. "-o" (string-append #$output "/"
  299. (basename texi ".texi")
  300. ".info")))
  301. (cons "guix.texi"
  302. (find-files "." "^guix\\.[a-z]{2}\\.texi$"))))))
  303. (computed-file "guix-manual" build))
  304. (define* (guix-command modules #:key source (dependencies '())
  305. (guile-version (effective-version)))
  306. "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its
  307. load path."
  308. (program-file "guix-command"
  309. #~(begin
  310. (set! %load-path
  311. (append '#$(map (lambda (package)
  312. (file-append package
  313. "/share/guile/site/"
  314. guile-version))
  315. dependencies)
  316. %load-path))
  317. (set! %load-compiled-path
  318. (append '#$(map (lambda (package)
  319. (file-append package "/lib/guile/"
  320. guile-version
  321. "/site-ccache"))
  322. dependencies)
  323. %load-compiled-path))
  324. (set! %load-path (cons #$modules %load-path))
  325. (set! %load-compiled-path
  326. (cons #$modules %load-compiled-path))
  327. (let ((guix-main (module-ref (resolve-interface '(guix ui))
  328. 'guix-main)))
  329. #$(if source
  330. #~(begin
  331. (bindtextdomain "guix"
  332. #$(locale-data source "guix"))
  333. (bindtextdomain "guix-packages"
  334. #$(locale-data source
  335. "guix-packages"
  336. "packages")))
  337. #t)
  338. ;; XXX: It would be more convenient to change it to:
  339. ;; (exit (apply guix-main (command-line)))
  340. (apply guix-main (command-line))))))
  341. (define* (whole-package name modules dependencies
  342. #:key
  343. (guile-version (effective-version))
  344. info
  345. (command (guix-command modules
  346. #:dependencies dependencies
  347. #:guile-version guile-version)))
  348. "Return the whole Guix package NAME that uses MODULES, a derivation of all
  349. the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the
  350. 'guix' program to use; INFO is the Info manual."
  351. ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'.
  352. (computed-file name
  353. (with-imported-modules '((guix build utils))
  354. #~(begin
  355. (use-modules (guix build utils))
  356. (mkdir-p (string-append #$output "/bin"))
  357. (symlink #$command
  358. (string-append #$output "/bin/guix"))
  359. (let ((modules (string-append #$output
  360. "/share/guile/site/"
  361. (effective-version)))
  362. (info #$info))
  363. (mkdir-p (dirname modules))
  364. (symlink #$modules modules)
  365. (when info
  366. (symlink #$info
  367. (string-append #$output
  368. "/share/info"))))))))
  369. (define* (compiled-guix source #:key (version %guix-version)
  370. (pull-version 1)
  371. (name (string-append "guix-" version))
  372. (guile-version (effective-version))
  373. (guile-for-build (guile-for-build guile-version))
  374. (libgcrypt (specification->package "libgcrypt"))
  375. (zlib (specification->package "zlib"))
  376. (gzip (specification->package "gzip"))
  377. (bzip2 (specification->package "bzip2"))
  378. (xz (specification->package "xz"))
  379. (guix (specification->package "guix")))
  380. "Return a file-like object that contains a compiled Guix."
  381. (define guile-json
  382. (package-for-guile guile-version
  383. "guile-json"
  384. "guile2.0-json"))
  385. (define guile-ssh
  386. (package-for-guile guile-version
  387. "guile-ssh"
  388. "guile2.0-ssh"))
  389. (define guile-git
  390. (package-for-guile guile-version
  391. "guile-git"
  392. "guile2.0-git"))
  393. (define guile-sqlite3
  394. (package-for-guile guile-version
  395. "guile-sqlite3"
  396. "guile2.0-sqlite3"))
  397. (define dependencies
  398. (match (append-map (lambda (package)
  399. (cons (list "x" package)
  400. (package-transitive-propagated-inputs package)))
  401. (list guile-git guile-json guile-ssh guile-sqlite3))
  402. (((labels packages _ ...) ...)
  403. packages)))
  404. (define *core-modules*
  405. (scheme-node "guix-core"
  406. '((guix)
  407. (guix monad-repl)
  408. (guix packages)
  409. (guix download)
  410. (guix discovery)
  411. (guix profiles)
  412. (guix build-system gnu)
  413. (guix build-system trivial)
  414. (guix build profiles)
  415. (guix build gnu-build-system))
  416. ;; Provide a dummy (guix config) with the default version
  417. ;; number, storedir, etc. This is so that "guix-core" is the
  418. ;; same across all installations and doesn't need to be
  419. ;; rebuilt when the version changes, which in turn means we
  420. ;; can have substitutes for it.
  421. #:extra-modules
  422. `(((guix config)
  423. => ,(make-config.scm #:libgcrypt
  424. (specification->package
  425. "libgcrypt"))))
  426. ;; (guix man-db) is needed at build-time by (guix profiles)
  427. ;; but we don't need to compile it; not compiling it allows
  428. ;; us to avoid an extra dependency on guile-gdbm-ffi.
  429. #:extra-files
  430. `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))
  431. ("guix/store/schema.sql"
  432. ,(local-file "../guix/store/schema.sql")))
  433. #:guile-for-build guile-for-build))
  434. (define *extra-modules*
  435. (scheme-node "guix-extra"
  436. (filter-map (match-lambda
  437. (('guix 'scripts _ ..1) #f)
  438. (('guix 'man-db) #f)
  439. (name name))
  440. (scheme-modules* source "guix"))
  441. (list *core-modules*)
  442. #:extensions dependencies
  443. #:guile-for-build guile-for-build))
  444. (define *core-package-modules*
  445. (scheme-node "guix-packages-base"
  446. `((gnu packages)
  447. (gnu packages base))
  448. (list *core-modules* *extra-modules*)
  449. #:extensions dependencies
  450. ;; Add all the non-Scheme files here. We must do it here so
  451. ;; that 'search-patches' & co. can find them. Ideally we'd
  452. ;; keep them next to the .scm files that use them but it's
  453. ;; difficult to do (XXX).
  454. #:extra-files
  455. (file-imports source "gnu/packages"
  456. (lambda (file stat)
  457. (and (eq? 'regular (stat:type stat))
  458. (not (string-suffix? ".scm" file))
  459. (not (string-suffix? ".go" file))
  460. (not (string-prefix? ".#" file))
  461. (not (string-suffix? "~" file)))))
  462. #:guile-for-build guile-for-build))
  463. (define *package-modules*
  464. (scheme-node "guix-packages"
  465. (scheme-modules* source "gnu/packages")
  466. (list *core-modules* *extra-modules* *core-package-modules*)
  467. #:extensions dependencies
  468. #:guile-for-build guile-for-build))
  469. (define *system-modules*
  470. (scheme-node "guix-system"
  471. `((gnu system)
  472. (gnu services)
  473. ,@(scheme-modules* source "gnu/system")
  474. ,@(scheme-modules* source "gnu/services"))
  475. (list *core-package-modules* *package-modules*
  476. *extra-modules* *core-modules*)
  477. #:extensions dependencies
  478. #:extra-files
  479. (append (file-imports source "gnu/system/examples"
  480. (const #t))
  481. ;; Build-side code that we don't build. Some of
  482. ;; these depend on guile-rsvg, the Shepherd, etc.
  483. (file-imports source "gnu/build" (const #t)))
  484. #:guile-for-build
  485. guile-for-build))
  486. (define *cli-modules*
  487. (scheme-node "guix-cli"
  488. (scheme-modules* source "/guix/scripts")
  489. (list *core-modules* *extra-modules*
  490. *core-package-modules* *package-modules*
  491. *system-modules*)
  492. #:extensions dependencies
  493. #:guile-for-build guile-for-build))
  494. (define *config*
  495. (scheme-node "guix-config"
  496. '()
  497. #:extra-modules
  498. `(((guix config)
  499. => ,(make-config.scm #:libgcrypt libgcrypt
  500. #:zlib zlib
  501. #:gzip gzip
  502. #:bzip2 bzip2
  503. #:xz xz
  504. #:package-name
  505. %guix-package-name
  506. #:package-version
  507. version
  508. #:bug-report-address
  509. %guix-bug-report-address
  510. #:home-page-url
  511. %guix-home-page-url)))
  512. #:guile-for-build guile-for-build))
  513. (define built-modules
  514. (directory-union (string-append name "-modules")
  515. (append-map (lambda (node)
  516. (list (node-source node)
  517. (node-compiled node)))
  518. ;; Note: *CONFIG* comes first so that it
  519. ;; overrides the (guix config) module that
  520. ;; comes with *CORE-MODULES*.
  521. (list *config*
  522. *cli-modules*
  523. *system-modules*
  524. *package-modules*
  525. *core-package-modules*
  526. *extra-modules*
  527. *core-modules*))
  528. ;; Silently choose the first entry upon collision so that
  529. ;; we choose *CONFIG*.
  530. #:resolve-collision 'first
  531. ;; When we do (add-to-store "utils.scm"), "utils.scm" must
  532. ;; be a regular file, not a symlink. Thus, arrange so that
  533. ;; regular files appear as regular files in the final
  534. ;; output.
  535. #:copy? #t
  536. #:quiet? #t))
  537. ;; Version 0 of 'guix pull' meant we'd just return Scheme modules.
  538. ;; Version 1 is when we return the full package.
  539. (cond ((= 1 pull-version)
  540. ;; The whole package, with a standard file hierarchy.
  541. (let ((command (guix-command built-modules
  542. #:source source
  543. #:dependencies dependencies
  544. #:guile-version guile-version)))
  545. (whole-package name built-modules dependencies
  546. #:command command
  547. #:info (info-manual source)
  548. #:guile-version guile-version)))
  549. ((= 0 pull-version)
  550. ;; Legacy 'guix pull': just return the compiled modules.
  551. built-modules)
  552. (else
  553. ;; Unsupported 'guix pull' version.
  554. #f)))
  555. ;;;
  556. ;;; Generating (guix config).
  557. ;;;
  558. (define %dependency-variables
  559. ;; (guix config) variables corresponding to dependencies.
  560. '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate))
  561. (define %persona-variables
  562. ;; (guix config) variables that define Guix's persona.
  563. '(%guix-package-name
  564. %guix-version
  565. %guix-bug-report-address
  566. %guix-home-page-url))
  567. (define %config-variables
  568. ;; (guix config) variables corresponding to Guix configuration (storedir,
  569. ;; localstatedir, etc.)
  570. (sort (filter pair?
  571. (module-map (lambda (name var)
  572. (and (not (memq name %dependency-variables))
  573. (not (memq name %persona-variables))
  574. (cons name (variable-ref var))))
  575. (resolve-interface '(guix config))))
  576. (lambda (name+value1 name+value2)
  577. (string<? (symbol->string (car name+value1))
  578. (symbol->string (car name+value2))))))
  579. (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2
  580. (package-name "GNU Guix")
  581. (package-version "0")
  582. (bug-report-address "bug-guix@gnu.org")
  583. (home-page-url "https://gnu.org/s/guix"))
  584. ;; Hack so that Geiser is not confused.
  585. (define defmod 'define-module)
  586. (scheme-file "config.scm"
  587. #~(;; The following expressions get spliced.
  588. (#$defmod (guix config)
  589. #:export (%guix-package-name
  590. %guix-version
  591. %guix-bug-report-address
  592. %guix-home-page-url
  593. %libgcrypt
  594. %libz
  595. %gzip
  596. %bzip2
  597. %xz
  598. %nix-instantiate))
  599. #$@(map (match-lambda
  600. ((name . value)
  601. #~(define-public #$name #$value)))
  602. %config-variables)
  603. (define %guix-package-name #$package-name)
  604. (define %guix-version #$package-version)
  605. (define %guix-bug-report-address #$bug-report-address)
  606. (define %guix-home-page-url #$home-page-url)
  607. (define %gzip
  608. #+(and gzip (file-append gzip "/bin/gzip")))
  609. (define %bzip2
  610. #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
  611. (define %xz
  612. #+(and xz (file-append xz "/bin/xz")))
  613. (define %libgcrypt
  614. #+(and libgcrypt
  615. (file-append libgcrypt "/lib/libgcrypt")))
  616. (define %libz
  617. #+(and zlib
  618. (file-append zlib "/lib/libz")))
  619. (define %nix-instantiate ;for (guix import snix)
  620. "nix-instantiate"))
  621. ;; Guile 2.0 *requires* the 'define-module' to be at the
  622. ;; top-level or it 'toplevel-ref' in the resulting .go file are
  623. ;; made relative to a nonexistent anonymous module.
  624. #:splice? #t))
  625. ;;;
  626. ;;; Building.
  627. ;;;
  628. (define (imported-files name files)
  629. ;; This is a non-monadic, simplified version of 'imported-files' from (guix
  630. ;; gexp).
  631. (define same-target?
  632. (match-lambda*
  633. (((file1 . _) (file2 . _))
  634. (string=? file1 file2))))
  635. (define build
  636. (with-imported-modules (source-module-closure
  637. '((guix build utils)))
  638. #~(begin
  639. (use-modules (ice-9 match)
  640. (guix build utils))
  641. (mkdir (ungexp output)) (chdir (ungexp output))
  642. (for-each (match-lambda
  643. ((final-path store-path)
  644. (mkdir-p (dirname final-path))
  645. ;; Note: We need regular files to be regular files, not
  646. ;; symlinks, as this makes a difference for
  647. ;; 'add-to-store'.
  648. (copy-file store-path final-path)))
  649. '#$(delete-duplicates files same-target?)))))
  650. ;; We're just copying files around, no need to substitute or offload it.
  651. (computed-file name build
  652. #:options '(#:local-build? #t
  653. #:substitutable? #f
  654. #:env-vars (("COLUMNS" . "200")))))
  655. (define* (compiled-modules name module-tree module-files
  656. #:optional
  657. (dependencies '())
  658. (dependencies-compiled '())
  659. #:key
  660. (extensions '()) ;full-blown Guile packages
  661. parallel?
  662. guile-for-build)
  663. "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list
  664. like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory
  665. containing MODULE-FILES and possibly other files as well."
  666. ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix
  667. ;; gexp).
  668. (define build
  669. (with-imported-modules (source-module-closure
  670. '((guix build compile)
  671. (guix build utils)))
  672. #~(begin
  673. (use-modules (srfi srfi-26)
  674. (ice-9 match)
  675. (ice-9 format)
  676. (ice-9 threads)
  677. (guix build compile)
  678. (guix build utils))
  679. (define (regular? file)
  680. (not (member file '("." ".."))))
  681. (define (report-load file total completed)
  682. (display #\cr)
  683. (format #t
  684. "loading...\t~5,1f% of ~d files" ;FIXME: i18n
  685. (* 100. (/ completed total)) total)
  686. (force-output))
  687. (define (report-compilation file total completed)
  688. (display #\cr)
  689. (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
  690. (* 100. (/ completed total)) total)
  691. (force-output))
  692. (define (process-directory directory files output)
  693. ;; Hide compilation warnings.
  694. (parameterize ((current-warning-port (%make-void-port "w")))
  695. (compile-files directory #$output files
  696. #:workers (parallel-job-count)
  697. #:report-load report-load
  698. #:report-compilation report-compilation)))
  699. (setvbuf (current-output-port) _IONBF)
  700. (setvbuf (current-error-port) _IONBF)
  701. (set! %load-path (cons #+module-tree %load-path))
  702. (set! %load-path
  703. (append '#+dependencies
  704. (map (lambda (extension)
  705. (string-append extension "/share/guile/site/"
  706. (effective-version)))
  707. '#+extensions)
  708. %load-path))
  709. (set! %load-compiled-path
  710. (append '#+dependencies-compiled
  711. (map (lambda (extension)
  712. (string-append extension "/lib/guile/"
  713. (effective-version)
  714. "/site-ccache"))
  715. '#+extensions)
  716. %load-compiled-path))
  717. ;; Load the compiler modules upfront.
  718. (compile #f)
  719. (mkdir #$output)
  720. (chdir #+module-tree)
  721. (process-directory "." '#+module-files #$output)
  722. (newline))))
  723. (computed-file name build
  724. #:guile guile-for-build
  725. #:options
  726. `(#:local-build? #f ;allow substitutes
  727. ;; Don't annoy people about _IONBF deprecation.
  728. ;; Initialize 'terminal-width' in (system repl debug)
  729. ;; to a large-enough value to make backtrace more
  730. ;; verbose.
  731. #:env-vars (("GUILE_WARN_DEPRECATED" . "no")
  732. ("COLUMNS" . "200")))))
  733. ;;;
  734. ;;; Building.
  735. ;;;
  736. (define (guile-for-build version)
  737. "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
  738. running Guile."
  739. (define canonical-package ;soft reference
  740. (module-ref (resolve-interface '(gnu packages base))
  741. 'canonical-package))
  742. (match version
  743. ("2.2.2"
  744. ;; Gross hack to avoid ABI incompatibilities (see
  745. ;; <https://bugs.gnu.org/29570>.)
  746. (module-ref (resolve-interface '(gnu packages guile))
  747. 'guile-2.2.2))
  748. ("2.2"
  749. (canonical-package (module-ref (resolve-interface '(gnu packages guile))
  750. 'guile-2.2/fixed)))
  751. ("2.0"
  752. (module-ref (resolve-interface '(gnu packages guile))
  753. 'guile-2.0))))
  754. (define* (guix-derivation source version
  755. #:optional (guile-version (effective-version))
  756. #:key (pull-version 0))
  757. "Return, as a monadic value, the derivation to build the Guix from SOURCE
  758. for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies
  759. the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value
  760. is not supported."
  761. (define (shorten version)
  762. (if (and (string-every char-set:hex-digit version)
  763. (> (string-length version) 9))
  764. (string-take version 9) ;Git commit
  765. version))
  766. (define guile
  767. (guile-for-build guile-version))
  768. (mbegin %store-monad
  769. (set-guile-for-build guile)
  770. (let ((guix (compiled-guix source
  771. #:version version
  772. #:name (string-append "guix-"
  773. (shorten version))
  774. #:pull-version pull-version
  775. #:guile-version (match guile-version
  776. ("2.2.2" "2.2")
  777. (version version))
  778. #:guile-for-build guile)))
  779. (if guix
  780. (lower-object guix)
  781. (return #f)))))