;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015, 2017, 2019, 2020 Ludovic Courtès ;;; ;;; 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 (test-challenge) #:use-module (guix tests) #:use-module (guix tests http) #:use-module ((gcrypt hash) #:prefix gcrypt:) #:use-module (guix store) #:use-modu
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020, 2022 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2022 Pavel Shlyak <p.shlyak@pantherx.org>
;;; Copyright © 2022 Denis 'GNUtoo' Carikli <GNUtoo@cyberdimension.org>
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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 build image)
  #:use-module (guix build store-copy)
  #:use-module (guix build syscalls)
  #:use-module (guix build utils)
  #:use-module (guix store database)
  #:use-module (guix utils)
  #:use-module (gnu build bootloader)
  #:use-module (gnu build install)
  #:use-module (gnu build linux-boot)
  #:use-module (gnu image)
  #:use-module (gnu system uuid)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-19)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:export (make-partition-image
            convert-disk-image
            genimage
            initialize-efi-partition
            initialize-efi32-partition
            initialize-root-partition

            make-iso9660-image))

(define (sexp->partition sexp)
  "Take SEXP, a tuple as returned by 'partition->gexp', and turn it into a
<partition> record."
  (match sexp
    ((size file-system file-system-options label uuid flags)
     (partition (size size)
                (file-system file-system)
                (file-system-options file-system-options)
                (label label)
                (uuid uuid)
                (flags flags)))))

(define (size-in-kib size)
  "Convert SIZE expressed in bytes, to kilobytes and return it as a string."
  (number->string
   (inexact->exact (ceiling (/ size 1024)))))

(define (estimate-partition-size root)
  "Given the ROOT directory, evaluate and return its size.  As this doesn't
take the partition metadata size into account, take a 25% margin.  As this in
turn doesn't take any constant overhead into account, force a 1-MiB minimum."
  (max (ash 1 20)
       (* 1.25 (file-size root))))

(define* (make-btrfs-image partition target root)
  "Handle the creation of BTRFS partition images. See
'make-partition-image'."
  (let ((size (partition-size partition))
        (fs-options (partition-file-system-options partition))
        (label (partition-label partition))
        (uuid (partition-uuid partition)))
    (apply invoke
           `("fakeroot" "mkfs.btrfs" "-r" ,root
             "-L" ,label
             ,@(if uuid
                   `("-U" ,(uuid->string uuid))
                   '())
             "--shrink"
             ,@fs-options
             ,target))))

(define* (make-ext-image partition target root
                         #:key
                         (owner-uid 0)
                         (owner-gid 0))
  "Handle the creation of EXT2/3/4 partition images. See
'make-partition-image'."
  (let ((size (partition-size partition))
        (fs (partition-file-system partition))
        (fs-options (partition-file-system-options partition))
        (label (partition-label partition))
        (uuid (partition-uuid partition))
        (journal-options "lazy_itable_init=1,lazy_journal_init=1"))
    (apply invoke
           `("fakeroot" "mke2fs" "-t" ,fs "-d" ,root
             "-L" ,label
             ,@(if uuid
                   `("-U" ,(uuid->string uuid))
                   '())
             "-E" ,(format #f "root_owner=~a:~a,~a"
                           owner-uid owner-gid journal-options)
             ,@fs-options
             ,target
             ,(format #f "~ak"
                      (size-in-kib
                       (if (eq? size 'guess)
                           (estimate-partition-size root)
                           size)))))))

(define* (make-vfat-image partition target root fs-bits)
  "Handle the creation of VFAT partition images.  See 'make-partition-image'."
  (let ((size (partition-size partition))
        (label (partition-label partition))
        (flags (partition-flags partition))
        (fs-options (partition-file-system-options partition)))
    (apply invoke "fakeroot" "mkdosfs" "-n" label "-C" target
           "-F" (number->string fs-bits)
           (size-in-kib
            (if (eq? size 'guess)
                (estimate-partition-size root)
                size))
           ;; u-boot in particular needs the formatted block
           ;; size and the physical block size to be equal.
           ;; TODO: What about 4k blocks?
           (if (and (member 'esp flags)
                    (not (member "-S" fs-options)))
               (append (list "-S" "512") fs-options)
               fs-options))
    (for-each (lambda (file)
                (unless (member file '("." ".."))
                  (invoke "mcopy" "-bsp" "-i" target
                          (string-append root "/" file)
                          (string-append "::" file))))
              (scandir root))))

(define* (make-unformatted-image partition target)
  "Make an unformatted partition of a certain size."
  (let ((size (partition-size partition)))
    ;; Create the file and then truncate it to the desired size.
    (with-output-to-file target
      (lambda _ (display "")))
    (truncate-file target size)))

(define* (make-partition-image partition-sexp target root)
  "Create and return the image of PARTITION-SEXP as TARGET.  Use the given
ROOT directory to populate the image."
  (let* ((partition (sexp->partition partition-sexp))
         (type (partition-file-system partition)))
    (cond
     ((string=? "btrfs" type)
      (make-btrfs-image partition target root))
     ((string-prefix? "ext" type)
      (make-ext-image partition target root))
     ((or (string=? type "vfat") (string=? type "fat16"))
      (make-vfat-image partition target root 16))
     ((string=? type "fat32")
      (make-vfat-image partition target root 32))
     ((string=? type "unformatted")
      (make-unformatted-image partition target))
     (else
      (raise (condition
              (&message
               (message "unsupported partition type"))))))))

(define (convert-disk-image image format output)
  "Convert IMAGE to OUTPUT according to the given FORMAT."
  (case format
    ((compressed-qcow2)
     (invoke "qemu-img" "convert" "-c" "-f" "raw"
             "-O" "qcow2" image output))
    (else
     (copy-file image output))))

(define* (genimage config)
  "Use genimage to generate in TARGET directory, the image described in the
given CONFIG file."
  ;; genimage needs a 'root' directory.
  (mkdir "root")
  (invoke "genimage" "--config" config))

(define* (register-closure prefix closure
                           #:key
                           (schema (sql-schema))
                           (wal-mode? #t))
  "Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
produced by #:references-graphs.  Pass WAL-MODE? to call-with-database."
  (let (