;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@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 (gnu system image)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (guix monads)
  #:use-module (guix records)
  #:use-module (guix store)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module ((guix self) #:select (make-config.scm))
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu image)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system uuid)
  #:use-module (gnu system vm)
  #:use-module (guix packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bootloaders)
  #:use-module (gnu packages cdrom)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages genimage)
  #:use-module (gnu packages guile)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:use-module (gnu packages hurd)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages mtools)
  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 match)
  #:export (esp-partition
            root-partition

            hurd-disk-image
            efi-disk-image
            iso9660-image

            find-image
            system-image))


;;;
;;; Images definitions.
;;;

;; This is the offset before the first partition. GRUB will install itself in
;; this post-MBR gap.
(define root-offset (* 512 2048))

;; Generic root partition label.
(define root-label "Guix_image")

(define esp-partition
  (partition
   (size (* 40 (expt 2 20)))
   (offset root-offset)
   (label "GNU-ESP") ;cosmetic only
   ;; Use "vfat" here since this property is used when mounting.  The actual
   ;; FAT-ness is based on file system size (16 in this case).
   (file-system "vfat")
   (flags '(esp))
   (initializer (gexp initialize-efi-partition))))

(define root-partition
  (partition
   (size 'guess)
   (label root-label)
   (file-system "ext4")
   (flags '(boot))
   (initializer (gexp initialize-root-partition))))

(define hurd-initialize-root-partition
  #~(lambda* (#:rest args)
      (apply initialize-root-partition
             (append args
                     (list #:make-device-nodes
                           make-hurd-device-nodes)))))

(define hurd-disk-image
  (image
   (format 'disk-image)
   (partitions
    (list (partition
           (size 'guess)
           (offset root-offset)
           (label root-label)
           (file-system "ext2")
           (file-system-options '("-o" "hurd" "-O" "ext_attr"))
           (flags '(boot))
           (initializer hurd-initialize-root-partition))))))

(define efi-disk-image
  (image
   (format 'disk-image)
   (partitions (list esp-partition root-partition))))

(define iso9660-image
  (image
   (format 'iso9660)
   (partitions
    (list (partition
           (size 'guess)
           (label "GUIX_IMAGE")
           (flags '(boot)))))
   ;; XXX: Temporarily disable compression to speed-up the tests.
   (compression? #f)))


;;
;; Helpers.
;;

(define not-config?
  ;; Select (guix …) and (gnu …) modules, except (guix config).
  (match-lambda
    (('guix 'config) #f)
    (('guix rest ...) #t)
    (('gnu rest ...) #t)
    (rest #f)))

(define (partition->gexp partition)
  "Turn PARTITION, a <partition> object, into a list-valued gexp suitable for
'make-partition-image'."
  #~'(#$@(list (partition-size partition))
      #$(partition-file-system partition)
      #$(partition-file-system-options partition)
      #$(partition-label partition)