;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
;;; Copyright © 2016, 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
;;; 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 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 (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-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)
     (partition (size size)
                (file-system file-system)
                (file-system-options file-system-options)
                (label label)
                (uuid uuid)))))

(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."
  (* 1.25 (file-size root)))

(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 "-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)
  "Handle the creation of VFAT partition images.  See 'make-partition-image'."
  (let ((size (partition-size partition))
        (label (partition-label partition)))
    (invoke "fakeroot" "mkdosfs" "-n" label "-C" target
            "-F" "16" "-S" "1024"
            (size-in-kib
             (if (eq? size 'guess)
                 (estimate-partition-size root)
                 size)))
    (for-each (lambda (file)
                (unless (member file '("." ".."))
                  (invoke "mcopy" "-bsp" "-i" target
                          (string-append root "/" file)
                          (string-append "::" file))))
              (scandir root))))

(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-prefix? "ext" type)
      (make-ext-image partition target root))
     ((string=? type "vfat")
      (make-vfat-image partition target root))
     (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 ((items (call-with-input-file closure read-reference-graph)))
    (parameterize ((sql-schema schema))
      (with-database (store-database-file #:prefix prefix) db
       #:wal-mode? wal-mode?
       (register-items db items
                       #:prefix prefix
                       #:registration-time %epoch)))))

(define* (initialize-efi-partition root
                                   #:key
                                   grub-efi
                                   #:allow-other-keys)
  "Install in ROOT directory, an EFI loader using GRUB-EFI."
  (install-efi-loader grub-efi root))

(define* (initialize-root-partition root
                                    #:key
                                    bootcfg
                                    bootcfg-location
                                    bootloader-package
                                    bootloader-installer
                                    (deduplicate? #t)
                                    references-graphs
                                    (register-closures? #t)
                                    system-directory
                                    make-device-nodes
                                    (wal-mode? #t)
                                    #:allow-other-keys)
  "Initialize the given ROOT directory. Use BOOTCFG and BOOTCFG-LOCATION to
install the bootloader configuration.

If REGISTER-CLOSURES? is true, register REFERENCES-GRAPHS in the store.  If
DEDUPLICATE? is true, then also deduplicate files common to CLOSURES and the
rest of the store when registering the closures.  SYSTEM-DIRECTORY is the name
of the directory of the 'system' derivation.  Pass WAL-MODE? to
register-closure."
  (populate-root-file-system system-directory root)
  (populate-store references-graphs root
                  #:deduplicate? deduplicate?)

  ;; Populate /dev.
  (when make-device-nodes
    (make-device-nodes root))

  (when register-closures?
    (for-each (lambda (closure)
                (register-closure root closure
                                  #:wal-mode? wal-mode?))
              references-graphs))

  (when bootloader-installer
    (display "installing bootloader...\n")
    (bootloader-installer bootloader-package #f root))
  (when bootcfg
    (install-boot-config bootcfg bootcfg-location root)))

(define* (make-iso9660-image xorriso grub-mkrescue-environment
                             grub bootcfg system-directory root target
                             #:key (volume-id "Guix_image") (volume-uuid #f)
                             register-closures? (references-graphs '())
                             (compression? #t))
  "Given a GRUB package, creates an iso image as TARGET, using BOOTCFG as
GRUB configuration and OS-DRV as the stuff in it."
  (define grub-mkrescue
    (string-append grub "/bin/grub-mkrescue"))

  (define grub-mkrescue-sed.sh
    (string-append (getcwd) "/" "grub-mkrescue-sed.sh"))

  ;; Use a modified version of grub-mkrescue-sed.sh, see below.
  (copy-file (string-append xorriso
                            "/bin/grub-mkrescue-sed.sh")
             grub-mkrescue-sed.sh)

  ;; Force grub-mkrescue-sed.sh to use the build directory instead of /tmp
  ;; that is read-only i<tr><td><span title='2021-08-27 10:01:32 +0200'>2021-08-27</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=538376341e9a50ebd350897fe26f43c433f0ee06'>enable whitelisting of `file://' protocol\n\nThis commit additionally also ch...</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-26 11:50:36 +0200'>2021-08-26</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=2875397fb887a5b09b5f39d6b3a75419a516dd07'>improve signing\n\nSignature timestamp is now handled in a saner way. Sha256 ...</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-20 12:57:48 +0200'>2021-08-20</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=d09b7ee10541b5a81430d2e11abb3a9a09643ade'>sanitize `&lt;meta&gt;' tags containing CSP rules under Chromium</a><span class='msg-avail'>...<span class='msg-tooltip'>This commit adds a mechanism of hijacking document when it loads and injecting sanitized nodes to the DOM from the level of content script.
</span></span></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-18 20:54:07 +0200'>2021-08-18</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=3d0efa153c95f3bf4912379f910bc59d0fd563c9'>remove unneeded policy-related cosole messages; restore IceCat 60 compatibility</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-18 17:53:57 +0200'>2021-08-18</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=014f2a2f4e2071c35314d67285711f0f4615266b'>implement smuggling via cookies instead of URL</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-14 10:07:28 +0200'>2021-08-14</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=443bc095a72949adb4a007c9a19a43da7dd8843d'>merge facility to install from Hydrilla</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-14 09:54:03 +0200'>2021-08-14</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=ae1844f9ac935eb3c89314cd402b4ec2c3d0f537'>merge csp-PoC</a></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-06 17:17:45 +0200'>2021-08-06</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=792fbe187bdffca4a748e88d66ea29f8936ae5c8'>Facilitate installation of scripts from the repository</a><span class='msg-avail'>...<span class='msg-tooltip'>This commit includes:
* removal of page_info_server
* running of storage client in popup context
* extraction of some common CSS to a separate file
* extraction of scripts import view to a separate file
* addition of a facility to conveniently clone complex structures from DOM (in DOM_helpers.js)
* addition of hydrilla repo url to default settings
* other minor changes
and of course changes related to the actual installation of scripts from the repo
</span></span></td><td>Wojtek Kosior</td></tr>
<tr><td><span title='2021-08-02 00:00:00 +0000'>2021-08-02</span></td><td><a href='/browser-extension/commit/common/misc.js?h=koszko&amp;id=5b419aedd564e6506aa2fc8bddcaa5d601888f17'>[UNTESTED- will test] Add filtering for http-equiv CSP headers</a></td><td>jahoti</td></tr>
ot (char=? #\- value)))
                               (iso9660-uuid->string
                                volume-uuid)))
             '()))))