From 0eefcc0bef8fb950611ec5801a9f4d2e256b6b59 Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Mon, 25 May 2020 17:18:23 +0200 Subject: [PATCH] wip: system: Add "--image " support. This allows to run: guix system --list-images to get a list of available system images, and guix system --image hurd-system-image to build one of them. --- gnu/image.scm | 9 +++++ gnu/local.mk | 2 ++ gnu/system/image.scm | 59 ++++++++++++++++++++------------ gnu/system/images/hurd.scm | 70 ++++++++++++++++++++++++++++++++++++++ guix/scripts/system.scm | 56 +++++++++++++++++++++++++----- 5 files changed, 166 insertions(+), 30 deletions(-) create mode 100644 gnu/system/images/hurd.scm diff --git a/gnu/image.scm b/gnu/image.scm index 3a02692950..3a0b8d858b 100644 --- a/gnu/image.scm +++ b/gnu/image.scm @@ -30,8 +30,11 @@ partition-initializer image + image? image-name image-format + image-system + image-target image-size image-operating-system image-partitions @@ -63,7 +66,13 @@ (define-record-type* image make-image image? + (name image-name ;symbol + (default #f)) (format image-format) ;symbol + (system image-system + (default #f)) + (target image-target + (default #f)) (size image-size ;size in bytes as integer (default 'guess)) (operating-system image-operating-system ; diff --git a/gnu/local.mk b/gnu/local.mk index ad740ade82..b72ebede7f 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -627,6 +627,8 @@ GNU_SYSTEM_MODULES = \ %D%/system/uuid.scm \ %D%/system/vm.scm \ \ + %D%/system/images/hurd.scm \ + \ %D%/machine.scm \ %D%/machine/digital-ocean.scm \ %D%/machine/ssh.scm \ diff --git a/gnu/system/image.scm b/gnu/system/image.scm index 328dfe9d2f..0b1708747a 100644 --- a/gnu/system/image.scm +++ b/gnu/system/image.scm @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu system image) + #:use-module (guix discovery) #:use-module (guix gexp) #:use-module (guix modules) #:use-module (guix monads) @@ -52,15 +53,20 @@ #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) - #:export (esp-partition + #:export (root-offset + root-label + + esp-partition root-partition - hurd-disk-image efi-disk-image iso9660-image + system-image + find-image - system-image)) + %images + lookup-image-by-name)) ;;; @@ -89,18 +95,6 @@ (flags '(boot)) (initializer (gexp initialize-root-partition)))) -(define hurd-disk-image - (image - (format 'disk-image) - (partitions - (list (partition - (size 'guess) - (offset root-offset) - (label root-label) - (file-system "ext2") - (flags '(boot)) - (initializer (gexp initialize-root-partition))))))) - (define efi-disk-image (image (format 'disk-image) @@ -556,6 +550,11 @@ image, depending on IMAGE format." #:grub-mkrescue-environment '(("MKRESCUE_SED_MODE" . "mbr_hfs"))))))) + +;; +;; Image detection. +;; + (define (find-image file-system-type) "Find and return an image that could match the given FILE-SYSTEM-TYPE. This is useful to adapt to interfaces written before the addition of the @@ -565,11 +564,29 @@ record." (return (match file-system-type ("iso9660" iso9660-image) - (_ (cond - ((and target - (hurd-triplet? target)) - hurd-disk-image) - (else - efi-disk-image)))))))) + (_ efi-disk-image)))))) + +(define (image-modules) + "Return the list of image modules." + (all-modules (map (lambda (entry) + `(,entry . "gnu/system/images/")) + %load-path) + #:warn warn-about-load-error)) + +(define %images + ;; The list of publically-known images. + (delay (fold-module-public-variables (lambda (obj result) + (if (image? obj) + (cons obj result) + result)) + '() + (image-modules)))) + +(define (lookup-image-by-name name) + "Return the image called NAME." + (or (srfi-1:find (lambda (image) + (eq? name (image-name image))) + (force %images)) + (leave (G_ "~a: no such image~%") name))) ;;; image.scm ends here diff --git a/gnu/system/images/hurd.scm b/gnu/system/images/hurd.scm new file mode 100644 index 0000000000..785dc6428c --- /dev/null +++ b/gnu/system/images/hurd.scm @@ -0,0 +1,70 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2020 Mathieu Othacehe +;;; +;;; 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 . + +(define-module (gnu system images hurd) + #:use-module (guix gexp) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu image) + #:use-module (gnu packages ssh) + #:use-module (gnu services) + #:use-module (gnu services ssh) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system hurd) + #:use-module (gnu system image) + #:export (hurd-barebones-os + hurd-disk-image)) + +(define hurd-barebones-os + (operating-system + (inherit %hurd-default-operating-system) + (bootloader (bootloader-configuration + (bootloader grub-minimal-bootloader) + (target "/dev/sdX"))) + (file-systems (cons (file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext2")) + %base-file-systems)) + (host-name "guixygnu") + (timezone "GNUrope") + (packages (cons openssh %base-packages/hurd)) + (services (cons (service openssh-service-type + (openssh-configuration + (use-pam? #f) + (port-number 2222) + (permit-root-login #t) + (allow-empty-passwords? #t) + (password-authentication? #t))) + %base-services/hurd)))) + +(define hurd-disk-image + (image + (name 'hurd-disk-image) + (format 'disk-image) + (target "i586-pc-gnu") + (operating-system hurd-barebones-os) + (partitions + (list (partition + (size 'guess) + (offset root-offset) + (label root-label) + (file-system "ext2") + (flags '(boot)) + (initializer (gexp initialize-root-partition))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 3d7aa77cb7..14ea1cd000 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -700,6 +700,9 @@ checking this by themselves in their 'check' procedure." (inherit base-image) (size image-size) (operating-system os))))) + ((image) + (lower-object + (system-image base-image))) ((docker-image) (system-docker-image os #:shared-network? container-shared-network?)))) @@ -744,7 +747,7 @@ and TARGET arguments." (set! %load-compiled-path (lowered-gexp-load-compiled-path lowered)) (return (primitive-eval (lowered-gexp-sexp lowered)))))) -(define* (perform-action action os +(define* (perform-action action os image #:key save-provenance? skip-safety-checks? @@ -801,7 +804,7 @@ static checks." (check-initrd-modules os))) (mlet* %store-monad - ((image (find-image file-system-type)) + ((image -> (or image (find-image file-system-type))) (sys (system-derivation-for-action os image action #:file-system-type file-system-type #:image-size image-size @@ -884,6 +887,17 @@ upgrade, and restart each service that was not automatically restarted.\n")))))) #:node-type (shepherd-service-node-type shepherds) #:reverse-edges? #t))) + +;;; +;;; Images. +;;; + +(define (list-images) + "Print the available images" + (display (G_ "The available images are:\n")) + (newline) + (format #t " ~{- ~a ~%~}" (map image-name (force %images)))) + ;;; ;;; Options. @@ -922,6 +936,8 @@ Some ACTIONS support additional ARGS.\n")) disk-image build a disk image, suitable for a USB stick\n")) (display (G_ "\ docker-image build a Docker image\n")) + (display (G_ "\ + image build the specified image\n")) (display (G_ "\ init initialize a root file system to run GNU\n")) (display (G_ "\ @@ -943,6 +959,8 @@ Some ACTIONS support additional ARGS.\n")) --file-system-type=TYPE for 'disk-image', produce a root file system of TYPE (one of 'ext4', 'iso9660')")) + (display (G_ " + --list-images list available images")) (display (G_ " --image-size=SIZE for 'vm-image', produce an image of SIZE")) (display (G_ " @@ -998,6 +1016,10 @@ Some ACTIONS support additional ARGS.\n")) (lambda (opt name arg result) (alist-cons 'file-system-type arg result))) + (option '("list-images") #f #f + (lambda (opt name arg result) + (list-images) + (exit 0))) (option '("image-size") #t #f (lambda (opt name arg result) (alist-cons 'image-size (size->number arg) @@ -1089,9 +1111,21 @@ resulting from command-line parsing." (let* ((file (match args (() #f) ((x . _) x))) + (image (and (eq? action 'image) + (match args + (() #f) + ((name . _) + (lookup-image-by-name + (string->symbol name)))))) (expr (assoc-ref opts 'expression)) - (system (assoc-ref opts 'system)) - (target (assoc-ref opts 'target)) + (system (let ((system (assoc-ref opts 'system))) + (if image + (or (image-system image) system) + system))) + (target (let ((target (assoc-ref opts 'target))) + (if image + (image-target image) + target))) (transform (if save-provenance? (cut operating-system-with-provenance <> file) identity)) @@ -1099,6 +1133,8 @@ resulting from command-line parsing." (ensure-operating-system (or file expr) (cond + (image + (image-operating-system image)) ((and expr file) (leave (G_ "both file and expression cannot be specified~%"))) @@ -1108,7 +1144,8 @@ resulting from command-line parsing." (load* file %user-module #:on-error (assoc-ref opts 'on-error))) (else - (leave (G_ "no configuration specified~%"))))))) + (leave + (G_ "no configuration specified~%"))))))) (dry? (assoc-ref opts 'dry-run?)) (bootloader? (assoc-ref opts 'install-bootloader?)) @@ -1140,7 +1177,7 @@ resulting from command-line parsing." (warn-about-old-distro #:suggested-command "guix system reconfigure")) - (perform-action action os + (perform-action action os image #:dry-run? dry? #:derivations-only? (assoc-ref opts 'derivations-only?) @@ -1229,8 +1266,8 @@ argument list and OPTS is the option alist." (alist-cons 'argument arg result) (let ((action (string->symbol arg))) (case action - ((build container vm vm-image disk-image reconfigure init - extension-graph shepherd-graph + ((build container vm vm-image disk-image image + reconfigure init extension-graph shepherd-graph list-generations describe delete-generations roll-back switch-generation search docker-image) @@ -1262,7 +1299,8 @@ argument list and OPTS is the option alist." (exit 1)) (case action - ((build container vm vm-image disk-image docker-image reconfigure) + ((build container vm vm-image disk-image image docker-image + reconfigure) (unless (or (= count 1) (and expr (= count 0))) (fail))) -- 2.26.2