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.

531 lines
22 KiB

Remove traces of "GuixSD". * gnu/bootloader/extlinux.scm (extlinux-configuration-file): Remove mentions of "GuixSD". * gnu/bootloader/grub.scm (install-grub-efi): Likewise. * gnu/build/vm.scm (make-iso9660-image): Change default #:volume-id to "Guix_image". (initialize-hard-disk): Search for the "Guix_image" label. * gnu/ci.scm (system-test-jobs, tarball-jobs): Remove "GuixSD". * gnu/installer/newt/welcome.scm (run-welcome-page): Likewise. * gnu/packages/audio.scm (supercollider)[description]: Likewise. * gnu/packages/curl.scm (curl): Likewise. * gnu/packages/emacs.scm (emacs): Likewise. * gnu/packages/gnome.scm (network-manager): Likewise. * gnu/packages/julia.scm (julia): Likewise. * gnu/packages/linux.scm (alsa-plugins): Likewise. (powertop, wireless-regdb): Likewise. * gnu/packages/package-management.scm (guix): Likewise. * gnu/packages/polkit.scm (polkit): Likewise. * gnu/packages/tex.scm (texlive-bin): Likewise. * gnu/services/base.scm (file-systems->fstab): Likewise. * gnu/services/cups.scm (%cups-activation): Likewise. * gnu/services/mail.scm (%dovecot-activation): Likewise. * gnu/services/messaging.scm (prosody-configuration)[log]: Likewise. * gnu/system/examples/vm-image.tmpl (vm-image-motd): Likewise. * gnu/system/install.scm (installation-os)[file-systems]: Change root file system label to "Guix_image". * gnu/system/mapped-devices.scm (check-device-initrd-modules): Remove "GuixSD". * gnu/system/vm.scm (system-docker-image): Likewise. (system-disk-image)[root-label]: Change to "Guix_image". * gnu/tests/install.scm (run-install): Remove "GuixSD". * guix/modules.scm (guix-module-name?): Likewise. * nix/libstore/optimise-store.cc: Likewise.
3 years ago
Remove traces of "GuixSD". * gnu/bootloader/extlinux.scm (extlinux-configuration-file): Remove mentions of "GuixSD". * gnu/bootloader/grub.scm (install-grub-efi): Likewise. * gnu/build/vm.scm (make-iso9660-image): Change default #:volume-id to "Guix_image". (initialize-hard-disk): Search for the "Guix_image" label. * gnu/ci.scm (system-test-jobs, tarball-jobs): Remove "GuixSD". * gnu/installer/newt/welcome.scm (run-welcome-page): Likewise. * gnu/packages/audio.scm (supercollider)[description]: Likewise. * gnu/packages/curl.scm (curl): Likewise. * gnu/packages/emacs.scm (emacs): Likewise. * gnu/packages/gnome.scm (network-manager): Likewise. * gnu/packages/julia.scm (julia): Likewise. * gnu/packages/linux.scm (alsa-plugins): Likewise. (powertop, wireless-regdb): Likewise. * gnu/packages/package-management.scm (guix): Likewise. * gnu/packages/polkit.scm (polkit): Likewise. * gnu/packages/tex.scm (texlive-bin): Likewise. * gnu/services/base.scm (file-systems->fstab): Likewise. * gnu/services/cups.scm (%cups-activation): Likewise. * gnu/services/mail.scm (%dovecot-activation): Likewise. * gnu/services/messaging.scm (prosody-configuration)[log]: Likewise. * gnu/system/examples/vm-image.tmpl (vm-image-motd): Likewise. * gnu/system/install.scm (installation-os)[file-systems]: Change root file system label to "Guix_image". * gnu/system/mapped-devices.scm (check-device-initrd-modules): Remove "GuixSD". * gnu/system/vm.scm (system-docker-image): Likewise. (system-disk-image)[root-label]: Change to "Guix_image". * gnu/tests/install.scm (run-install): Remove "GuixSD". * guix/modules.scm (guix-module-name?): Likewise. * nix/libstore/optimise-store.cc: Likewise.
3 years ago
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;; Copyright © 2017 Jan Nieuwenhuizen <janneke@gnu.org>
  4. ;;; Copyright © 2018, 2019 Clément Lassieur <clement@lassieur.org>
  5. ;;;
  6. ;;; This file is part of GNU Guix.
  7. ;;;
  8. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  9. ;;; under the terms of the GNU General Public License as published by
  10. ;;; the Free Software Foundation; either version 3 of the License, or (at
  11. ;;; your option) any later version.
  12. ;;;
  13. ;;; GNU Guix is distributed in the hope that it will be useful, but
  14. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  16. ;;; GNU General Public License for more details.
  17. ;;;
  18. ;;; You should have received a copy of the GNU General Public License
  19. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  20. (define-module (gnu ci)
  21. #:use-module (guix config)
  22. #:use-module (guix store)
  23. #:use-module (guix grafts)
  24. #:use-module (guix profiles)
  25. #:use-module (guix packages)
  26. #:use-module (guix channels)
  27. #:use-module (guix derivations)
  28. #:use-module (guix build-system)
  29. #:use-module (guix monads)
  30. #:use-module (guix gexp)
  31. #:use-module (guix ui)
  32. #:use-module ((guix licenses)
  33. #:select (gpl3+ license? license-name))
  34. #:use-module ((guix utils) #:select (%current-system))
  35. #:use-module ((guix scripts system) #:select (read-operating-system))
  36. #:use-module ((guix scripts pack)
  37. #:select (lookup-compressor self-contained-tarball))
  38. #:use-module (gnu bootloader)
  39. #:use-module (gnu bootloader u-boot)
  40. #:use-module (gnu image)
  41. #:use-module (gnu packages)
  42. #:use-module (gnu packages gcc)
  43. #:use-module (gnu packages base)
  44. #:use-module (gnu packages gawk)
  45. #:use-module (gnu packages guile)
  46. #:use-module (gnu packages gettext)
  47. #:use-module (gnu packages compression)
  48. #:use-module (gnu packages multiprecision)
  49. #:use-module (gnu packages make-bootstrap)
  50. #:use-module (gnu packages package-management)
  51. #:use-module (gnu system)
  52. #:use-module (gnu system image)
  53. #:use-module (gnu system vm)
  54. #:use-module (gnu system install)
  55. #:use-module (gnu system images hurd)
  56. #:use-module (gnu tests)
  57. #:use-module (srfi srfi-1)
  58. #:use-module (srfi srfi-26)
  59. #:use-module (ice-9 match)
  60. #:export (%cross-targets
  61. channel-source->package
  62. hydra-jobs))
  63. ;;; Commentary:
  64. ;;;
  65. ;;; This file defines build jobs for the Hydra and Cuirass continuation
  66. ;;; integration tools.
  67. ;;;
  68. ;;; Code:
  69. (define* (package->alist store package system
  70. #:optional (package-derivation package-derivation))
  71. "Convert PACKAGE to an alist suitable for Hydra."
  72. (parameterize ((%graft? #f))
  73. `((derivation . ,(derivation-file-name
  74. (package-derivation store package system
  75. #:graft? #f)))
  76. (description . ,(package-synopsis package))
  77. (long-description . ,(package-description package))
  78. ;; XXX: Hydra ignores licenses that are not a <license> structure or a
  79. ;; list thereof.
  80. (license . ,(let loop ((license (package-license package)))
  81. (match license
  82. ((? license?)
  83. (license-name license))
  84. ((lst ...)
  85. (map loop license)))))
  86. (home-page . ,(package-home-page package))
  87. (maintainers . ("bug-guix@gnu.org"))
  88. (max-silent-time . ,(or (assoc-ref (package-properties package)
  89. 'max-silent-time)
  90. 3600)) ;1 hour by default
  91. (timeout . ,(or (assoc-ref (package-properties package) 'timeout)
  92. 72000))))) ;20 hours by default
  93. (define (package-job store job-name package system)
  94. "Return a job called JOB-NAME that builds PACKAGE on SYSTEM."
  95. (let ((job-name (symbol-append job-name (string->symbol ".")
  96. (string->symbol system))))
  97. `(,job-name . ,(cut package->alist store package system))))
  98. (define (package-cross-job store job-name package target system)
  99. "Return a job called TARGET.JOB-NAME that cross-builds PACKAGE for TARGET on
  100. SYSTEM."
  101. `(,(symbol-append (string->symbol target) (string->symbol ".") job-name
  102. (string->symbol ".") (string->symbol system)) .
  103. ,(cute package->alist store package system
  104. (lambda* (store package system #:key graft?)
  105. (package-cross-derivation store package target system
  106. #:graft? graft?)))))
  107. (define %core-packages
  108. ;; Note: Don't put the '-final' package variants because (1) that's
  109. ;; implicit, and (2) they cannot be cross-built (due to the explicit input
  110. ;; chain.)
  111. (list gcc-4.8 gcc-4.9 gcc-5 glibc binutils
  112. gmp mpfr mpc coreutils findutils diffutils patch sed grep
  113. gawk gnu-gettext hello guile-2.0 guile-2.2 zlib gzip xz
  114. %bootstrap-binaries-tarball
  115. %binutils-bootstrap-tarball
  116. (%glibc-bootstrap-tarball)
  117. %gcc-bootstrap-tarball
  118. %guile-bootstrap-tarball
  119. %bootstrap-tarballs))
  120. (define (packages-to-cross-build target)
  121. "Return the list of packages to cross-build for TARGET."
  122. ;; Don't cross-build the bootstrap tarballs for MinGW.
  123. (if (string-contains target "mingw")
  124. (drop-right %core-packages 6)
  125. %core-packages))
  126. (define %cross-targets
  127. '("mips64el-linux-gnu"
  128. "arm-linux-gnueabihf"
  129. "aarch64-linux-gnu"
  130. "powerpc-linux-gnu"
  131. "riscv64-linux-gnu"
  132. "i586-pc-gnu" ;aka. GNU/Hurd
  133. "i686-w64-mingw32"
  134. "x86_64-w64-mingw32"))
  135. (define (cross-jobs store system)
  136. "Return a list of cross-compilation jobs for SYSTEM."
  137. (define (from-32-to-64? target)
  138. ;; Return true if SYSTEM is 32-bit and TARGET is 64-bit. This hack
  139. ;; prevents known-to-fail cross-builds from i686-linux or armhf-linux to
  140. ;; mips64el-linux-gnuabi64.
  141. (and (or (string-prefix? "i686-" system)
  142. (string-prefix? "i586-" system)
  143. (string-prefix? "armhf-" system))
  144. (string-contains target "64"))) ;x86_64, mips64el, aarch64, etc.
  145. (define (same? target)
  146. ;; Return true if SYSTEM and TARGET are the same thing. This is so we
  147. ;; don't try to cross-compile to 'mips64el-linux-gnu' from
  148. ;; 'mips64el-linux'.
  149. (or (string-contains target system)
  150. (and (string-prefix? "armhf" system) ;armhf-linux
  151. (string-prefix? "arm" target)))) ;arm-linux-gnueabihf
  152. (define (pointless? target)
  153. ;; Return #t if it makes no sense to cross-build to TARGET from SYSTEM.
  154. (match system
  155. ((or "x86_64-linux" "i686-linux")
  156. (if (string-contains target "mingw")
  157. (not (string=? "x86_64-linux" system))
  158. #f))
  159. (_
  160. ;; Don't try to cross-compile from non-Intel platforms: this isn't
  161. ;; very useful and these are often brittle configurations.
  162. #t)))
  163. (define (either proc1 proc2 proc3)
  164. (lambda (x)
  165. (or (proc1 x) (proc2 x) (proc3 x))))
  166. (append-map (lambda (target)
  167. (map (lambda (package)
  168. (package-cross-job store (job-name package)
  169. package target system))
  170. (packages-to-cross-build target)))
  171. (remove (either from-32-to-64? same? pointless?)
  172. %cross-targets)))
  173. ;; Architectures that are able to build or cross-build Guix System images.
  174. ;; This does not mean that other architectures are not supported, only that
  175. ;; they are often not fast enough to support Guix System images building.
  176. (define %guix-system-supported-systems
  177. '("x86_64-linux" "i686-linux"))
  178. (define %guix-system-images
  179. (list hurd-barebones-disk-image))
  180. (define (image-jobs store system)
  181. "Return a list of jobs that build images for SYSTEM."
  182. (define (->alist drv)
  183. `((derivation . ,(derivation-file-name drv))
  184. (description . "Stand-alone image of the GNU system")
  185. (long-description . "This is a demo stand-alone image of the GNU
  186. system.")
  187. (license . ,(license-name gpl3+))
  188. (max-silent-time . 600)
  189. (timeout . 3600)
  190. (home-page . ,%guix-home-page-url)
  191. (maintainers . ("bug-guix@gnu.org"))))
  192. (define (->job name drv)
  193. (let ((name (symbol-append name (string->symbol ".")
  194. (string->symbol system))))
  195. `(,name . ,(lambda ()
  196. (parameterize ((%graft? #f))
  197. (->alist drv))))))
  198. (define (build-image image)
  199. (run-with-store store
  200. (mbegin %store-monad
  201. (set-guile-for-build (default-guile))
  202. (lower-object (system-image image)))))
  203. (define MiB
  204. (expt 2 20))
  205. (if (member system %guix-system-supported-systems)
  206. `(,(->job 'usb-image
  207. (build-image
  208. (image
  209. (inherit efi-disk-image)
  210. (operating-system installation-os))))
  211. ,(->job 'iso9660-image
  212. (build-image
  213. (image
  214. (inherit iso9660-image)
  215. (operating-system installation-os))))
  216. ;; Only cross-compile Guix System images from x86_64-linux for now.
  217. ,@(if (string=? system "x86_64-linux")
  218. (map (lambda (image)
  219. (->job (image-name image) (build-image image)))
  220. %guix-system-images)
  221. '()))
  222. '()))
  223. (define channel-build-system
  224. ;; Build system used to "convert" a channel instance to a package.
  225. (let* ((build (lambda* (store name inputs
  226. #:key source commit system
  227. #:allow-other-keys)
  228. (run-with-store store
  229. ;; SOURCE can be a lowerable object such as <local-file>
  230. ;; or a file name. Adjust accordingly.
  231. (mlet* %store-monad ((source (if (string? source)
  232. (return source)
  233. (lower-object source)))
  234. (instance
  235. -> (checkout->channel-instance
  236. source #:commit commit)))
  237. (channel-instances->derivation (list instance)))
  238. #:system system)))
  239. (lower (lambda* (name #:key system source commit
  240. #:allow-other-keys)
  241. (bag
  242. (name name)
  243. (system system)
  244. (build build)
  245. (arguments `(#:source ,source
  246. #:commit ,commit))))))
  247. (build-system (name 'channel)
  248. (description "Turn a channel instance into a package.")
  249. (lower lower))))
  250. (define* (channel-source->package source #:key commit)
  251. "Return a package for the given channel SOURCE, a lowerable object."
  252. (package
  253. (inherit guix)
  254. (version (string-append (package-version guix) "+"))
  255. (build-system channel-build-system)
  256. (arguments `(#:source ,source
  257. #:commit ,commit))
  258. (inputs '())
  259. (native-inputs '())
  260. (propagated-inputs '())))
  261. (define* (system-test-jobs store system
  262. #:key source commit)
  263. "Return a list of jobs for the system tests."
  264. (define (test->thunk test)
  265. (lambda ()
  266. (define drv
  267. (run-with-store store
  268. (mbegin %store-monad
  269. (set-current-system system)
  270. (set-grafting #f)
  271. (set-guile-for-build (default-guile))
  272. (system-test-value test))))
  273. `((derivation . ,(derivation-file-name drv))
  274. (description . ,(format #f "Guix '~a' system test"
  275. (system-test-name test)))
  276. (long-description . ,(system-test-description test))
  277. (license . ,(license-name gpl3+))
  278. (max-silent-time . 600)
  279. (timeout . 3600)
  280. (home-page . ,%guix-home-page-url)
  281. (maintainers . ("bug-guix@gnu.org")))))
  282. (define (->job test)
  283. (let ((name (string->symbol
  284. (string-append "test." (system-test-name test)
  285. "." system))))
  286. (cons name (test->thunk test))))
  287. (if (member system %guix-system-supported-systems)
  288. ;; Override the value of 'current-guix' used by system tests. Using a
  289. ;; channel instance makes tests that rely on 'current-guix' less
  290. ;; expensive. It also makes sure we get a valid Guix package when this
  291. ;; code is not running from a checkout.
  292. (parameterize ((current-guix-package
  293. (channel-source->package source #:commit commit)))
  294. (map ->job (all-system-tests)))
  295. '()))
  296. (define (tarball-jobs store system)
  297. "Return Hydra jobs to build the self-contained Guix binary tarball."
  298. (define (->alist drv)
  299. `((derivation . ,(derivation-file-name drv))
  300. (description . "Stand-alone binary Guix tarball")
  301. (long-description . "This is a tarball containing binaries of Guix and
  302. all its dependencies, and ready to be installed on \"foreign\" distributions.")
  303. (license . ,(license-name gpl3+))
  304. (home-page . ,%guix-home-page-url)
  305. (maintainers . ("bug-guix@gnu.org"))))
  306. (define (->job name drv)
  307. (let ((name (symbol-append name (string->symbol ".")
  308. (string->symbol system))))
  309. `(,name . ,(lambda ()
  310. (parameterize ((%graft? #f))
  311. (->alist drv))))))
  312. ;; XXX: Add a job for the stable Guix?
  313. (list (->job 'binary-tarball
  314. (run-with-store store
  315. (mbegin %store-monad
  316. (set-guile-for-build (default-guile))
  317. (>>= (profile-derivation (packages->manifest (list guix)))
  318. (lambda (profile)
  319. (self-contained-tarball "guix-binary" profile
  320. #:localstatedir? #t
  321. #:compressor
  322. (lookup-compressor "xz")))))
  323. #:system system))))
  324. (define job-name
  325. ;; Return the name of a package's job.
  326. (compose string->symbol
  327. (cut package-full-name <> "-")))
  328. (define package->job
  329. (let ((base-packages
  330. (delete-duplicates
  331. (append-map (match-lambda
  332. ((_ package _ ...)
  333. (match (package-transitive-inputs package)
  334. (((_ inputs _ ...) ...)
  335. inputs))))
  336. (%final-inputs)))))
  337. (lambda (store package system)
  338. "Return a job for PACKAGE on SYSTEM, or #f if this combination is not
  339. valid."
  340. (cond ((member package base-packages)
  341. (package-job store (symbol-append 'base. (job-name package))
  342. package system))
  343. ((supported-package? package system)
  344. (let ((drv (package-derivation store package system
  345. #:graft? #f)))
  346. (and (substitutable-derivation? drv)
  347. (package-job store (job-name package)
  348. package system))))
  349. (else
  350. #f)))))
  351. (define (all-packages)
  352. "Return the list of packages to build."
  353. (define (adjust package result)
  354. (cond ((package-replacement package)
  355. ;; XXX: If PACKAGE and its replacement have the same name/version,
  356. ;; then both Cuirass jobs will have the same name, which
  357. ;; effectively means that the second one will be ignored. Thus,
  358. ;; return the replacement first.
  359. (cons* (package-replacement package) ;build both
  360. package
  361. result))
  362. ((package-superseded package)
  363. result) ;don't build it
  364. (else
  365. (cons package result))))
  366. (fold-packages adjust
  367. (fold adjust '() ;include base packages
  368. (match (%final-inputs)
  369. (((labels packages _ ...) ...)
  370. packages)))
  371. #:select? (const #t))) ;include hidden packages
  372. (define (arguments->manifests arguments)
  373. "Return the list of manifests extracted from ARGUMENTS."
  374. (map (match-lambda
  375. ((input-name . relative-path)
  376. (let* ((checkout (assq-ref arguments (string->symbol input-name)))
  377. (base (assq-ref checkout 'file-name)))
  378. (in-vicinity base relative-path))))
  379. (assq-ref arguments 'manifests)))
  380. (define (manifests->packages store manifests)
  381. "Return the list of packages found in MANIFESTS."
  382. (define (load-manifest manifest)
  383. (save-module-excursion
  384. (lambda ()
  385. (set-current-module (make-user-module '((guix profiles) (gnu))))
  386. (primitive-load manifest))))
  387. (delete-duplicates!
  388. (map manifest-entry-item
  389. (append-map (compose manifest-entries
  390. load-manifest)
  391. manifests))))
  392. (define (find-current-checkout arguments)
  393. "Find the first checkout of ARGUMENTS that provided the current file.
  394. Return #f if no such checkout is found."
  395. (let ((current-root
  396. (canonicalize-path
  397. (string-append (dirname (current-filename)) "/.."))))
  398. (find (lambda (argument)
  399. (and=> (assq-ref argument 'file-name)
  400. (lambda (name)
  401. (string=? name current-root)))) arguments)))
  402. ;;;
  403. ;;; Hydra entry point.
  404. ;;;
  405. (define (hydra-jobs store arguments)
  406. "Return Hydra jobs."
  407. (define subset
  408. (match (assoc-ref arguments 'subset)
  409. ("core" 'core) ; only build core packages
  410. ("hello" 'hello) ; only build hello
  411. (((? string?) (? string?) ...) 'list) ; only build selected list of packages
  412. ("manifests" 'manifests) ; only build packages in the list of manifests
  413. (_ 'all))) ; build everything
  414. (define systems
  415. (match (assoc-ref arguments 'systems)
  416. (#f %hydra-supported-systems)
  417. ((lst ...) lst)
  418. ((? string? str) (call-with-input-string str read))))
  419. (define checkout
  420. (or (find-current-checkout arguments)
  421. (assq-ref arguments 'superior-guix-checkout)))
  422. (define commit
  423. (assq-ref checkout 'revision))
  424. (define source
  425. (assq-ref checkout 'file-name))
  426. ;; Turn off grafts. Grafting is meant to happen on the user's machines.
  427. (parameterize ((%graft? #f))
  428. ;; Return one job for each package, except bootstrap packages.
  429. (append-map (lambda (system)
  430. (format (current-error-port)
  431. "evaluating for '~a' (heap size: ~a MiB)...~%"
  432. system
  433. (round
  434. (/ (assoc-ref (gc-stats) 'heap-size)
  435. (expt 2. 20))))
  436. (invalidate-derivation-caches!)
  437. (case subset
  438. ((all)
  439. ;; Build everything, including replacements.
  440. (let ((all (all-packages))
  441. (job (lambda (package)
  442. (package->job store package
  443. system))))
  444. (append (filter-map job all)
  445. (image-jobs store system)
  446. (system-test-jobs store system
  447. #:source source
  448. #:commit commit)
  449. (tarball-jobs store system)
  450. (cross-jobs store system))))
  451. ((core)
  452. ;; Build core packages only.
  453. (append (map (lambda (package)
  454. (package-job store (job-name package)
  455. package system))
  456. %core-packages)
  457. (cross-jobs store system)))
  458. ((hello)
  459. ;; Build hello package only.
  460. (if (string=? system (%current-system))
  461. (let ((hello (specification->package "hello")))
  462. (list (package-job store (job-name hello) hello system)))
  463. '()))
  464. ((list)
  465. ;; Build selected list of packages only.
  466. (if (string=? system (%current-system))
  467. (let* ((names (assoc-ref arguments 'subset))
  468. (packages (map specification->package names)))
  469. (map (lambda (package)
  470. (package-job store (job-name package)
  471. package system))
  472. packages))
  473. '()))
  474. ((manifests)
  475. ;; Build packages in the list of manifests.
  476. (let* ((manifests (arguments->manifests arguments))
  477. (packages (manifests->packages store manifests)))
  478. (map (lambda (package)
  479. (package-job store (job-name package)
  480. package system))
  481. packages)))
  482. (else
  483. (error "unknown subset" subset))))
  484. systems)))