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.

625 lines
25 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. compiled-guix
  37. guix-derivation
  38. reload-guix))
  39. ;;;
  40. ;;; Dependency handling.
  41. ;;;
  42. (define* (false-if-wrong-guile package
  43. #:optional (guile-version (effective-version)))
  44. "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g.,
  45. 2.0 instead of 2.2), otherwise return PACKAGE."
  46. (let ((guile (any (match-lambda
  47. ((label (? package? dep) _ ...)
  48. (and (string=? (package-name dep) "guile")
  49. dep)))
  50. (package-direct-inputs package))))
  51. (and (or (not guile)
  52. (string-prefix? guile-version
  53. (package-version guile)))
  54. package)))
  55. (define (package-for-guile guile-version . names)
  56. "Return the package with one of the given NAMES that depends on
  57. GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches."
  58. (let loop ((names names))
  59. (match names
  60. (()
  61. #f)
  62. ((name rest ...)
  63. (match (specification->package name)
  64. (#f
  65. (loop rest))
  66. ((? package? package)
  67. (or (false-if-wrong-guile package guile-version)
  68. (loop rest))))))))
  69. (define specification->package
  70. ;; Use our own variant of that procedure because that of (gnu packages)
  71. ;; would traverse all the .scm files, which is wasteful.
  72. (let ((ref (lambda (module variable)
  73. (module-ref (resolve-interface module) variable))))
  74. (match-lambda
  75. ("guile" (ref '(gnu packages commencement) 'guile-final))
  76. ("guile-json" (ref '(gnu packages guile) 'guile-json))
  77. ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh))
  78. ("guile-git" (ref '(gnu packages guile) 'guile-git))
  79. ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt))
  80. ("zlib" (ref '(gnu packages compression) 'zlib))
  81. ("gzip" (ref '(gnu packages compression) 'gzip))
  82. ("bzip2" (ref '(gnu packages compression) 'bzip2))
  83. ("xz" (ref '(gnu packages compression) 'xz))
  84. ("guix" (ref '(gnu packages package-management)
  85. 'guix-register))
  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. (_ #f)))) ;no such package
  90. ;;;
  91. ;;; Derivations.
  92. ;;;
  93. ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's
  94. ;; easier to express things this way.
  95. (define-record-type <node>
  96. (node name modules source dependencies compiled)
  97. node?
  98. (name node-name) ;string
  99. (modules node-modules) ;list of module names
  100. (source node-source) ;list of source files
  101. (dependencies node-dependencies) ;list of nodes
  102. (compiled node-compiled)) ;node -> lowerable object
  103. (define (node-fold proc init nodes)
  104. (let loop ((nodes nodes)
  105. (visited (setq))
  106. (result init))
  107. (match nodes
  108. (() result)
  109. ((head tail ...)
  110. (if (set-contains? visited head)
  111. (loop tail visited result)
  112. (loop tail (set-insert head visited)
  113. (proc head result)))))))
  114. (define (node-modules/recursive nodes)
  115. (node-fold (lambda (node modules)
  116. (append (node-modules node) modules))
  117. '()
  118. nodes))
  119. (define* (closure modules #:optional (except '()))
  120. (source-module-closure modules
  121. #:select?
  122. (match-lambda
  123. (('guix 'config)
  124. #f)
  125. ((and module
  126. (or ('guix _ ...) ('gnu _ ...)))
  127. (not (member module except)))
  128. (rest #f))))
  129. (define module->import
  130. ;; Return a file-name/file-like object pair for the specified module and
  131. ;; suitable for 'imported-files'.
  132. (match-lambda
  133. ((module '=> thing)
  134. (let ((file (module-name->file-name module)))
  135. (list file thing)))
  136. (module
  137. (let ((file (module-name->file-name module)))
  138. (list file
  139. (local-file (search-path %load-path file)))))))
  140. (define* (scheme-node name modules #:optional (dependencies '())
  141. #:key (extra-modules '()) (extra-files '())
  142. (extensions '())
  143. parallel? guile-for-build)
  144. "Return a node that builds the given Scheme MODULES, and depends on
  145. DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules
  146. added to the source, and EXTRA-FILES is a list of additional files.
  147. EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that
  148. must be present in the search path."
  149. (let* ((modules (append extra-modules
  150. (closure modules
  151. (node-modules/recursive dependencies))))
  152. (module-files (map module->import modules))
  153. (source (imported-files (string-append name "-source")
  154. (append module-files extra-files))))
  155. (node name modules source dependencies
  156. (compiled-modules name source modules
  157. (map node-source dependencies)
  158. (map node-compiled dependencies)
  159. #:extensions extensions
  160. #:parallel? parallel?
  161. #:guile-for-build guile-for-build))))
  162. (define (file-imports directory sub-directory pred)
  163. "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a
  164. list of file-name/file-like objects suitable as inputs to 'imported-files'."
  165. (map (lambda (file)
  166. (list (string-drop file (+ 1 (string-length directory)))
  167. (local-file file #:recursive? #t)))
  168. (find-files (string-append directory "/" sub-directory) pred)))
  169. (define (scheme-modules* directory sub-directory)
  170. "Return the list of module names found under SUB-DIRECTORY in DIRECTORY."
  171. (let ((prefix (string-length directory)))
  172. (map (lambda (file)
  173. (file-name->module-name (string-drop file prefix)))
  174. (scheme-files (string-append directory "/" sub-directory)))))
  175. (define* (compiled-guix source #:key (version %guix-version)
  176. (name (string-append "guix-" version))
  177. (guile-version (effective-version))
  178. (guile-for-build (guile-for-build guile-version))
  179. (libgcrypt (specification->package "libgcrypt"))
  180. (zlib (specification->package "zlib"))
  181. (gzip (specification->package "gzip"))
  182. (bzip2 (specification->package "bzip2"))
  183. (xz (specification->package "xz"))
  184. (guix (specification->package "guix")))
  185. "Return a file-like object that contains a compiled Guix."
  186. (define guile-json
  187. (package-for-guile guile-version
  188. "guile-json"
  189. "guile2.0-json"))
  190. (define guile-ssh
  191. (package-for-guile guile-version
  192. "guile-ssh"
  193. "guile2.0-ssh"))
  194. (define guile-git
  195. (package-for-guile guile-version
  196. "guile-git"
  197. "guile2.0-git"))
  198. (define dependencies
  199. (match (append-map (lambda (package)
  200. (cons (list "x" package)
  201. (package-transitive-propagated-inputs package)))
  202. (list guile-git guile-json guile-ssh))
  203. (((labels packages _ ...) ...)
  204. packages)))
  205. (define *core-modules*
  206. (scheme-node "guix-core"
  207. '((guix)
  208. (guix monad-repl)
  209. (guix packages)
  210. (guix download)
  211. (guix discovery)
  212. (guix profiles)
  213. (guix build-system gnu)
  214. (guix build-system trivial)
  215. (guix build profiles)
  216. (guix build gnu-build-system))
  217. ;; Provide a dummy (guix config) with the default version
  218. ;; number, storedir, etc. This is so that "guix-core" is the
  219. ;; same across all installations and doesn't need to be
  220. ;; rebuilt when the version changes, which in turn means we
  221. ;; can have substitutes for it.
  222. #:extra-modules
  223. `(((guix config)
  224. => ,(make-config.scm #:libgcrypt
  225. (specification->package
  226. "libgcrypt"))))
  227. #:guile-for-build guile-for-build))
  228. (define *extra-modules*
  229. (scheme-node "guix-extra"
  230. (filter-map (match-lambda
  231. (('guix 'scripts _ ..1) #f)
  232. (name name))
  233. (scheme-modules* source "guix"))
  234. (list *core-modules*)
  235. #:extensions dependencies
  236. #:guile-for-build guile-for-build))
  237. (define *core-package-modules*
  238. (scheme-node "guix-packages-base"
  239. `((gnu packages)
  240. (gnu packages base))
  241. (list *core-modules* *extra-modules*)
  242. #:extensions dependencies
  243. ;; Add all the non-Scheme files here. We must do it here so
  244. ;; that 'search-patches' & co. can find them. Ideally we'd
  245. ;; keep them next to the .scm files that use them but it's
  246. ;; difficult to do (XXX).
  247. #:extra-files
  248. (file-imports source "gnu/packages"
  249. (lambda (file stat)
  250. (and (eq? 'regular (stat:type stat))
  251. (not (string-suffix? ".scm" file))
  252. (not (string-suffix? ".go" file))
  253. (not (string-prefix? ".#" file))
  254. (not (string-suffix? "~" file)))))
  255. #:guile-for-build guile-for-build))
  256. (define *package-modules*
  257. (scheme-node "guix-packages"
  258. (scheme-modules* source "gnu/packages")
  259. (list *core-modules* *extra-modules* *core-package-modules*)
  260. #:extensions dependencies
  261. #:guile-for-build guile-for-build))
  262. (define *system-modules*
  263. (scheme-node "guix-system"
  264. `((gnu system)
  265. (gnu services)
  266. ,@(scheme-modules* source "gnu/system")
  267. ,@(scheme-modules* source "gnu/services"))
  268. (list *core-package-modules* *package-modules*
  269. *extra-modules* *core-modules*)
  270. #:extensions dependencies
  271. #:extra-files
  272. (file-imports source "gnu/system/examples" (const #t))
  273. #:guile-for-build
  274. guile-for-build))
  275. (define *cli-modules*
  276. (scheme-node "guix-cli"
  277. (scheme-modules* source "/guix/scripts")
  278. (list *core-modules* *extra-modules*
  279. *core-package-modules* *package-modules*
  280. *system-modules*)
  281. #:extensions dependencies
  282. #:guile-for-build guile-for-build))
  283. (define *config*
  284. (scheme-node "guix-config"
  285. '()
  286. #:extra-modules
  287. `(((guix config)
  288. => ,(make-config.scm #:libgcrypt libgcrypt
  289. #:zlib zlib
  290. #:gzip gzip
  291. #:bzip2 bzip2
  292. #:xz xz
  293. #:guix guix
  294. #:package-name
  295. %guix-package-name
  296. #:package-version
  297. version
  298. #:bug-report-address
  299. %guix-bug-report-address
  300. #:home-page-url
  301. %guix-home-page-url)))
  302. #:guile-for-build guile-for-build))
  303. (directory-union name
  304. (append-map (lambda (node)
  305. (list (node-source node)
  306. (node-compiled node)))
  307. ;; Note: *CONFIG* comes first so that it
  308. ;; overrides the (guix config) module that
  309. ;; comes with *CORE-MODULES*.
  310. (list *config*
  311. *cli-modules*
  312. *system-modules*
  313. *package-modules*
  314. *core-package-modules*
  315. *extra-modules*
  316. *core-modules*))
  317. ;; Silently choose the first entry upon collision so that
  318. ;; we choose *CONFIG*.
  319. #:resolve-collision 'first
  320. ;; When we do (add-to-store "utils.scm"), "utils.scm" must
  321. ;; be a regular file, not a symlink. Thus, arrange so that
  322. ;; regular files appear as regular files in the final
  323. ;; output.
  324. #:copy? #t
  325. #:quiet? #t))
  326. ;;;
  327. ;;; Generating (guix config).
  328. ;;;
  329. (define %dependency-variables
  330. ;; (guix config) variables corresponding to dependencies.
  331. '(%libgcrypt %libz %xz %gzip %bzip2 %nix-instantiate
  332. %sbindir %guix-register-program))
  333. (define %persona-variables
  334. ;; (guix config) variables that define Guix's persona.
  335. '(%guix-package-name
  336. %guix-version
  337. %guix-bug-report-address
  338. %guix-home-page-url))
  339. (define %config-variables
  340. ;; (guix config) variables corresponding to Guix configuration (storedir,
  341. ;; localstatedir, etc.)
  342. (sort (filter pair?
  343. (module-map (lambda (name var)
  344. (and (not (memq name %dependency-variables))
  345. (not (memq name %persona-variables))
  346. (cons name (variable-ref var))))
  347. (resolve-interface '(guix config))))
  348. (lambda (name+value1 name+value2)
  349. (string<? (symbol->string (car name+value1))
  350. (symbol->string (car name+value2))))))
  351. (define* (make-config.scm #:key libgcrypt zlib gzip xz bzip2 guix
  352. (package-name "GNU Guix")
  353. (package-version "0")
  354. (bug-report-address "bug-guix@gnu.org")
  355. (home-page-url "https://gnu.org/s/guix"))
  356. ;; Hack so that Geiser is not confused.
  357. (define defmod 'define-module)
  358. (scheme-file "config.scm"
  359. #~(;; The following expressions get spliced.
  360. (#$defmod (guix config)
  361. #:export (%guix-package-name
  362. %guix-version
  363. %guix-bug-report-address
  364. %guix-home-page-url
  365. %sbindir
  366. %guix-register-program
  367. %libgcrypt
  368. %libz
  369. %gzip
  370. %bzip2
  371. %xz
  372. %nix-instantiate))
  373. #$@(map (match-lambda
  374. ((name . value)
  375. #~(define-public #$name #$value)))
  376. %config-variables)
  377. (define %guix-package-name #$package-name)
  378. (define %guix-version #$package-version)
  379. (define %guix-bug-report-address #$bug-report-address)
  380. (define %guix-home-page-url #$home-page-url)
  381. (define %sbindir
  382. ;; This is used to define '%guix-register-program'.
  383. ;; TODO: Use a derivation that builds nothing but the
  384. ;; C++ part.
  385. #+(and guix (file-append guix "/sbin")))
  386. (define %guix-register-program
  387. (or (getenv "GUIX_REGISTER")
  388. (and %sbindir
  389. (string-append %sbindir "/guix-register"))))
  390. (define %gzip
  391. #+(and gzip (file-append gzip "/bin/gzip")))
  392. (define %bzip2
  393. #+(and bzip2 (file-append bzip2 "/bin/bzip2")))
  394. (define %xz
  395. #+(and xz (file-append xz "/bin/xz")))
  396. (define %libgcrypt
  397. #+(and libgcrypt
  398. (file-append libgcrypt "/lib/libgcrypt")))
  399. (define %libz
  400. #+(and zlib
  401. (file-append zlib "/lib/libz")))
  402. (define %nix-instantiate ;for (guix import snix)
  403. "nix-instantiate"))
  404. ;; Guile 2.0 *requires* the 'define-module' to be at the
  405. ;; top-level or it 'toplevel-ref' in the resulting .go file are
  406. ;; made relative to a nonexistent anonymous module.
  407. #:splice? #t))
  408. ;;;
  409. ;;; Building.
  410. ;;;
  411. (define (imported-files name files)
  412. ;; This is a non-monadic, simplified version of 'imported-files' from (guix
  413. ;; gexp).
  414. (define build
  415. (with-imported-modules (source-module-closure
  416. '((guix build utils)))
  417. #~(begin
  418. (use-modules (ice-9 match)
  419. (guix build utils))
  420. (mkdir (ungexp output)) (chdir (ungexp output))
  421. (for-each (match-lambda
  422. ((final-path store-path)
  423. (mkdir-p (dirname final-path))
  424. ;; Note: We need regular files to be regular files, not
  425. ;; symlinks, as this makes a difference for
  426. ;; 'add-to-store'.
  427. (copy-file store-path final-path)))
  428. '#$files))))
  429. ;; We're just copying files around, no need to substitute or offload it.
  430. (computed-file name build
  431. #:options '(#:local-build? #t
  432. #:substitutable? #f)))
  433. (define* (compiled-modules name module-tree modules
  434. #:optional
  435. (dependencies '())
  436. (dependencies-compiled '())
  437. #:key
  438. (extensions '()) ;full-blown Guile packages
  439. parallel?
  440. guile-for-build)
  441. ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix
  442. ;; gexp).
  443. (define build
  444. (with-imported-modules (source-module-closure
  445. '((guix build compile)
  446. (guix build utils)))
  447. #~(begin
  448. (use-modules (srfi srfi-26)
  449. (ice-9 match)
  450. (ice-9 format)
  451. (ice-9 threads)
  452. (guix build compile)
  453. (guix build utils))
  454. (define (regular? file)
  455. (not (member file '("." ".."))))
  456. (define (report-load file total completed)
  457. (display #\cr)
  458. (format #t
  459. "loading...\t~5,1f% of ~d files" ;FIXME: i18n
  460. (* 100. (/ completed total)) total)
  461. (force-output))
  462. (define (report-compilation file total completed)
  463. (display #\cr)
  464. (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n
  465. (* 100. (/ completed total)) total)
  466. (force-output))
  467. (define (process-directory directory output)
  468. (let ((files (find-files directory "\\.scm$"))
  469. (prefix (+ 1 (string-length directory))))
  470. ;; Hide compilation warnings.
  471. (parameterize ((current-warning-port (%make-void-port "w")))
  472. (compile-files directory #$output
  473. (map (cut string-drop <> prefix) files)
  474. #:workers (parallel-job-count)
  475. #:report-load report-load
  476. #:report-compilation report-compilation))))
  477. (setvbuf (current-output-port) _IONBF)
  478. (setvbuf (current-error-port) _IONBF)
  479. (set! %load-path (cons #+module-tree %load-path))
  480. (set! %load-path
  481. (append '#+dependencies
  482. (map (lambda (extension)
  483. (string-append extension "/share/guile/site/"
  484. (effective-version)))
  485. '#+extensions)
  486. %load-path))
  487. (set! %load-compiled-path
  488. (append '#+dependencies-compiled
  489. (map (lambda (extension)
  490. (string-append extension "/lib/guile/"
  491. (effective-version)
  492. "/site-ccache"))
  493. '#+extensions)
  494. %load-compiled-path))
  495. ;; Load the compiler modules upfront.
  496. (compile #f)
  497. (mkdir #$output)
  498. (chdir #+module-tree)
  499. (process-directory "." #$output)
  500. (newline))))
  501. (computed-file name build
  502. #:guile guile-for-build
  503. #:options
  504. `(#:local-build? #f ;allow substitutes
  505. ;; Don't annoy people about _IONBF deprecation.
  506. #:env-vars (("GUILE_WARN_DEPRECATED" . "no")))))
  507. ;;;
  508. ;;; Building.
  509. ;;;
  510. (define (guile-for-build version)
  511. "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently
  512. running Guile."
  513. (define canonical-package ;soft reference
  514. (module-ref (resolve-interface '(gnu packages base))
  515. 'canonical-package))
  516. (match version
  517. ("2.2.2"
  518. ;; Gross hack to avoid ABI incompatibilities (see
  519. ;; <https://bugs.gnu.org/29570>.)
  520. (module-ref (resolve-interface '(gnu packages guile))
  521. 'guile-2.2.2))
  522. ("2.2"
  523. (canonical-package (module-ref (resolve-interface '(gnu packages guile))
  524. 'guile-2.2/fixed)))
  525. ("2.0"
  526. (module-ref (resolve-interface '(gnu packages guile))
  527. 'guile-2.0))))
  528. (define* (guix-derivation source version
  529. #:optional (guile-version (effective-version)))
  530. "Return, as a monadic value, the derivation to build the Guix from SOURCE
  531. for GUILE-VERSION. Use VERSION as the version string."
  532. (define (shorten version)
  533. (if (and (string-every char-set:hex-digit version)
  534. (> (string-length version) 9))
  535. (string-take version 9) ;Git commit
  536. version))
  537. (define guile
  538. (guile-for-build guile-version))
  539. (mbegin %store-monad
  540. (set-guile-for-build guile)
  541. (lower-object (compiled-guix source
  542. #:version version
  543. #:name (string-append "guix-"
  544. (shorten version))
  545. #:guile-version (match guile-version
  546. ("2.2.2" "2.2")
  547. (version version))
  548. #:guile-for-build guile))))