code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Google LLC
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2020, 2021 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 (gnu system file-systems)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-2)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (guix records)
  #:use-module ((guix diagnostics) #:select (&fix-hint))
  #:use-module (guix i18n)
  #:use-module (gnu system uuid)
  #:re-export (uuid                               ;backward compatibility
               string->uuid
               uuid->string)
  #:export (file-system
            file-system?
            file-system-device
            file-system-device->string
            file-system-title                     ;deprecated
            file-system-mount-point
            file-system-type
            file-system-needed-for-boot?
            file-system-flags
            file-system-options
            file-system-options->alist
            alist->file-system-options

            file-system-mount?
            file-system-mount-may-fail?
            file-system-check?
            file-system-create-mount-point?
            file-system-dependencies
            file-system-location

            file-system-type-predicate
            btrfs-subvolume?
            btrfs-store-subvolume-file-name

            file-system-label
            file-system-label?
            file-system-label->string

            file-system->spec
            spec->file-system
            specification->file-system-mapping

            %pseudo-file-system-types
            %fuse-control-file-system
            %binary-format-file-system
            %debug-file-system
            %efivars-file-system
            %shared-memory-file-system
            %pseudo-terminal-file-system
            %tty-gid
            %immutable-store
            %control-groups
            %elogind-file-systems

            %base-file-systems
            %container-file-systems

            <file-system-mapping>
            file-system-mapping
            file-system-mapping?
            file-system-mapping-source
            file-system-mapping-target
            file-system-mapping-writable?

            file-system-mapping->bind-mount

            %store-mapping
            %network-configuration-files
            %network-file-mappings))

;;; Commentary:
;;;
;;; Declaring file systems to be mounted.
;;;
;;; Note: this file system is used both in the Shepherd and on the "host
;;; side", so it must not include (gnu packages …) modules.
;;;
;;; Code:

;; File system declaration.
(define-record-type* <file-system> %file-system
  make-file-system
  file-system?
  (device           file-system-device) ; string | <uuid> | <file-system-label>
  (mount-point      file-system-mount-point)      ; string
  (type             file-system-type)             ; string
  (flags            file-system-flags             ; list of symbols
                    (default '()))
  (options          file-system-options           ; string or #f
                    (default #f))
  (mount?           file-system-mount?            ; Boolean
                    (default #t))
  (mount-may-fail?  file-system-mount-may-fail?   ; Boolean
                    (default #f))
  (needed-for-boot? %file-system-needed-for-boot? ; Boolean
                    (default #f))
  (check?           file-system-check?            ; Boolean
                    (default #t))
  (create-mount-point? file-system-create-mount-point? ; Boolean
                       (default #f))
  (dependencies     file-system-dependencies      ; list of <file-system>
                    (default '()))                ; or <mapped-device>
  (location         file-system-location
                    (default (current-source-location))
                    (innate)))

;; A file system label for use in the 'device' field.
(define-record-type <file-system-label>
  (file-system-label label)
  file-system-label?
  (label file-system-label->string))

(set-record-type-printer! <file-system-label>
                          (lambda (obj port)
                            (format port "#<file-system-label ~s>"
                                    (file-system-label->string obj))))

(define-syntax report-deprecation
  (lambda (s)
    "Report the use of the now-deprecated 'title' field."
    (syntax-case s ()
      ((_ field)
       (let* ((source (syntax-source #'field))
              (file   (and source (assq-ref source 'filename)))
              (line   (and source
                           (and=> (assq-ref source 'line) 1+)))
              (column (and source (assq-ref source 'column))))
         (format (current-error-port)
                 "~a:~a:~a: warning: 'title' field is deprecated~%"
                 file line column)
         #t)))))

;; Helper for 'process-file-system-declaration'.
(define-syntax device-expression
  (syntax-rules (quote label uuid device)
    ((_ (quote label) dev)
     (file-system-label dev))
    ((_ (quote uuid) dev)
     (if (uuid? dev) dev (uuid dev)))
    ((_ (quote device) dev)
     dev)
    ((_ title dev)
     (case title
       ((label) (file-system-label dev))
       ((uuid)  (uuid dev))
       (else    dev)))))

;; Helper to interpret the now-deprecated 'title' field.  Detect forms like
;; (title 'label), remove them, and adjust the 'device' field accordingly.
;; TODO: Remove this once 'title' has been deprecated long enough.
(define-syntax process-file-system-declaration
  (syntax-rules (device title)
    ((_ () (rest ...) #f #f)                 ;no 'title' and no 'device' field
     (%file-system rest ...))
    ((_ () (rest ...) dev #f)                     ;no 'title' field
     (%file-system rest ... (device dev)))
    ((_ () (rest ...) dev titl)                   ;got a 'title' field
     (%file-system rest ...
                   (device (device-expression titl dev))))
    ((_ ((title titl) rest ...) (previous ...) dev _)
     (begin
       (report-deprecation (title titl))
       (process-file-system-declaration (rest ...)
                                        (previous ...)
                                        dev titl)))
    ((_ ((device dev) rest ...) (previous ...) _ titl)
     (process-file-system-declaration (rest ...)
                                      (previous ...)
                                      dev titl))
    ((_ (field rest ...) (previous ...) dev titl)
     (process-file-system-declaration (rest ...)
                                      (previous ... field)
                                      dev titl))))

(define-syntax-rule (file-system fields ...)
  (process-file-system-declaration (fields ...) () #f #f))

(define (file-system-title fs)                    ;deprecated
  (match (file-system-device fs)
    ((? file-system-label?) 'label)
    ((? uuid?)              'uuid)
    ((? string?)            'device)))

;; Note: This module is used both on the build side and on the host side.
;; Arrange not to pull (guix store) and (guix config) because the latter
;; differs from user to user.
(define (%store-prefix)
  "Return the store prefix."
  ;; Note: If we have (guix store database) in the search path and we do *not*
  ;; have (guix store) proper, 'resolve-module' returns an empty (guix store)
  ;; with one sub-module.
  (cond ((and=> (resolve-module '(guix store) #:ensure #f)
                (lambda (store)
                  (module-variable store '%store-prefix)))
         =>
         (lambda (variable)
           ((variable-ref variable))))
        ((getenv "NIX_STORE")
         => identity)
        (else
         "/gnu/store")))

(define %not-slash
  (char-set-complement (char-set #\/)))

(define (file-prefix? file1 file2)
  "Return #t if FILE1 denotes the name of a file that is a parent of FILE2.
FILE1 and FILE2 must both be either absolute or relative file names, else #f
is returned.

For example:

  (file-prefix? \"/gnu\" \"/gnu/store\")
  => #t

  (file-prefix? \"/gn\" \"/gnu/store\")
  => #f
"
  (define (absolute? file)
    (string-prefix? "/" file))

  (if (or (every absolute? (list file1 file2))
          (every (negate absolute?) (list file1 file2)))
      (let loop ((file1 (string-tokenize file1 %not-slash))
                 (file2 (string-tokenize file2 %not-slash)))
        (match file1
          (()
           #t)
          ((head1 tail1 ...)
           (match file2
             ((head2 tail2 ...)
              (and (string=? head1 head2) (loop tail1 tail2)))
             (()
              #f)))))
      ;; FILE1 and FILE2 are a mix of absolute and relative file names.
      #f))

(define (file-name-depth file-name)
  (length (string-tokenize file-name %not-slash)))

(define* (file-system-device->string device #:key uuid-type)
  "Return the string representations of the DEVICE field of a <file-system>
record.  When the device is a UUID, its representation is chosen depending on
UUID-TYPE, a symbol such as 'dce or 'iso9660."
  (match device
    ((? file-system-label?)
     (file-system-label->string device))
    ((? uuid?)
     (if uuid-type
         (uuid->string (uuid-bytevector device) uuid-type)
         (uuid->string device)))
    ((? string?)
     device)))

(define (file-system-options->alist string)
  "Translate the option string format of a <file-system> record into an
association list of options or option/value pairs."
  (if string
      (let ((options (string-split string #\,)))
        (map (lambda (param)
               (let ((=index (string-index param #\=)))
                 (if =index
                     (cons (string-take param =index)
                           (string-drop param (1+ =index)))
                     param)))
             options))
      '()))

(define (alist->file-system-options options)
  "Return the string representation of OPTIONS, an association list.  The
string obtained can be used as the option field of a <file-system> record."
  (if (null? options)
      #f
      (string-join (map (match-lambda
                          ((key . value)
                           (string-append key "=" value))
                          (key
                           key))
                        options)
                   ",")))

(define (file-system-needed-for-boot? fs)
  "Return true if FS has the 'needed-for-boot?' flag set, or if it holds the
store--e.g., if FS is the root file system."
  (or (%file-system-needed-for-boot? fs)
      (and (file-prefix? (file-system-mount-point fs) (%store-prefix))
           (not (memq 'bind-mount (file-system-flags fs))))))

(define (file-system->spec fs)
  "Return a list corresponding to file-system FS that can be passed to the
initrd code."
  (match fs
    (($ <file-system> device mount-point type flags options mount?
                      mount-may-fail? needed-for-boot? check?)
     ;; Note: Add new fields towards the end for compatibility.
     (list (cond ((uuid? device)
                  `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
                 ((file-system-label? device)
                  `(file-system-label ,(file-system-label->string device)))
                 (else device))
           mount-point type flags options mount-may-fail? check?))))

(define (spec->file-system sexp)
  "Deserialize SEXP, a list, to the corresponding <file-system> object."
  (match sexp
    ((device mount-point type flags options mount-may-fail? check?
             _ ...)                               ;placeholder for new fields
     (file-system
       (device (match device
                 (('uuid (? symbol? type) (? bytevector? bv))
                  (bytevector->uuid bv type))
                 (('file-system-label (? string? label))
                  (file-system-label label))
                 (_
                  device)))
       (mount-point mount-point) (type type)
       (flags flags) (options options)
       (mount-may-fail? mount-may-fail?)
       (check? check?)))))

(define (specification->file-system-mapping spec writable?)
  "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
a string of the form \"SOURCE\" or \"SOURCE=TARGET\".  The former specifies
that SOURCE from the host should be mounted at SOURCE in the other system.
The latter format specifies that SOURCE from the host should be mounted at
TARGET in the other system."
  (let ((index (string-index spec #\=)))
    (if index
        (file-system-mapping
         (source (substring spec 0 index))
         (target (substring spec (+ 1 index)))
         (writable? writable?))
        (file-system-mapping
         (source spec)
         (target spec)
         (writable? writable?)))))

;;;
;;; Common file systems.
;;;

(define %pseudo-file-system-types
  ;; List of know pseudo file system types.  This is used when validating file
  ;; system definitions.
  '("binfmt_misc" "cgroup" "debugfs" "devpts" "devtmpfs" "efivarfs" "fusectl"
    "hugetlbfs" "overlay" "proc" "securityfs" "sysfs" "tmpfs"))

(define %fuse-control-file-system
  ;; Control file system for Linux' file systems in user-space (FUSE).
  (file-system
    (device "fusectl")
    (mount-point "/sys/fs/fuse/connections")
    (type "fusectl")
    (check? #f)))

(define %binary-format-file-system
  ;; Support for arbitrary executable binary format.
  (file-system
    (device "binfmt_misc")
    (mount-point "/proc/sys/fs/binfmt_misc")
    (type "binfmt_misc")
    (check? #f)))

(define %debug-file-system
  (file-system
    (type "debugfs")
    (device "none")
    (mount-point "/sys/kernel/debug")
    (check? #f)
    (create-mount-point? #t)))

(define %efivars-file-system
  ;; Support for EFI variables file system.
  (file-system
    (device "efivarfs")
    (mount-point "/sys/firmware/efi/efivars")
    (type "efivarfs")
    (mount-may-fail? #t)
    (needed-for-boot? #f)
    (check? #f)))

(define %tty-gid
  ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
  ;; to it from here and from the 'tty' group definitions.
  996)

(define %pseudo-terminal-file-system
  ;; The pseudo-terminal file system.  It needs to be mounted so that
  ;; statfs(2) returns DEVPTS_SUPER_MAGIC like libc's getpt(3) expects (and
  ;; thus openpty(3) and its users, such as xterm.)
  (file-system
    (device "none")
    (mount-point "/dev/pts")
    (type "devpts")
    (check? #f)
    (needed-for-boot? #f)
    (create-mount-point? #t)
    (options (string-append "gid=" (number->string %tty-gid) ",mode=620"))))

(define %shared-memory-file-system
  ;; Shared memory.
  (file-system
    (device "tmpfs")
    (mount-point "/dev/shm")
    (type "tmpfs")
    (check? #f)
    (flags '(no-suid no-dev))
    (options "size=50%")                         ;TODO: make size configurable
    (create-mount-point? #t)))

(define %immutable-store
  ;; Read-only store to avoid users or daemons accidentally modifying it.
  ;; 'guix-daemon' has provisions to remount it read-write in its own name
  ;; space.
  (file-system
    (device (%store-prefix))
    (mount-point (%store-prefix))
    (type "none")
    (check? #f)
    (flags '(read-only bind-mount no-atime))))

(define %control-groups
  (let ((parent (file-system
                  (device "cgroup")
                  (mount-point "/sys/fs/cgroup")
                  (type "tmpfs")
                  (check? #f))))
    (cons parent
          (map (lambda (subsystem)
                 (file-system
                   (device "cgroup")
                   (mount-point (string-append "/sys/fs/cgroup/" subsystem))
                   (type "cgroup")
                   (check? #f)
                   (options subsystem)
                   (create-mount-point? #t)

                   ;; This must be mounted after, and unmounted before the
                   ;; parent directory.
                   (dependencies (list parent))))
               '("cpuset" "cpu" "cpuacct" "memory" "devices" "freezer"
                 "blkio" "perf_event" "pids")))))

(define %elogind-file-systems
  ;; We don't use systemd, but these file systems are needed for elogind,
  ;; which was extracted from systemd.
  (append
   (list (file-system
           (device "none")
           (mount-point "/run/systemd")
           (type "tmpfs")
           (check? #f)
           (flags '(no-suid no-dev no-exec))
           (options "mode=0755")
           (create-mount-point? #t))
         (file-system
           (device "none")
           (mount-point "/run/user")
           (type "tmpfs")
           (check? #f)
           (flags '(no-suid no-dev no-exec))
           (options "mode=0755")
           (create-mount-point? #t))
         ;; Elogind uses cgroups to organize processes, allowing it to map PIDs
         ;; to sessions.  Elogind's cgroup hierarchy isn't associated with any
         ;; resource controller ("subsystem").
         (file-system
           (device "cgroup")
           (mount-point "/sys/fs/cgroup/elogind")
           (type "cgroup")
           (check? #f)
           (options "none,name=elogind")
           (create-mount-point? #t)
           (dependencies (list (car %control-groups)))))
   %control-groups))

(define %base-file-systems
  ;; List of basic file systems to be mounted.  Note that /proc and /sys are
  ;; currently mounted by the initrd.
  (list %pseudo-terminal-file-system
        %debug-file-system
        %shared-memory-file-system
        %efivars-file-system
        %immutable-store))

;; File systems for Linux containers differ from %base-file-systems in that
;; they impose additional restrictions such as no-exec or need different
;; options to function properly.
;;
;; The file system flags and options conform to the libcontainer
;; specification:
;; https://github.com/docker/libcontainer/blob/master/SPEC.md#filesystem
(define %container-file-systems
  (list
   ;; Pseudo-terminal file system.
   (file-system
     (device "none")
     (mount-point "/dev/pts")
     (type "devpts")
     (flags '(no-exec no-suid))
     (needed-for-boot? #t)
     (create-mount-point? #t)
     (check? #f)
     (options "newinstance,ptmxmode=0666,mode=620"))
   ;; Shared memory file system.
   (file-system
     (device "tmpfs")
     (mount-point "/dev/shm")
     (type "tmpfs")
     (flags '(no-exec no-suid no-dev))
     (options "mode=1777,size=65536k")
     (needed-for-boot? #t)
     (create-mount-point? #t)
     (check? #f))
   ;; Message queue file system.
   (file-system
     (device "mqueue")
     (mount-point "/dev/mqueue")
     (type "mqueue")
     (flags '(no-exec no-suid no-dev))
     (needed-for-boot? #t)
     (create-mount-point? #t)
     (check? #f))))

;;;
;;; Shared file systems, for VMs/containers.
;;;

;; Mapping of host file system SOURCE to mount point TARGET in the guest.
(define-record-type* <file-system-mapping> file-system-mapping
  make-file-system-mapping
  file-system-mapping?
  (source    file-system-mapping-source)          ;string
  (target    file-system-mapping-target)          ;string
  (writable? file-system-mapping-writable?        ;Boolean
             (default #f)))

(define (file-system-mapping->bind-mount mapping)
  "Return a file system that realizes MAPPING, a <file-system-mapping>, using
a bind mount."
  (match mapping
    (($ <file-system-mapping> source target writable?)
     (file-system
       (mount-point target)
       (device source)
       (type "none")
       (flags (if writable?
                  '(bind-mount)
                  '(bind-mount read-only)))
       (check? #f)
       (create-mount-point? #t)))))

(define %store-mapping
  ;; Mapping of the host's store into the guest.
  (file-system-mapping
   (source (%store-prefix))
   (target (%store-prefix))
   (writable? #f)))

(define %network-configuration-files
  ;; List of essential network configuration files.
  '("/etc/resolv.conf"
    "/etc/nsswitch.conf"
    "/etc/services"
    "/etc/hosts"))

(define %network-file-mappings
  ;; List of file mappings for essential network files.
  (filter-map (lambda (file)
                (file-system-mapping
                 (source file)
                 (target file)
                 ;; XXX: On some GNU/Linux systems, /etc/resolv.conf is a
                 ;; symlink to a file in a tmpfs which, for an unknown reason,
                 ;; cannot be bind mounted read-only within the container.
                 (writable? (string=? file "/etc/resolv.conf"))))
              %network-configuration-files))

(define (file-system-type-predicate type)
  "Return a predicate that, when passed a file system, returns #t if that file
system has the given TYPE."
  (lambda (fs)
    (string=? (file-system-type fs) type)))

;;;
;;; Btrfs specific helpers.
;;;

(define (btrfs-subvolume? fs)
  "Predicate to check if FS, a file-system object, is a Btrfs subvolume."
  (and-let* ((btrfs-file-system? (string= "btrfs" (file-system-type fs)))
             (option-keys (map (match-lambda
                                 ((key . value) key)
                                 (key key))
                               (file-system-options->alist
                                (file-system-options fs)))))
    (find (cut string-prefix? "subvol" <>) option-keys)))

(define (btrfs-store-subvolume-file-name file-systems)
  "Return the subvolume file name within the Btrfs top level onto which the
store is located, else #f."

  (define (prepend-slash/maybe s)
    (if (string=? "/" (string-take s 1))
        s
        (string-append "/" s)))

  (and-let* ((btrfs-subvolume-fs (filter btrfs-subvolume? file-systems))
             (btrfs-subvolume-fs*
              (sort btrfs-subvolume-fs
                    (lambda (fs1 fs2)
                      (> (file-name-depth (file-system-mount-point fs1))
                         (file-name-depth (file-system-mount-point fs2))))))
             (store-subvolume-fs
              (find (lambda (fs) (file-prefix? (file-system-mount-point fs)
                                               (%store-prefix)))
                    btrfs-subvolume-fs*))
             (options (file-system-options->alist
                       (file-system-options store-subvolume-fs))))
    ;; XXX: Deriving the subvolume name based from a subvolume ID is not
    ;; supported, as we'd need to query the actual file system.
    (or (and=> (assoc-ref options "subvol") prepend-slash/maybe)
        (raise (condition
                (&message
                 (message "The store is on a Btrfs subvolume, but the \
subvolume name is unknown."))
                (&fix-hint
                 (hint
                  (G_ "Use the @code{subvol} Btrfs file system option."))))))))

;;; file-systems.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 hurd)
  #:use-module (guix gexp)
  #:use-module (guix profiles)
  #:use-module (guix utils)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages file)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages guile-xyz)
  #:use-module (gnu packages hurd)
  #:use-module (gnu packages less)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services hurd)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (gnu system shadow)
  #:use-module (gnu system vm)
  #:export (%base-packages/hurd
            %base-services/hurd
            %hurd-default-operating-system
            %hurd-default-operating-system-kernel
            %setuid-programs/hurd))

;;; Commentary:
;;;
;;; This module provides system-specifics for the GNU/Hurd operating system
;;; and virtual machine.
;;;
;;; Code:

(define %hurd-default-operating-system-kernel
  (if (hurd-system?)
      gnumach
      ;; A cross-built GNUmach does not work
      (with-parameters ((%current-system "i686-linux")
                        (%current-target-system #f))
        gnumach)))

(define %base-packages/hurd
  (list hurd bash coreutils file findutils grep sed
        diffutils patch gawk tar gzip bzip2 xz lzip
        guile-3.0-latest guile-colorized guile-readline
        net-base inetutils less shadow shepherd sudo which))

(define %base-services/hurd
  (list (service hurd-console-service-type
                 (hurd-console-configuration (hurd hurd)))
        (service hurd-getty-service-type (hurd-getty-configuration
                                          (tty "tty1")))
        (service hurd-getty-service-type (hurd-getty-configuration
                                          (tty "tty2")))
        (service static-networking-service-type
                 (list (static-networking (interface "lo")
                                          (ip "127.0.0.1")
                                          (requirement '())
                                          (provision '(loopback networking))
                                          (name-servers '("10.0.2.3")))))
        (syslog-service)
        (service guix-service-type
                 (guix-configuration
                  (extra-options '("--disable-chroot"
                                   "--disable-deduplication"))))
        (service special-files-service-type
                 `(("/bin/sh" ,(file-append bash "/bin/sh"))
                   ("/usr/bin/env" ,(file-append coreutils "/bin/env"))))))

(define %setuid-programs/hurd
  ;; Default set of setuid-root programs.
  (list (file-append shadow "/bin/passwd")
        (file-append shadow "/bin/sg")
        (file-append shadow "/bin/su")
        (file-append shadow "/bin/newgrp")
        (file-append shadow "/bin/newuidmap")
        (file-append shadow "/bin/newgidmap")
        (file-append sudo "/bin/sudo")
        (file-append sudo "/bin/sudoedit")))

(define %hurd-default-operating-system
  (operating-system
    (kernel %hurd-default-operating-system-kernel)
    (kernel-arguments '())
    (hurd hurd)
    (bootloader (bootloader-configuration
                 (bootloader grub-minimal-bootloader)
                 (target "/dev/vda")))
    (initrd #f)
    (initrd-modules (lambda _ '()))
    (firmware '())
    (host-name "guixygnu")
    (file-systems '())
    (packages %base-packages/hurd)
    (timezone "GNUrope")
    (name-service-switch #f)
    (essential-services (hurd-default-essential-services this-operating-system))
    (setuid-programs %setuid-programs/hurd)))

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 diagnostics)
  #:use-module (guix discovery)
  #: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 (gnu packages virtualization)
  #:use-module ((srfi srfi-1) #:prefix srfi-1:)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (root-offset
            root-label

            esp-partition
            root-partition

            efi-disk-image
            iso9660-image
            arm32-disk-image
            arm64-disk-image

            image-with-os
            efi-raw-image-type
            qcow2-image-type
            iso-image-type
            uncompressed-iso-image-type
            arm32-image-type
            arm64-image-type

            image-with-label
            system-image

            %image-types
            lookup-image-type-by-name))

;;;
;;; 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 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)))))))

(define* (arm32-disk-image #:optional (offset root-offset))
  (image
   (format 'disk-image)
   (target "arm-linux-gnueabihf")
   (partitions
    (list (partition
           (inherit root-partition)
           (offset offset))))
   ;; FIXME: Deleting and creating "/var/run" and "/tmp" on the overlayfs
   ;; fails.
   (volatile-root? #f)))

(define* (arm64-disk-image #:optional (offset root-offset))
  (image
   (inherit (arm32-disk-image offset))
   (target "aarch64-linux-gnu")))

;;;
;;; Images types.
;;;

(define-syntax-rule (image-with-os base-image os)
  "Return an image inheriting from BASE-IMAGE, with the operating-system field
set to the given OS."
  (image
   (inherit base-image)
   (operating-system os)))

(define efi-raw-image-type
  (image-type
   (name 'efi-raw)
   (constructor (cut image-with-os efi-disk-image <>))))

(define qcow2-image-type
  (image-type
   (name 'qcow2)
   (constructor (cut image-with-os
                 (image
                  (inherit efi-disk-image)
                  (name 'image.qcow2)
                  (format 'compressed-qcow2))
                 <>))))

(define iso-image-type
  (image-type
   (name 'iso9660)
   (constructor (cut image-with-os iso9660-image <>))))

(define uncompressed-iso-image-type
  (image-type
   (name 'uncompressed-iso9660)
   (constructor (cut image-with-os
                 (image
                  (inherit iso9660-image)
                  (compression? #f))
                 <>))))

(define arm32-image-type
  (image-type
   (name 'arm32-raw)
   (constructor (cut image-with-os (arm32-disk-image) <>))))

(define arm64-image-type
  (image-type
   (name 'arm64-raw)
   (constructor (cut image-with-os (arm64-disk-image) <>))))

;;
;; 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)
      #$(and=> (partition-uuid partition)
               uuid-bytevector)))

(define gcrypt-sqlite3&co
  ;; Guile-Gcrypt, Guile-SQLite3, and their propagated inputs.
  (srfi-1:append-map
   (lambda (package)
     (cons package
           (match (package-transitive-propagated-inputs package)
             (((labels packages) ...)
              packages))))
   (list guile-gcrypt guile-sqlite3)))

(define-syntax-rule (with-imported-modules* gexp* ...)
  (with-extensions gcrypt-sqlite3&co
    (with-imported-modules `(,@(source-module-closure
                                '((gnu build vm)
                                  (gnu build image)
                                  (gnu build bootloader)
                                  (gnu build hurd-boot)
                                  (gnu build linux-boot)
                                  (guix store database))
                                #:select? not-config?)
                             ((guix config) => ,(make-config.scm)))
      #~(begin
          (use-modules (gnu build vm)
                       (gnu build image)
                       (gnu build bootloader)
                       (gnu build hurd-boot)
                       (gnu build linux-boot)
                       (guix store database)
                       (guix build utils))
          gexp* ...))))

(define (root-partition? partition)
  "Return true if PARTITION is the root partition, false otherwise."
  (member 'boot (partition-flags partition)))

(define (find-root-partition image)
  "Return the root partition of the given IMAGE."
  (srfi-1:find root-partition? (image-partitions image)))

(define (root-partition-index image)
  "Return the index of the root partition of the given IMAGE."
  (1+ (srfi-1:list-index root-partition? (image-partitions image))))

;;
;; Disk image.
;;

(define* (system-disk-image image
                            #:key
                            (name "disk-image")
                            bootcfg
                            bootloader
                            register-closures?
                            (inputs '()))
  "Return as a file-like object, the disk-image described by IMAGE.  Said
image can be copied on a USB stick as is.  BOOTLOADER is the bootloader that
will be installed and configured according to BOOTCFG parameter.

Raw images of the IMAGE partitions are first created.  Then, genimage is used
to assemble the partition images into a disk-image without resorting to a
virtual machine.

INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
true, register INPUTS in the store database of the image so that Guix can be
used in the image."

  (define genimage-name "image")

  (define (image->genimage-cfg image)
    ;; Return as a file-like object, the genimage configuration file
    ;; describing the given IMAGE.
    (define (format->image-type format)
      ;; Return the genimage format corresponding to FORMAT.  For now, only
      ;; the hdimage format (raw disk-image) is supported.
      (cond
       ((memq format '(disk-image compressed-qcow2)) "hdimage")
        (else
         (raise (condition
                 (&message
                  (message
                   (format #f (G_ "Unsupported image type ~a~%.") format))))))))

    (define (partition->dos-type partition)
      ;; Return the MBR partition type corresponding to the given PARTITION.
      ;; See: https://en.wikipedia.org/wiki/Partition_type.
      (let ((flags (partition-flags partition)))
        (cond
         ((member 'esp flags) "0xEF")
         (else "0x83"))))

    (define (partition-image partition)
      ;; Return as a file-like object, an image of the given PARTITION.  A
      ;; directory, filled by calling the PARTITION initializer procedure, is
      ;; first created within the store.  Then, an image of this directory is
      ;; created using tools such as 'mke2fs' or 'mkdosfs', depending on the
      ;; partition file-system type.
      (let* ((os (image-operating-system image))
             (schema (local-file (search-path %load-path
                                              "guix/store/schema.sql")))
             (graph (match inputs
                      (((names . _) ...)
                       names)))
             (type (partition-file-system partition))
             (image-builder
              (with-imported-modules*
               (let ((initializer #$(partition-initializer partition))
                     (inputs '#+(list e2fsprogs fakeroot dosfstools mtools))
                     (image-root "tmp-root"))
                 (sql-schema #$schema)

                 (set-path-environment-variable "PATH" '("bin" "sbin") inputs)

                 ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be
                 ;; decoded.
                 (setenv "GUIX_LOCPATH"
                         #+(file-append glibc-utf8-locales "/lib/locale"))
                 (setlocale LC_ALL "en_US.utf8")

                 (initializer image-root
                              #:references-graphs '#$graph
                              #:deduplicate? #f
                              #:system-directory #$os
                              #:grub-efi #+grub-efi
                              #:bootloader-package
                              #+(bootloader-package bootloader)
                              #:bootloader-installer
                              #+(bootloader-installer bootloader)
                              #:bootcfg #$bootcfg
                              #:bootcfg-location
                              #$(bootloader-configuration-file bootloader))
                 (make-partition-image #$(partition->gexp partition)
                                       #$output
                                       image-root)))))
        (computed-file "partition.img" image-builder
                       ;; Allow offloading so that this I/O-intensive process
                       ;; doesn't run on the build farm's head node.
                       #:local-build? #f
                       #:options `(#:references-graphs ,inputs))))

    (define (partition->config partition)
      ;; Return the genimage partition configuration for PARTITION.
      (let ((label (partition-label partition))
            (dos-type (partition->dos-type partition))
            (image (partition-image partition))
            (offset (partition-offset partition)))
        #~(format #f "~/partition ~a {
~/~/partition-type = ~a
~/~/image = \"~a\"
~/~/offset = \"~a\"
~/}"
                  #$label
                  #$dos-type
                  #$image
                  #$offset)))

    (let* ((format (image-format image))
           (image-type (format->image-type format))
           (partitions (image-partitions image))
           (partitions-config (map partition->config partitions))
           (builder
            #~(begin
                (let ((format (@ (ice-9 format) format)))
                  (call-with-output-file #$output
                    (lambda (port)
                      (format port
                              "\
image ~a {
~/~a {}
~{~a~^~%~}
}~%" #$genimage-name #$image-type (list #$@partitions-config))))))))
      (computed-file "genimage.cfg" builder)))

  (let* ((image-name (image-name image))
         (name (if image-name
                   (symbol->string image-name)
                   name))
         (format (image-format image))
         (substitutable? (image-substitutable? image))
         (builder
          (with-imported-modules*
           (let ((inputs '#+(list genimage coreutils findutils qemu-minimal))
                 (bootloader-installer
                  #+(bootloader-disk-image-installer bootloader))
                 (out-image (string-append "images/" #$genimage-name)))
             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
             (genimage #$(image->genimage-cfg image))
             ;; Install the bootloader directly on the disk-image.
             (when bootloader-installer
               (bootloader-installer
                #+(bootloader-package bootloader)
                #$(root-partition-index image)
                out-image))
             (convert-disk-image out-image '#$format #$output)))))
    (computed-file name builder
                   #:local-build? #f              ;too I/O-intensive
                   #:options `(#:substitutable? ,substitutable?))))

;;
;; ISO9660 image.
;;

(define (has-guix-service-type? os)
  "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
  (not (not (srfi-1:find (lambda (service)
                           (eq? (service-kind service) guix-service-type))
                         (operating-system-services os)))))

(define* (system-iso9660-image image
                               #:key
                               (name "image.iso")
                               bootcfg
                               bootloader
                               register-closures?
                               (inputs '())
                               (grub-mkrescue-environment '()))
  "Return as a file-like object a bootable, stand-alone iso9660 image.

INPUTS is a list of inputs (as for packages).  When REGISTER-CLOSURES? is
true, register INPUTS in the store database of the image so that Guix can be
used in the image. "
  (define root-label
    (match (image-partitions image)
      ((partition)
       (partition-label partition))))

  (define root-uuid
    (match (image-partitions image)
      ((partition)
       (uuid-bytevector (partition-uuid partition)))))

  (let* ((os (image-operating-system image))
         (bootloader (bootloader-package bootloader))
         (compression? (image-compression? image))
         (substitutable? (image-substitutable? image))
         (schema (local-file (search-path %load-path
                                          "guix/store/schema.sql")))
         (graph (match inputs
                  (((names . _) ...)
                   names)))
         (builder
          (with-imported-modules*
           (let* ((inputs '#$(list parted e2fsprogs dosfstools xorriso
                                   sed grep coreutils findutils gawk))
                  (image-root "tmp-root"))
             (sql-schema #$schema)

             ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
             (setenv "GUIX_LOCPATH"
                     #+(file-append glibc-utf8-locales "/lib/locale"))

             (setlocale LC_ALL "en_US.utf8")

             (set-path-environment-variable "PATH" '("bin" "sbin") inputs)

             (initialize-root-partition image-root
                                        #:references-graphs '#$graph
                                        #:deduplicate? #f
                                        #:system-directory #$os)
             (make-iso9660-image #$xorriso
                                 '#$grub-mkrescue-environment
                                 #$bootloader
                                 #$bootcfg
                                 #$os
                                 image-root
                                 #$output
                                 #:references-graphs '#$graph
                                 #:register-closures? #$register-closures?
                                 #:compression? #$compression?
                                 #:volume-id #$root-label
                                 #:volume-uuid #$root-uuid)))))
    (computed-file name builder
                   ;; Allow offloading so that this I/O-intensive process
                   ;; doesn't run on the build farm's head node.
                   #:local-build? #f
                   #:options `(#:references-graphs ,inputs
                               #:substitutable? ,substitutable?))))

(define (image-with-label base-image label)
  "The volume ID of an ISO is the label of the first partition.  This procedure
returns an image record where the first partition's label is set to <label>."
  (image
    (inherit base-image)
    (partitions
      (match (image-partitions base-image)
        ((boot others ...)
         (cons
           (partition
             (inherit boot)
             (label label))
           others))))))

;;
;; Image creation.
;;

(define (image->root-file-system image)
  "Return the IMAGE root partition file-system type."
  (let ((format (image-format image)))
    (if (eq? format 'iso9660)
        "iso9660"
        (partition-file-system (find-root-partition image)))))

(define (root-size image)
  "Return the root partition size of IMAGE."
  (let* ((image-size (image-size image))
         (root-partition (find-root-partition image))
         (root-size (partition-size root-partition)))
    (cond
     ((and (eq? root-size 'guess) image-size)
      image-size)
     (else root-size))))

(define* (image-with-os* base-image os)
  "Return an image based on BASE-IMAGE but with the operating-system field set
to OS.  Also set the UUID and the size of the root partition."
  (define root-file-system
    (srfi-1:find
     (lambda (fs)
       (string=? (file-system-mount-point fs) "/"))
     (operating-system-file-systems os)))

  (image
   (inherit base-image)
   (operating-system os)
   (partitions
    (map (lambda (p)
           (if (root-partition? p)
               (partition
                (inherit p)
                (uuid (file-system-device root-file-system))
                (size (root-size base-image)))
               p))
         (image-partitions base-image)))))

(define (operating-system-for-image image)
  "Return an operating-system based on the one specified in IMAGE, but
suitable for image creation.  Assign an UUID to the root file-system, so that
it can be used for bootloading."
  (define volatile-root? (if (eq? (image-format image) 'iso9660)
                             #t
                             (image-volatile-root? image)))

  (define (root-uuid os)
    ;; UUID of the root file system, computed in a deterministic fashion.
    ;; This is what we use to locate the root file system so it has to be
    ;; different from the user's own file system UUIDs.
    (let ((type (if (eq? (image-format image) 'iso9660)
                    'iso9660
                    'dce)))
      (operating-system-uuid os type)))

  (let* ((root-file-system-type (image->root-file-system image))
         (base-os (image-operating-system image))
         (file-systems-to-keep
          (srfi-1:remove
           (lambda (fs)
             (let ((mount-point (file-system-mount-point fs)))
               (or (string=? mount-point "/")
                   (string=? mount-point "/boot/efi"))))
           (operating-system-file-systems base-os)))
         (format (image-format image))
         (os
          (operating-system
            (inherit base-os)
            (initrd (lambda (file-systems . rest)
                      (apply (operating-system-initrd base-os)
                             file-systems
                             #:volatile-root? volatile-root?
                             rest)))
            (bootloader (if (eq? format 'iso9660)
                            (bootloader-configuration
                             (inherit
                              (operating-system-bootloader base-os))
                             (bootloader grub-mkrescue-bootloader))
                            (operating-system-bootloader base-os)))
            (file-systems (cons (file-system
                                  (mount-point "/")
                                  (device "/dev/placeholder")
                                  (type root-file-system-type))
                                file-systems-to-keep))))
         (uuid (root-uuid os)))
    (operating-system
      (inherit os)
      (file-systems (cons (file-system
                            (mount-point "/")
                            (device uuid)
                            (type root-file-system-type))
                          file-systems-to-keep)))))

(define* (system-image image)
  "Return the derivation of IMAGE.  It can be a raw disk-image or an ISO9660
image, depending on IMAGE format."
  (define substitutable? (image-substitutable? image))
  (define target (image-target image))

  (with-parameters ((%current-target-system target))
    (let* ((os (operating-system-for-image image))
           (image* (image-with-os* image os))
           (image-format (image-format image))
           (register-closures? (has-guix-service-type? os))
           (bootcfg (operating-system-bootcfg os))
           (bootloader (bootloader-configuration-bootloader
                        (operating-system-bootloader os))))
      (cond
       ((memq image-format '(disk-image compressed-qcow2))
         (system-disk-image image*
                            #:bootcfg bootcfg
                            #:bootloader bootloader
                            #:register-closures? register-closures?
                            #:inputs `(("system" ,os)
                                       ("bootcfg" ,bootcfg))))
       ((memq image-format '(iso9660))
         (system-iso9660-image
          image*
          #:bootcfg bootcfg
          #:bootloader bootloader
          #:register-closures? register-closures?
          #:inputs `(("system" ,os)
                     ("bootcfg" ,bootcfg))
          ;; Make sure to use a mode that does no imply
          ;; HFS+ tree creation that may fail with:
          ;;
          ;; "libisofs: FAILURE : Too much files to mangle,
          ;; cannot guarantee unique file names"
          ;;
          ;; This happens if some limits are exceeded, see:
          ;; https://lists.gnu.org/archive/html/grub-devel/2020-06/msg00048.html
          #:grub-mkrescue-environment
          '(("MKRESCUE_SED_MODE" . "mbr_only"))))))))

;;
;; Image detection.
;;

(define (image-modules)
  "Return the list of image modules."
  (cons (resolve-interface '(gnu system image))
        (all-modules (map (lambda (entry)
                            `(,entry . "gnu/system/images/"))
                          %load-path)
                     #:warn warn-about-load-error)))

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

(define (lookup-image-type-by-name name)
  "Return the image type called NAME."
  (or (srfi-1:find (lambda (image-type)
                     (eq? name (image-type-name image-type)))
                   (force %image-types))
      (raise
       (formatted-message (G_ "~a: no such image type") name))))

;;; image.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 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)
  #:use-module (srfi srfi-26)
  #:export (hurd-barebones-os
            hurd-disk-image
            hurd-image-type
            hurd-qcow2-image-type
            hurd-barebones-disk-image
            hurd-barebones-qcow2-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 "Europe/Amsterdam")
    (packages (cons openssh-sans-x %base-packages/hurd))
    (services (cons (service openssh-service-type
                             (openssh-configuration
                              (openssh openssh-sans-x)
                              (use-pam? #f)
                              (port-number 2222)
                              (permit-root-login #t)
                              (allow-empty-passwords? #t)
                              (password-authentication? #t)))
               %base-services/hurd))))

(define hurd-initialize-root-partition
  #~(lambda* (#:rest args)
      (apply initialize-root-partition
             (append args
                     (list #:make-device-nodes make-hurd-device-nodes
                           ;; XXX Creating a db.sqlite with journal_mode=WAL
                           ;; yields "unable to open database file" on GNU/Hurd
                           ;; for an sqlite with the hurd-locking-mode.patch;
                           ;; see <https://bugs.gnu.org/42151>.
                           #:wal-mode? #f)))))

(define hurd-disk-image
  (image
   (format 'disk-image)
   (target "i586-pc-gnu")
   (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 hurd-image-type
  (image-type
   (name 'hurd-raw)
   (constructor (cut image-with-os hurd-disk-image <>))))

(define hurd-qcow2-image-type
  (image-type
   (name 'hurd-qcow2)
   (constructor (lambda (os)
                  (image
                   (inherit hurd-disk-image)
                   (format 'compressed-qcow2)
                   (operating-system os))))))

(define hurd-barebones-disk-image
  (image
   (inherit
    (os->image hurd-barebones-os #:type hurd-image-type))
   (name 'hurd-barebones-disk-image)))

(define hurd-barebones-qcow2-image
  (image
   (inherit
    (os->image hurd-barebones-os #:type hurd-qcow2-image-type))
   (name 'hurd-barebones.qcow2)))

;; Return the default image.
hurd-barebones-qcow2-image


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;;
;;; 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 images novena)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system image)
  #:use-module (srfi srfi-26)
  #:export (novena-barebones-os
            novena-image-type
            novena-barebones-raw-image))

(define novena-barebones-os
  (operating-system
    (host-name "vignemale")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader u-boot-novena-bootloader)
                 (target "/dev/vda")))
    (initrd-modules '("sdhci-esdhc-imx" "ahci_imx" "i2c-dev"))
    ;(kernel linux-libre-arm-generic)
    (kernel-arguments '("console=ttymxc1,115200"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))))

(define novena-image-type
  (image-type
   (name 'novena-raw)
   (constructor (cut image-with-os (arm32-disk-image) <>))))

(define novena-barebones-raw-image
  (image
   (inherit
    (os->image novena-barebones-os #:type novena-image-type))
   (name 'novena-barebones-raw-image)))

;; Return the default image.
novena-barebones-raw-image


code:
;;; 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 images pine64)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system image)
  #:use-module (srfi srfi-26)
  #:export (pine64-barebones-os
            pine64-image-type
            pine64-barebones-raw-image))

(define pine64-barebones-os
  (operating-system
    (host-name "vignemale")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader u-boot-pine64-lts-bootloader)
                 (target "/dev/vda")))
    (initrd-modules '())
    (kernel linux-libre-arm64-generic)
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (services (cons (service agetty-service-type
                             (agetty-configuration
                              (extra-options '("-L")) ; no carrier detect
                              (baud-rate "115200")
                              (term "vt100")
                              (tty "ttyS0")))
                    %base-services))))

(define pine64-image-type
  (image-type
   (name 'pine64-raw)
   (constructor (cut image-with-os (arm64-disk-image) <>))))

(define pine64-barebones-raw-image
  (image
   (inherit
    (os->image pine64-barebones-os #:type pine64-image-type))
   (name 'pine64-barebones-raw-image)))

;; Return the default image.
pine64-barebones-raw-image


code:
;;; 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 images pinebook-pro)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system image)
  #:use-module (srfi srfi-26)
  #:export (pinebook-pro-barebones-os
            pinebook-pro-image-type
            pinebook-pro-barebones-raw-image))

(define pinebook-pro-barebones-os
  (operating-system
    (host-name "viso")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader u-boot-pinebook-pro-rk3399-bootloader)
                 (target "/dev/vda")))
    (initrd-modules '())
    (kernel linux-libre-arm64-generic)
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (services (cons (service agetty-service-type
                             (agetty-configuration
                              (extra-options '("-L")) ; no carrier detect
                              (baud-rate "115200")
                              (term "vt100")
                              (tty "ttyS2")))
                    %base-services))))

(define pinebook-pro-image-type
  (image-type
   (name 'pinebook-pro-raw)
   (constructor (cut image-with-os
                     (arm64-disk-image (* 9 (expt 2 20))) ;9MiB
                     <>))))

(define pinebook-pro-barebones-raw-image
  (image
   (inherit
    (os->image pinebook-pro-barebones-os #:type pinebook-pro-image-type))
   (name 'pinebook-pro-barebones-raw-image)))

;; Return the default image.
pinebook-pro-barebones-raw-image


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;;
;;; 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 images rock64)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader u-boot)
  #:use-module (gnu image)
  #:use-module (gnu packages linux)
  #:use-module (gnu services)
  #:use-module (gnu services base)
  #:use-module (gnu services networking)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system image)
  #:use-module (srfi srfi-26)
  #:export (rock64-barebones-os
            rock64-image-type
            rock64-barebones-raw-image))

(define rock64-barebones-os
  (operating-system
    (host-name "jiehkkevarri")
    (timezone "Europe/Oslo")
    (locale "en_US.utf8")
    (bootloader (bootloader-configuration
                 (bootloader u-boot-rock64-rk3328-bootloader)
                 (target "/dev/sda")))
    (initrd-modules '())
    (kernel linux-libre-arm64-generic)
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (services (append (list (service dhcp-client-service-type))
                      %base-services))))

(define rock64-image-type
  (image-type
   (name 'rock64-raw)
   (constructor (cut image-with-os (arm64-disk-image (expt 2 24)) <>))))

(define rock64-barebones-raw-image
  (image
   (inherit
    (os->image rock64-barebones-os #:type rock64-image-type))
   (name 'rock64-barebones-raw-image)))

rock64-barebones-raw-image


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017 Marius Bakke <mbakke@fastmail.com>
;;; Copyright © 2017, 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Florian Pelz <pelzflorian@pelzflorian.de>
;;; Copyright © 2020 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 system install)
  #:use-module (gnu)
  #:use-module (gnu system)
  #:use-module (gnu bootloader u-boot)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module ((guix packages) #:select (package-version))
  #:use-module ((guix store) #:select (%store-prefix))
  #:use-module (gnu installer)
  #:use-module (gnu system locale)
  #:use-module (gnu services avahi)
  #:use-module (gnu services dbus)
  #:use-module (gnu services networking)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services ssh)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages bootloaders)
  #:use-module (gnu packages certs)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages fonts)
  #:use-module (gnu packages fontutils)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages xorg)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-26)
  #:export (installation-os
            a20-olinuxino-lime-installation-os
            a20-olinuxino-lime2-emmc-installation-os
            a20-olinuxino-micro-installation-os
            bananapi-m2-ultra-installation-os
            beaglebone-black-installation-os
            mx6cuboxi-installation-os
            nintendo-nes-classic-edition-installation-os
            novena-installation-os
            firefly-rk3399-installation-os
            pine64-plus-installation-os
            pinebook-installation-os
            rock64-installation-os
            rockpro64-installation-os
            rk3399-puma-installation-os
            wandboard-installation-os
            os-with-u-boot))

;;; Commentary:
;;;
;;; This module provides an 'operating-system' definition for use on images
;;; for USB sticks etc., for the installation of the GNU system.
;;;
;;; Code:

;;;
;;; Documentation service.
;;;

(define %installation-node-names
  ;; Translated name of the "System Installation" node of the manual.  Ideally
  ;; we'd extract it from the 'guix-manual' gettext domain, but that one is
  ;; usually not available at run time, hence this hack.
  '(("de" . "Systeminstallation")
    ("en" . "System Installation")
    ("es" . "Instalación del sistema")
    ("fr" . "Installation du système")
    ("ru" . "Установка системы")))

(define (log-to-info tty user)
  "Return a script that spawns the Info reader on the right section of the
manual."
  (program-file "log-to-info"
                #~(let* ((tty      (open-file #$(string-append "/dev/" tty)
                                              "r0+"))
                         (locale   (cadr (command-line)))
                         (language (string-take locale
                                                (string-index locale #\_)))
                         (infodir  "/run/current-system/profile/share/info")
                         (per-lang (string-append infodir "/guix." language
                                                  ".info.gz"))
                         (file     (if (file-exists? per-lang)
                                       per-lang
                                       (string-append infodir "/guix.info")))
                         (node     (or (assoc-ref '#$%installation-node-names
                                                  language)
                                       "System Installation")))
                    (redirect-port tty (current-output-port))
                    (redirect-port tty (current-error-port))
                    (redirect-port tty (current-input-port))

                    (let ((pw (getpwnam #$user)))
                      (setgid (passwd:gid pw))
                      (setuid (passwd:uid pw)))

                    ;; 'gunzip' is needed to decompress the doc.
                    (setenv "PATH" (string-append #$gzip "/bin"))

                    ;; Change this process' locale so that command-line
                    ;; arguments to 'info' are properly encoded.
                    (catch #t
                      (lambda ()
                        (setlocale LC_ALL locale)
                        (setenv "LC_ALL" locale))
                      (lambda _
                        ;; Sometimes LOCALE itself is not available.  In that
                        ;; case pick the one UTF-8 locale that's known to work
                        ;; instead of failing.
                        (setlocale LC_ALL "en_US.utf8")
                        (setenv "LC_ALL" "en_US.utf8")))

                    (execl #$(file-append info-reader "/bin/info")
                           "info" "-d" infodir "-f" file "-n" node))))

(define (documentation-shepherd-service tty)
  (list (shepherd-service
         (provision (list (symbol-append 'term- (string->symbol tty))))
         (requirement '(user-processes host-name udev virtual-terminal))
         (start #~(lambda* (#:optional (locale "en_US.utf8"))
                    (fork+exec-command
                     (list #$(log-to-info tty "documentation") locale)
                     #:environment-variables
                     `("GUIX_LOCPATH=/run/current-system/locale"
                       "TERM=linux"))))
         (stop #~(make-kill-destructor)))))

(define %documentation-users
  ;; User account for the Info viewer.
  (list (user-account (name "documentation")
                      (system? #t)
                      (group "nogroup")
                      (home-directory "/var/empty"))))

(define documentation-service-type
  ;; Documentation viewer service.
  (service-type (name 'documentation)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          documentation-shepherd-service)
                       (service-extension account-service-type
                                          (const %documentation-users))))
                (description "Run the Info reader on a tty.")))

(define %backing-directory
  ;; Sub-directory used as the backing store for copy-on-write.
  "/tmp/guix-inst")

(define cow-store-service-type
  (shepherd-service-type
   'cow-store
   (lambda _
     (define (import-module? module)
       ;; Since we don't use deduplication support in 'populate-store', don't
       ;; import (guix store deduplication) and its dependencies, which
       ;; includes Guile-Gcrypt.
       (and (guix-module-name? module)
            (not (equal? module '(guix store deduplication)))))

     (shepherd-service
      (requirement '(root-file-system user-processes))
      (provision '(cow-store))
      (documentation
       "Make the store copy-on-write, with writes going to \
the given target.")

      ;; This is meant to be explicitly started by the user.
      (auto-start? #f)

      (modules `((gnu build install)
                 ,@%default-modules))
      (start
       (with-imported-modules (source-module-closure
                               '((gnu build install))
                               #:select? import-module?)
         #~(case-lambda
             ((target)
              (mount-cow-store target #$%backing-directory)
              target)
             (else
              ;; Do nothing, and mark the service as stopped.
              #f))))
      (stop #~(lambda (target)
                ;; Delete the temporary directory, but leave everything
                ;; mounted as there may still be processes using it since
                ;; 'user-processes' doesn't depend on us.  The 'user-file-systems'
                ;; service will unmount TARGET eventually.
                (delete-file-recursively
                 (string-append target #$%backing-directory))))))
   (description "Make the store copy-on-write, with writes going to \
the given target.")))

(define (cow-store-service)
  "Return a service that makes the store copy-on-write, such that writes go to
the user's target storage device rather than on the RAM disk."
  ;; See <http://bugs.gnu.org/18061> for the initial report.
  (service cow-store-service-type 'mooooh!))

(define (/etc/configuration-files _)
  "Return a list of tuples representing configuration templates to add to
/etc."
  (define directory
    (computed-file "configuration-templates"
                   (with-imported-modules '((guix build utils))
                     #~(begin
                         (mkdir #$output)
                         (for-each (lambda (file target)
                                     (copy-file file
                                                (string-append #$output "/"
                                                               target)))
                                   '(#$(local-file "examples/bare-bones.tmpl")
                                     #$(local-file "examples/beaglebone-black.tmpl")
                                     #$(local-file "examples/desktop.tmpl")
                                     #$(local-file "examples/lightweight-desktop.tmpl"))
                                   '("bare-bones.scm"
                                     "beaglebone-black.scm"
                                     "desktop.scm"
                                     "lightweight-desktop.scm"))
                         #t))))

  `(("configuration" ,directory)))

(define configuration-template-service-type
  (service-type (name 'configuration-template)
                (extensions
                 (list (service-extension etc-service-type
                                          /etc/configuration-files)))))

(define %configuration-template-service
  (service configuration-template-service-type #t))

(define %nscd-minimal-caches
  ;; Minimal in-memory caching policy for nscd.
  (list (nscd-cache (database 'hosts)
                    (positive-time-to-live (* 3600 12))

                    ;; Do not cache lookup failures at all since they are
                    ;; quite likely (for instance when someone tries to ping a
                    ;; host before networking is functional.)
                    (negative-time-to-live 0)

                    (persistent? #f)
                    (max-database-size (* 5 (expt 2 20)))))) ;5 MiB

;; These define a service to load the uvesafb kernel module with the
;; appropriate options.  The GUI installer needs it when the machine does not
;; support Kernel Mode Setting.  Otherwise kmscon is missing /dev/fb0.
(define (uvesafb-shepherd-service _)
  (list (shepherd-service
         (documentation "Load the uvesafb kernel module if needed.")
         (provision '(maybe-uvesafb))
         (requirement '(file-systems))
         (start #~(lambda ()
                    ;; uvesafb is only supported on x86 and x86_64.
                    (or (not (and (string-suffix? "linux-gnu" %host-type)
                                  (or (string-prefix? "x86_64" %host-type)
                                      (string-prefix? "i686" %host-type))))
                        (file-exists? "/dev/fb0")
                        (invoke #+(file-append kmod "/bin/modprobe")
                                "uvesafb"
                                (string-append "v86d=" #$v86d "/sbin/v86d")
                                "mode_option=1024x768"))))
         (respawn? #f)
         (one-shot? #t))))

(define uvesafb-service-type
  (service-type
   (name 'uvesafb)
   (extensions
    (list (service-extension shepherd-root-service-type
                             uvesafb-shepherd-service)))
   (description
    "Load the @code{uvesafb} kernel module with the right options.")
   (default-value #t)))

(define %installation-services
  ;; List of services of the installation system.
  (let ((motd (plain-file "motd" "
\x1b[1;37mWelcome to the installation of GNU Guix!\x1b[0m

\x1b[2m\
Using this shell, you can carry out the installation process \"manually.\"
Access documentation at any time by pressing Alt-F2.\x1b[0m
")))
    (define (normal-tty tty)
      (mingetty-service (mingetty-configuration (tty tty)
                                                (auto-login "root")
                                                (login-pause? #t))))

    (define bare-bones-os
      (load "examples/bare-bones.tmpl"))

    (list (service virtual-terminal-service-type)

          (service kmscon-service-type
                   (kmscon-configuration
                    (virtual-terminal "tty1")
                    (login-program (installer-program))))

          (login-service (login-configuration
                          (motd motd)))

          ;; Documentation.  The manual is in UTF-8, but
          ;; 'console-font-service' sets up Unicode support and loads a font
          ;; with all the useful glyphs like em dash and quotation marks.
          (service documentation-service-type "tty2")

          ;; Documentation add-on.
          %configuration-template-service

          ;; A bunch of 'root' ttys.
          (normal-tty "tty3")
          (normal-tty "tty4")
          (normal-tty "tty5")
          (normal-tty "tty6")

          ;; The usual services.
          (syslog-service)

          ;; Use the Avahi daemon to discover substitute servers on the local
          ;; network.  It can be faster than fetching from remote servers.
          (service avahi-service-type)

          ;; The build daemon.  Register the default substitute server key(s)
          ;; as trusted to allow the installation process to use substitutes by
          ;; default.
          (service guix-service-type
                   (guix-configuration (authorize-key? #t)))

          ;; Start udev so that useful device nodes are available.
          ;; Use device-mapper rules for cryptsetup & co; enable the CRDA for
          ;; regulations-compliant WiFi access.
          (udev-service #:rules (list lvm2 crda))

          ;; Add the 'cow-store' service, which users have to start manually
          ;; since it takes the installation directory as an argument.
          (cow-store-service)

          ;; Install Unicode support and a suitable font.
          (service console-font-service-type
                   (map (match-lambda
                          ("tty2"
                           ;; Use a font that contains characters such as
                           ;; curly quotes as found in the manual.
                           '("tty2" . "LatGrkCyr-8x16"))
                          (tty
                           ;; Use a font that doesn't have more than 256
                           ;; glyphs so that we can use colors with varying
                           ;; brightness levels (see note in setfont(8)).
                           `(,tty . "lat9u-16")))
                        '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))

          ;; To facilitate copy/paste.
          (service gpm-service-type)

          ;; Add an SSH server to facilitate remote installs.
          (service openssh-service-type
                   (openssh-configuration
                    (port-number 22)
                    (permit-root-login #t)
                    ;; The root account is passwordless, so make sure
                    ;; a password is set before allowing logins.
                    (allow-empty-passwords? #f)
                    (password-authentication? #t)

                    ;; Don't start it upfront.
                    (%auto-start? #f)))

          ;; Since this is running on a USB stick with a overlayfs as the root
          ;; file system, use an appropriate cache configuration.
          (nscd-service (nscd-configuration
                         (caches %nscd-minimal-caches)))

          ;; Having /bin/sh is a good idea.  In particular it allows Tramp
          ;; connections to this system to work.
          (service special-files-service-type
                   `(("/bin/sh" ,(file-append bash "/bin/sh"))))

          ;; Loopback device, needed by OpenSSH notably.
          (service static-networking-service-type
                   (list (static-networking (interface "lo")
                                            (ip "127.0.0.1")
                                            (requirement '())
                                            (provision '(loopback)))))

          (service wpa-supplicant-service-type)
          (dbus-service)
          (service connman-service-type
                   (connman-configuration
                    (disable-vpn? #t)))

          ;; Keep a reference to BARE-BONES-OS to make sure it can be
          ;; installed without downloading/building anything.  Also keep the
          ;; things needed by 'profile-derivation' to minimize the amount of
          ;; download.
          (service gc-root-service-type
                   (append
                    (list bare-bones-os
                          glibc-utf8-locales
                          texinfo
                          guile-3.0)
                    %default-locale-libcs))

          ;; Machines without Kernel Mode Setting (those with many old and
          ;; current AMD GPUs, SiS GPUs, ...) need uvesafb to show the GUI
          ;; installer.  Some may also need a kernel parameter like nomodeset
          ;; or vga=793, but we leave that for the user to specify in GRUB.
          (service uvesafb-service-type))))

(define %issue
  ;; Greeting.
  "
\x1b[1;37mThis is an installation image of the GNU system.  Welcome.\x1b[0m

\x1b[1;33mUse Alt-F2 for documentation.\x1b[0m
")

(define installation-os
  ;; The operating system used on installation images for USB sticks etc.
  (operating-system
    (host-name "gnu")
    (timezone "Europe/Paris")
    (locale "en_US.utf8")
    (name-service-switch %mdns-host-lookup-nss)
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sda")))
    (label (string-append "GNU Guix installation "
                          (package-version guix)))

    ;; XXX: The AMD Radeon driver is reportedly broken, which makes kmscon
    ;; non-functional:
    ;; <https://lists.gnu.org/archive/html/guix-devel/2019-03/msg00441.html>.
    ;; Thus, blacklist it.
    (kernel-arguments '("quiet" "modprobe.blacklist=radeon"))

    (file-systems
     ;; Note: the disk image build code overrides this root file system with
     ;; the appropriate one.
     (cons* (file-system
              (mount-point "/")
              (device (file-system-label "Guix_image"))
              (type "ext4"))

            ;; Make /tmp a tmpfs instead of keeping the overlayfs.  This
            ;; originally was used for unionfs because FUSE creates
            ;; '.fuse_hiddenXYZ' files for each open file, and this confuses
            ;; Guix's test suite, for instance (see
            ;; <http://bugs.gnu.org/23056>).  We keep this for overlayfs to be
            ;; on the safe side.
            (file-system
              (mount-point "/tmp")
              (device "none")
              (type "tmpfs")
              (check? #f))

            ;; XXX: This should be %BASE-FILE-SYSTEMS but we don't need
            ;; elogind's cgroup file systems.
            (list %pseudo-terminal-file-system
                  %shared-memory-file-system
                  %efivars-file-system
                  %immutable-store)))

    (users (list (user-account
                  (name "guest")
                  (group "users")
                  (supplementary-groups '("wheel")) ; allow use of sudo
                  (password "")
                  (comment "Guest of GNU"))))

    (issue %issue)
    (services %installation-services)

    ;; We don't need setuid programs, except for 'passwd', which can be handy
    ;; if one is to allow remote SSH login to the machine being installed.
    (setuid-programs (list (file-append shadow "/bin/passwd")))

    (pam-services
     ;; Explicitly allow for empty passwords.
     (base-pam-services #:allow-empty-passwords? #t))

    (packages (append
                (list glibc         ; for 'tzselect' & co.
                      fontconfig
                      font-dejavu font-gnu-unifont
                      grub          ; mostly so xrefs to its manual work
                      nss-certs)    ; To access HTTPS, use git, etc.
                %base-packages-disk-utilities
                %base-packages))))

(define* (os-with-u-boot os board #:key (bootloader-target "/dev/mmcblk0")
                         (triplet "arm-linux-gnueabihf"))
  "Given OS, amend it with the u-boot bootloader for BOARD,
installed to BOOTLOADER-TARGET (a drive), compiled for TRIPLET.

If you want a serial console, make sure to specify one in your
operating-system's kernel-arguments (\"console=ttyS0\" or similar)."
  (operating-system (inherit os)
    (bootloader (bootloader-configuration
                 (bootloader (bootloader (inherit u-boot-bootloader)
                              (package (make-u-boot-package board triplet))))
                 (target bootloader-target)))))

(define* (embedded-installation-os bootloader bootloader-target tty
                                   #:key (extra-modules '()))
  "Return an installation os for embedded systems.
The initrd gets the extra modules EXTRA-MODULES.
A getty is provided on TTY.
The bootloader BOOTLOADER is installed to BOOTLOADER-TARGET."
  (operating-system
    (inherit installation-os)
    (bootloader (bootloader-configuration
                 (bootloader bootloader)
                 (target bootloader-target)))
    (kernel linux-libre)
    (kernel-arguments
     (cons (string-append "console=" tty)
           (operating-system-user-kernel-arguments installation-os)))
    (initrd-modules (append extra-modules %base-initrd-modules))))

(define beaglebone-black-installation-os
  (embedded-installation-os u-boot-beaglebone-black-bootloader
                            "/dev/sda"
                            "ttyO0"
                            #:extra-modules
                            ;; This module is required to mount the sd card.
                            '("omap_hsmmc")))

(define a20-olinuxino-lime-installation-os
  (embedded-installation-os u-boot-a20-olinuxino-lime-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttyS0"))

(define a20-olinuxino-lime2-emmc-installation-os
  (embedded-installation-os u-boot-a20-olinuxino-lime2-bootloader
                            "/dev/mmcblk1" ; eMMC storage
                            "ttyS0"))

(define a20-olinuxino-micro-installation-os
  (embedded-installation-os u-boot-a20-olinuxino-micro-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttyS0"))

(define bananapi-m2-ultra-installation-os
  (embedded-installation-os u-boot-bananapi-m2-ultra-bootloader
                            "/dev/mmcblk1" ; eMMC storage
                            "ttyS0"))

(define firefly-rk3399-installation-os
  (embedded-installation-os u-boot-firefly-rk3399-bootloader
                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                            "ttyS2")) ; UART2 connected on the Pi2 bus

(define mx6cuboxi-installation-os
  (embedded-installation-os u-boot-mx6cuboxi-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttymxc0"))

(define novena-installation-os
  (embedded-installation-os u-boot-novena-bootloader
                            "/dev/mmcblk1" ; SD card storage
                            "ttymxc1"))

(define nintendo-nes-classic-edition-installation-os
  (embedded-installation-os u-boot-nintendo-nes-classic-edition-bootloader
                            "/dev/mmcblk0" ; SD card (solder it yourself)
                            "ttyS0"))

(define pine64-plus-installation-os
  (embedded-installation-os u-boot-pine64-plus-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttyS0"))

(define pinebook-installation-os
  (embedded-installation-os u-boot-pinebook-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttyS0"))

(define rock64-installation-os
  (embedded-installation-os u-boot-rock64-rk3328-bootloader
                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                            "ttyS2")) ; UART2 connected on the Pi2 bus

(define rockpro64-installation-os
  (embedded-installation-os u-boot-rockpro64-rk3399-bootloader
                            "/dev/mmcblk0" ; SD card/eMMC (SD priority) storage
                            "ttyS2")) ; UART2 connected on the Pi2 bus

(define rk3399-puma-installation-os
  (embedded-installation-os u-boot-puma-rk3399-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttyS0"))

(define wandboard-installation-os
  (embedded-installation-os u-boot-wandboard-bootloader
                            "/dev/mmcblk0" ; SD card storage
                            "ttymxc0"))

;; Return the default os here so 'guix system' can consume it directly.
installation-os

;;; install.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 keyboard)
  #:use-module (guix gexp)
  #:use-module ((gnu packages xorg)
                #:select (xkeyboard-config console-setup))
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 match)
  #:export (keyboard-layout?
            keyboard-layout
            keyboard-layout-name
            keyboard-layout-variant
            keyboard-layout-model
            keyboard-layout-options

            keyboard-layout->console-keymap))

;;; Commentary:
;;;
;;; This module provides a data structure to represent keyboard layouts
;;; according to the XKB naming and classification (see the 'xkeyboard-config'
;;; package).
;;;
;;; Code:

(define-immutable-record-type <keyboard-layout>
  (%keyboard-layout name variant model options)
  keyboard-layout?
  (name      keyboard-layout-name)                ;string
  (variant   keyboard-layout-variant)             ;#f | string
  (model     keyboard-layout-model)               ;#f | string
  (options   keyboard-layout-options))            ;list of strings

(define* (keyboard-layout name #:optional variant
                          #:key model (options '()))
  "Return a new keyboard layout with the given NAME and VARIANT.

NAME must be a string such as \"fr\"; VARIANT must be a string such as
\"bepo\" or \"nodeadkeys\".  See the 'xkeyboard-config' package for valid
options."
  (%keyboard-layout name variant model options))

(define* (keyboard-layout->console-keymap layout
                                          #:key
                                          (xkeyboard-config xkeyboard-config))
  "Return a Linux console keymap file for LAYOUT, a <keyboard-layout> record.
Layout information is taken from the XKEYBOARD-CONFIG package."
  (define build
    (with-imported-modules '((guix build utils))
      #~(begin
          (use-modules (guix build utils)
                       (ice-9 popen)
                       (ice-9 match))

          (define pipe
            (open-pipe* OPEN_READ
                        #+(file-append console-setup "/bin/ckbcomp")
                        (string-append "-I"
                                       #+(file-append xkeyboard-config
                                                      "/share/X11/xkb"))
                        "-rules" "base"
                        #$@(match (keyboard-layout-model layout)
                             (#f      '())
                             (model   `("-model" ,model)))
                        #$(keyboard-layout-name layout)
                        #$(or (keyboard-layout-variant layout)
                              "")
                        #$(string-join (keyboard-layout-options layout) ",")))

          (call-with-output-file #$output
            (lambda (output)
              (dump-port pipe output)))

          ;; Note: ckbcomp errors out when the layout name is unknown, but
          ;; merely emits a warning when the variant is unknown.
          (unless (zero? (close-pipe pipe))
            (error "failed to create console keymap for keyboard layout"
                   #$(keyboard-layout-name layout))))))

  (computed-file (string-append "console-keymap."
                                (string-map (match-lambda
                                              (#\, #\-)
                                              (chr chr))
                                            (keyboard-layout-name layout)))
                 build))