aboutsummaryrefslogtreecommitdiff
path: root/tests/offload.scm
blob: 5a5de4e8b92d1fb539bdd551701c29ab800e2856 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (tests offload)
  #:use-module (guix scripts offload)
  #:use-module (srfi srfi-64))


(test-begin "offload")

(define-syntax-rule (expose-internal-definitions s1 s2 ...)
  (begin
    (define s1 (@@ (guix scripts offload) s1))
    (define s2 (@@ (guix scripts offload) s2)) ...))

(expose-internal-definitions machine-matches?
                             build-requirements-system
                             build-requirements-features
                             build-machine-system
                             build-machine-systems
                             %build-machine-system
                             %build-machine-systems
                             build-machine-features)

(define (deprecated-build-machine system)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (system system)))

(define (new-build-machine systems)
  (build-machine
   (name "m1")
   (user "dummy")
   (host-key "some-key")
   (systems systems)))

;;; Test that deprecated build-machine definitions still work.
(test-assert (machine-matches? (deprecated-build-machine "i686-linux")
                               (build-requirements
                                (system "i686-linux"))))


(test-assert (machine-matches? (new-build-machine '("i686-linux"))
                               (build-requirements
                                (system "i686-linux"))))

;;; A build machine can act as more than one system type, thanks to QEMU
;;; emulation.
(test-assert (machine-matches? (new-build-machine '("armhf-linux"
                                                    "aarch64-linux"
                                                    "i686-linux"
                                                    "x86_64-linux"))
                               (build-requirements
                                (system "armhf-linux"))))
165' href='#n165'>165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 David Craven <david@craven.ch>
;;; Copyright © 2017, 2020, 2022 Mathieu Othacehe <othacehe@gnu.org>
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu bootloader)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (guix discovery)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix records)
  #:use-module (guix deprecation)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (guix diagnostics)
  #:use-module (guix i18n)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:export (menu-entry
            menu-entry?
            menu-entry-label
            menu-entry-device
            menu-entry-linux
            menu-entry-linux-arguments
            menu-entry-initrd
            menu-entry-device-mount-point
            menu-entry-multiboot-kernel
            menu-entry-multiboot-arguments
            menu-entry-multiboot-modules
            menu-entry-chain-loader

            menu-entry->sexp
            sexp->menu-entry

            bootloader
            bootloader?
            bootloader-name
            bootloader-package
            bootloader-installer
            bootloader-disk-image-installer
            bootloader-configuration-file
            bootloader-configuration-file-generator

            bootloader-configuration
            bootloader-configuration?
            bootloader-configuration-bootloader
            bootloader-configuration-target ;deprecated
            bootloader-configuration-targets
            bootloader-configuration-menu-entries
            bootloader-configuration-default-entry
            bootloader-configuration-timeout
            bootloader-configuration-keyboard-layout
            bootloader-configuration-theme
            bootloader-configuration-terminal-outputs
            bootloader-configuration-terminal-inputs
            bootloader-configuration-serial-unit
            bootloader-configuration-serial-speed
            bootloader-configuration-device-tree-support?
            bootloader-configuration-extra-initrd

            %bootloaders
            lookup-bootloader-by-name

            efi-bootloader-chain))


;;;
;;; Menu-entry record.
;;;

(define-record-type* <menu-entry>
  menu-entry make-menu-entry
  menu-entry?
  (label           menu-entry-label)
  (device          menu-entry-device       ; file system uuid, label, or #f
                   (default #f))
  (device-mount-point menu-entry-device-mount-point
                   (default #f))
  (linux           menu-entry-linux
                   (default #f))
  (linux-arguments menu-entry-linux-arguments
                   (default '()))          ; list of string-valued gexps
  (initrd          menu-entry-initrd       ; file name of the initrd as a gexp
                   (default #f))
  (multiboot-kernel menu-entry-multiboot-kernel
                    (default #f))
  (multiboot-arguments menu-entry-multiboot-arguments
                       (default '()))      ; list of string-valued gexps
  (multiboot-modules menu-entry-multiboot-modules
                     (default '()))        ; list of multiboot commands, where
                                           ; a command is a list of <string>
  (chain-loader     menu-entry-chain-loader
                    (default #f)))         ; string, path of efi file

(define (report-menu-entry-error menu-entry)
  (raise
   (condition
    (&message
     (message
      (format #f (G_ "invalid menu-entry: ~a") menu-entry)))
    (&fix-hint
     (hint
      (G_ "Please chose only one of:
@enumerate
@item direct boot by specifying fields @code{linux},
@code{linux-arguments} and @code{linux-modules},
@item multiboot by specifying fields @code{multiboot-kernel},
@code{multiboot-arguments} and @code{multiboot-modules},
@item chain-loader by specifying field @code{chain-loader}.
@end enumerate"))))))

(define (menu-entry->sexp entry)
  "Return ENTRY serialized as an sexp."
  (define (device->sexp device)
    (match device
      ((? uuid? uuid)
       `(uuid ,(uuid-type uuid) ,(uuid->string uuid)))
      ((? file-system-label? label)
       `(label ,(file-system-label->string label)))
      (_ device)))
  (match entry
    (($ <menu-entry> label device mount-point
                     (? identity linux) linux-arguments (? identity initrd)
                     #f () () #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (linux ,linux)
                  (linux-arguments ,linux-arguments)
                  (initrd ,initrd)))
    (($ <menu-entry> label device mount-point #f () #f
                     (? identity multiboot-kernel) multiboot-arguments
                     multiboot-modules #f)
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (multiboot-kernel ,multiboot-kernel)
                  (multiboot-arguments ,multiboot-arguments)
                  (multiboot-modules ,multiboot-modules)))
    (($ <menu-entry> label device mount-point #f () #f #f () ()
                     (? identity chain-loader))
     `(menu-entry (version 0)
                  (label ,label)
                  (device ,(device->sexp device))
                  (device-mount-point ,mount-point)
                  (chain-loader ,chain-loader)))
    (_ (report-menu-entry-error entry))))

(define (sexp->menu-entry sexp)
  "Turn SEXP, an sexp as returned by 'menu-entry->sexp', into a <menu-entry>
record."
  (define (sexp->device device-sexp)
    (match device-sexp
      (('uuid type uuid-string)
       (uuid uuid-string type))
      (('label label)
       (file-system-label label))
      (_ device-sexp)))
  (match sexp
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('linux linux) ('linux-arguments linux-arguments)
                  ('initrd initrd) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (linux linux)
      (linux-arguments linux-arguments)
      (initrd initrd)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('multiboot-kernel multiboot-kernel)
                  ('multiboot-arguments multiboot-arguments)
                  ('multiboot-modules multiboot-modules) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (multiboot-kernel multiboot-kernel)
      (multiboot-arguments multiboot-arguments)
      (multiboot-modules multiboot-modules)))
    (('menu-entry ('version 0)
                  ('label label) ('device device)
                  ('device-mount-point mount-point)
                  ('chain-loader chain-loader) _ ...)
     (menu-entry
      (label label)
      (device (sexp->device device))
      (device-mount-point mount-point)
      (chain-loader chain-loader)))))


;;;
;;; Bootloader record.
;;;

;; The <bootloader> record contains fields expressing how the bootloader
;; should be installed. Every bootloader in gnu/bootloader/ directory
;; has to be described by this record.

(define-record-type* <bootloader>
  bootloader make-bootloader
  bootloader?
  (name                            bootloader-name)
  (package                         bootloader-package)
  (installer                       bootloader-installer)
  (disk-image-installer            bootloader-disk-image-installer
                                   (default #f))
  (configuration-file              bootloader-configuration-file)
  (configuration-file-generator    bootloader-configuration-file-generator))


;;;
;;; Bootloader configuration record.
;;;

;; The <bootloader-configuration> record contains bootloader independant
;; configuration used to fill bootloader configuration file.

(define-with-syntax-properties (warn-target-field-deprecation
                                (value properties))
  (when value
    (warning (source-properties->location properties)
             (G_ "the 'target' field is deprecated, please use 'targets' \
instead~%")))
  value)

(define-record-type* <bootloader-configuration>
  bootloader-configuration make-bootloader-configuration
  bootloader-configuration?
  (bootloader
   bootloader-configuration-bootloader) ;<bootloader>
  (targets               %bootloader-configuration-targets
                         (default #f))     ;list of strings
  (target                %bootloader-configuration-target ;deprecated
                         (default #f)
                         (sanitize warn-target-field-deprecation))
  (menu-entries          bootloader-configuration-menu-entries
                         (default '()))   ;list of <menu-entry>
  (default-entry         bootloader-configuration-default-entry
                         (default 0))     ;integer
  (timeout               bootloader-configuration-timeout
                         (default 5))     ;seconds as integer
  (keyboard-layout       bootloader-configuration-keyboard-layout
                         (default #f))    ;<keyboard-layout> | #f
  (theme                 bootloader-configuration-theme
                         (default #f))    ;bootloader-specific theme
  (terminal-outputs      bootloader-configuration-terminal-outputs
                         (default '(gfxterm)))   ;list of symbols
  (terminal-inputs       bootloader-configuration-terminal-inputs
                         (default '()))   ;list of symbols
  (serial-unit           bootloader-configuration-serial-unit
                         (default #f))    ;integer | #f
  (serial-speed          bootloader-configuration-serial-speed
                         (default #f))    ;integer | #f
  (device-tree-support?  bootloader-configuration-device-tree-support?
                         (default #t))    ;boolean
  (extra-initrd          bootloader-configuration-extra-initrd
                         (default #f)))   ;string | #f

(define-deprecated (bootloader-configuration-target config)
  bootloader-configuration-targets
  (%bootloader-configuration-target config))

(define (bootloader-configuration-targets config)
  (or (%bootloader-configuration-targets config)
      ;; TODO: Remove after the deprecated 'target' field is removed.
      (list (%bootloader-configuration-target config))
      ;; XXX: At least the GRUB installer (see (gnu bootloader grub)) has this
      ;; peculiar behavior of installing fonts and GRUB modules when DEVICE is #f,
      ;; hence the default value of '(#f) rather than '().
      (list #f)))


;;;
;;; Bootloaders.
;;;

(define (bootloader-modules)
  "Return the list of bootloader modules."
  (all-modules (map (lambda (entry)
                      `(,entry . "gnu/bootloader"))
                    %load-path)
               #:warn warn-about-load-error))

(define %bootloaders
  ;; The list of publically-known bootloaders.
  (delay (fold-module-public-variables (lambda (obj result)
                                         (if (bootloader? obj)
                                             (cons obj result)
                                             result))
                                       '()
                                       (bootloader-modules))))

(define (lookup-bootloader-by-name name)
  "Return the bootloader called NAME."
  (or (find (lambda (bootloader)
              (eq? name (bootloader-name bootloader)))
            (force %bootloaders))
      (leave (G_ "~a: no such bootloader~%") name)))

(define (efi-bootloader-profile packages files hooks)
  "Creates a profile from the lists of PACKAGES and FILES from the store.
This profile is meant to be used by the bootloader-installer.

FILES is a list of file or directory names from the store, which will be
symlinked into the profile.  If a directory name ends with '/', then the
directory content instead of the directory itself will be symlinked into the
profile.

FILES may contain file like objects produced by procedures like plain-file,
local-file, etc., or package contents produced with file-append.

HOOKS lists additional hook functions to modify the profile."
  (define* (efi-bootloader-profile-hook manifest #:optional system)
    (define build
        (with-imported-modules '((guix build utils))
          #~(begin
            (use-modules ((guix build utils)
                          #:select (mkdir-p strip-store-file-name))
                         ((ice-9 ftw)
                          #:select (scandir))
                         ((srfi srfi-1)
                          #:select (append-map every remove))
                         ((srfi srfi-26)
                          #:select (cut)))
            (define (symlink-to file directory transform)
              "Creates a symlink to FILE named (TRANSFORM FILE) in DIRECTORY."
              (symlink file (string-append directory "/" (transform file))))
            (define (directory-content directory)
              "Creates a list of absolute path names inside DIRECTORY."
              (map (lambda (name)
                     (string-append directory name))
                   (or (scandir directory (lambda (name)
                                            (not (member name '("." "..")))))
                       '())))
            (define name-ends-with-/? (cut string-suffix? "/" <>))
            (define (name-is-store-entry? name)
              "Return #t if NAME is a direct store entry and nothing inside."
              (not (string-index (strip-store-file-name name) #\/)))
            (let* ((files '#$files)
                   (directories (filter name-ends-with-/? files))
                   (names-from-directories
                    (append-map (lambda (directory)
                                  (directory-content directory))
                                directories))
                   (names (append names-from-directories
                                  (remove name-ends-with-/? files))))
              (mkdir-p #$output)
              (if (every file-exists? names)
                  (begin
                    (for-each (lambda (name)
                               (symlink-to name #$output
                                            (if (name-is-store-entry? name)
                                                strip-store-file-name
                                                basename)))
                              names)
                    #t)
                  #f)))))

    (gexp->derivation "efi-bootloader-profile"
                      build
                      #:system system
                      #:local-build? #t
                      #:substitutable? #f
                      #:properties
                      `((type . profile-hook)
                        (hook . efi-bootloader-profile-hook))))

  (profile (content (packages->manifest packages))
           (name "efi-bootloader-profile")
           (hooks (cons efi-bootloader-profile-hook hooks))
           (locales? #f)
           (allow-collisions? #f)
           (relative-symlinks? #f)))

(define* (efi-bootloader-chain final-bootloader
                               #:key
                               (packages '())
                               (files '())
                               (hooks '())
                               installer
                               disk-image-installer)
  "Define a chain of bootloaders with the FINAL-BOOTLOADER, optional PACKAGES,
and optional directories and files from the store given in the list of FILES.

The package of the FINAL-BOOTLOADER and all PACKAGES and FILES will be placed
in an efi-bootloader-profile, which will be passed to the INSTALLER.

FILES may contain file-like objects produced by procedures like plain-file,
local-file, etc., or package contents produced with file-append.

If a directory name in FILES ends with '/', then the directory content instead
of the directory itself will be symlinked into the efi-bootloader-profile.

The procedures in the HOOKS list can be used to further modify the bootloader
profile.  It is possible to pass a single function instead of a list.

If the INSTALLER argument is used, then this gexp procedure will be called to
install the efi-bootloader-profile.  Otherwise the installer of the
FINAL-BOOTLOADER will be called.

If the DISK-IMAGE-INSTALLER is used, then this gexp procedure will be called
to install the efi-bootloader-profile into a disk image.  Otherwise the
disk-image-installer of the FINAL-BOOTLOADER will be called."
  (bootloader
    (inherit final-bootloader)
    (name "efi-bootloader-chain")
    (package
     (efi-bootloader-profile (cons (bootloader-package final-bootloader)
                                   packages)
                             files
                             (if (list? hooks)
                                 hooks
                                 (list hooks))))
    (installer
     (or installer
         (bootloader-installer final-bootloader)))
    (disk-image-installer
     (or disk-image-installer
         (bootloader-disk-image-installer final-bootloader)))))