code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
;;; Copyright © 2017 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)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix profiles)
  #:use-module (guix ui)
  #:use-module (gnu packages base)
  #:use-module (gnu packages bash)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages pciutils)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages less)
  #:use-module (gnu packages zile)
  #:use-module (gnu packages nano)
  #:use-module (gnu packages gawk)
  #:use-module (gnu packages man)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages firmware)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services base)
  #:use-module (gnu bootloader)
  #:use-module (gnu system shadow)
  #:use-module (gnu system nss)
  #:use-module (gnu system locale)
  #:use-module (gnu system pam)
  #:use-module (gnu system linux-initrd)
  #:use-module (gnu system uuid)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (rnrs bytevectors)
  #:export (operating-system
            operating-system?

            operating-system-bootloader
            operating-system-services
            operating-system-user-services
            operating-system-packages
            operating-system-host-name
            operating-system-hosts-file
            operating-system-kernel
            operating-system-kernel-file
            operating-system-kernel-arguments
            operating-system-initrd-modules
            operating-system-initrd
            operating-system-users
            operating-system-groups
            operating-system-issue
            operating-system-timezone
            operating-system-locale
            operating-system-locale-definitions
            operating-system-locale-libcs
            operating-system-mapped-devices
            operating-system-file-systems
            operating-system-store-file-system
            operating-system-user-mapped-devices
            operating-system-boot-mapped-devices
            operating-system-activation-script
            operating-system-user-accounts
            operating-system-shepherd-service-names
            operating-system-user-kernel-arguments

            operating-system-derivation
            operating-system-profile
            operating-system-bootcfg
            operating-system-etc-directory
            operating-system-locale-directory
            operating-system-boot-script

            system-linux-image-file-name

            boot-parameters
            boot-parameters?
            boot-parameters-label
            boot-parameters-root-device
            boot-parameters-bootloader-name
            boot-parameters-store-device
            boot-parameters-store-mount-point
            boot-parameters-kernel
            boot-parameters-kernel-arguments
            boot-parameters-initrd
            read-boot-parameters
            read-boot-parameters-file
            boot-parameters->menu-entry

            local-host-aliases
            %setuid-programs
            %base-packages
            %base-firmware))

;;; Commentary:
;;;
;;; This module supports whole-system configuration.
;;;
;;; Code:

(define (bootable-kernel-arguments kernel-arguments system.drv root-device)
  "Prepend extra arguments to KERNEL-ARGUMENTS that allow SYSTEM.DRV to be
booted from ROOT-DEVICE"
  (cons* (string-append "--root="
                        (cond ((uuid? root-device)

                               ;; Note: Always use the DCE format because that's
                               ;; what (gnu build linux-boot) expects for the
                               ;; '--root' kernel command-line option.
                               (uuid->string (uuid-bytevector root-device)
                                             'dce))
                              ((file-system-label? root-device)
                               (file-system-label->string root-device))
                              (else root-device)))
         #~(string-append "--system=" #$system.drv)
         #~(string-append "--load=" #$system.drv "/boot")
         kernel-arguments))

;; System-wide configuration.
;; TODO: Add per-field docstrings/stexi.
(define-record-type* <operating-system> operating-system
  make-operating-system
  operating-system?
  (kernel operating-system-kernel                 ; package
          (default linux-libre))
  (kernel-arguments operating-system-user-kernel-arguments
                    (default '()))                ; list of gexps/strings
  (bootloader operating-system-bootloader)        ; <bootloader-configuration>

  (initrd operating-system-initrd                 ; (list fs) -> M derivation
          (default base-initrd))
  (initrd-modules operating-system-initrd-modules ; list of strings
                  (thunked)                       ; it's system-dependent
                  (default %base-initrd-modules))

  (firmware operating-system-firmware             ; list of packages
            (default %base-firmware))

  (host-name operating-system-host-name)          ; string
  (hosts-file operating-system-hosts-file         ; file-like | #f
              (default #f))

  (mapped-devices operating-system-mapped-devices ; list of <mapped-device>
                  (default '()))
  (file-systems operating-system-file-systems)    ; list of fs
  (swap-devices operating-system-swap-devices     ; list of strings
                (default '()))

  (users operating-system-users                   ; list of user accounts
         (default %base-user-accounts))
  (groups operating-system-groups                 ; list of user groups
          (default %base-groups))

  (skeletons operating-system-skeletons           ; list of name/monadic value
             (default (default-skeletons)))
  (issue operating-system-issue                   ; string
         (default %default-issue))

  (packages operating-system-packages             ; list of (PACKAGE OUTPUT...)
            (default %base-packages))             ; or just PACKAGE

  (timezone operating-system-timezone)            ; string
  (locale   operating-system-locale               ; string
            (default "en_US.utf8"))
  (locale-definitions operating-system-locale-definitions ; list of <locale-definition>
                      (default %default-locale-definitions))
  (locale-libcs operating-system-locale-libcs     ; list of <packages>
                (default %default-locale-libcs))
  (name-service-switch operating-system-name-service-switch ; <name-service-switch>
                       (default %default-nss))

  (services operating-system-user-services        ; list of monadic services
            (default %base-services))

  (pam-services operating-system-pam-services     ; list of PAM services
                (default (base-pam-services)))
  (setuid-programs operating-system-setuid-programs
                   (default %setuid-programs))    ; list of string-valued gexps

  (sudoers-file operating-system-sudoers-file     ; file-like
                (default %sudoers-specification)))

(define (operating-system-kernel-arguments os system.drv root-device)
  "Return all the kernel arguments, including the ones not specified
directly by the user."
  (bootable-kernel-arguments (operating-system-user-kernel-arguments os)
                             system.drv
                             root-device))

;;;
;;; Boot parameters
;;;

(define-record-type* <boot-parameters>
  boot-parameters make-boot-parameters boot-parameters?
  (label            boot-parameters-label)
  ;; Because we will use the 'store-device' to create the GRUB search command,
  ;; the 'store-device' has slightly different semantics than 'root-device'.
  ;; The 'store-device' can be a file system uuid, a file system label, or #f,
  ;; but it cannot be a device path such as "/dev/sda3", since GRUB would not
  ;; understand that.  The 'root-device', on the other hand, corresponds
  ;; exactly to the device field of the <file-system> object representing the
  ;; OS's root file system, so it might be a device path like "/dev/sda3".
  (root-device      boot-parameters-root-device)
  (bootloader-name  boot-parameters-bootloader-name)
  (store-device     boot-parameters-store-device)
  (store-mount-point boot-parameters-store-mount-point)
  (kernel           boot-parameters-kernel)
  (kernel-arguments boot-parameters-kernel-arguments)
  (initrd           boot-parameters-initrd))

(define (ensure-not-/dev device)
  "If DEVICE starts with a slash, return #f.  This is meant to filter out
Linux device names such as /dev/sda, and to preserve GRUB device names and
file system labels."
  (if (and (string? device) (string-prefix? "/" device))
      #f
      device))

(define (read-boot-parameters port)
  "Read boot parameters from PORT and return the corresponding
<boot-parameters> object or #f if the format is unrecognized."
  (define device-sexp->device
    (match-lambda
      (('uuid (? symbol? type) (? bytevector? bv))
       (bytevector->uuid bv type))
      (('file-system-label (? string? label))
       (file-system-label label))
      ((? bytevector? bv)                         ;old format
       (bytevector->uuid bv 'dce))
      ((? string? device)
       ;; It used to be that we would not distinguish between labels and
       ;; device names.  Try to infer the right thing here.
       (if (string-prefix? "/dev/" device)
           device
           (file-system-label device)))))

  (match (read port)
    (('boot-parameters ('version 0)
                       ('label label) ('root-device root)
                       ('kernel linux)
                       rest ...)
     (boot-parameters
      (label label)
      (root-device (device-sexp->device root))

      (bootloader-name
       (match (assq 'bootloader-name rest)
         ((_ args) args)
         (#f       'grub))) ; for compatibility reasons.

      ;; In the past, we would store the directory name of the kernel instead
      ;; of the absolute file name of its image.  Detect that and correct it.
      (kernel (if (string=? linux (direct-store-path linux))
                  (string-append linux "/"
                                 (system-linux-image-file-name))
                  linux))

      (kernel-arguments
       (match (assq 'kernel-arguments rest)
         ((_ args) args)
         (#f       '())))                         ;the old format

      (initrd
       (match (assq 'initrd rest)
         (('initrd ('string-append directory file)) ;the old format
          (string-append directory file))
         (('initrd (? string? file))
          file)))

      (store-device
       ;; Linux device names like "/dev/sda1" are not suitable GRUB device
       ;; identifiers, so we just filter them out.
       (ensure-not-/dev
        (match (assq 'store rest)
          (('store ('device #f) _ ...)
           root-device)
          (('store ('device device) _ ...)
           (device-sexp->device device))
          (_                                      ;the old format
           root-device))))

      (store-mount-point
       (match (assq 'store rest)
         (('store ('device _) ('mount-point mount-point) _ ...)
          mount-point)
         (_                                       ;the old format
          "/")))))
    (x                                            ;unsupported format
     (warning (G_ "unrecognized boot parameters at '~a'~%")
              (port-filename port))
     #f)))

(define (read-boot-parameters-file system)
  "Read boot parameters from SYSTEM's (system or generation) \"parameters\"
file and returns the corresponding <boot-parameters> object or #f if the
format is unrecognized.
The object has its kernel-arguments extended in order to make it bootable."
  (let* ((file (string-append system "/parameters"))
         (params (call-with-input-file file read-boot-parameters))
         (root (boot-parameters-root-device params))
         (kernel-arguments (boot-parameters-kernel-arguments params)))
    (if params
      (boot-parameters
        (inherit params)
        (kernel-arguments (bootable-kernel-arguments kernel-arguments
                                                     system root)))
      #f)))

(define (boot-parameters->menu-entry conf)
  (menu-entry
   (label (boot-parameters-label conf))
   (device (boot-parameters-store-device conf))
   (device-mount-point (boot-parameters-store-mount-point conf))
   (linux (boot-parameters-kernel conf))
   (linux-arguments (boot-parameters-kernel-arguments conf))
   (initrd (boot-parameters-initrd conf))))

;;;
;;; Services.
;;;

(define (non-boot-file-system-service os)
  "Return the file system service for the file systems of OS that are not
marked as 'needed-for-boot'."
  (define file-systems
    (remove file-system-needed-for-boot?
            (operating-system-file-systems os)))

  (define mapped-devices-for-boot
    (operating-system-boot-mapped-devices os))

  (define (device-mappings fs)
    (let ((device (file-system-device fs)))
      (if (string? device)                        ;title is 'device
          (filter (lambda (md)
                    (string=? (string-append "/dev/mapper/"
                                             (mapped-device-target md))
                              device))
                  (operating-system-mapped-devices os))
          '())))

  (define (add-dependencies fs)
    ;; Add the dependencies due to device mappings to FS.
    (file-system
      (inherit fs)
      (dependencies
       (delete-duplicates
        (remove (cut member <> mapped-devices-for-boot)
                (append (device-mappings fs)
                        (file-system-dependencies fs)))
        eq?))))

  (service file-system-service-type
           (map add-dependencies file-systems)))

(define (mapped-device-users device file-systems)
  "Return the subset of FILE-SYSTEMS that use DEVICE."
  (let ((target (string-append "/dev/mapper/" (mapped-device-target device))))
    (filter (lambda (fs)
              (or (member device (file-system-dependencies fs))
                  (and (string? (file-system-device fs))
                       (string=? (file-system-device fs) target))))
            file-systems)))

(define (operating-system-user-mapped-devices os)
  "Return the subset of mapped devices that can be installed in
user-land--i.e., those not needed during boot."
  (let ((devices      (operating-system-mapped-devices os))
        (file-systems (operating-system-file-systems os)))
   (filter (lambda (md)
             (let ((users (mapped-device-users md file-systems)))
               (not (any file-system-needed-for-boot? users))))
           devices)))

(define (operating-system-boot-mapped-devices os)
  "Return the subset of mapped devices that must be installed during boot,
from the initrd."
  (let ((devices      (operating-system-mapped-devices os))
        (file-systems (operating-system-file-systems os)))
   (filter (lambda (md)
             (let ((users (mapped-device-users md file-systems)))
               (any file-system-needed-for-boot? users)))
           devices)))

(define (device-mapping-services os)
  "Return the list of device-mapping services for OS as a list."
  (map device-mapping-service
       (operating-system-user-mapped-devices os)))

(define (swap-services os)
  "Return the list of swap services for OS."
  (map swap-service (operating-system-swap-devices os)))

(define* (system-linux-image-file-name #:optional (system (%current-system)))
  "Return the basename of the kernel image file for SYSTEM."
  ;; FIXME: Evaluate the conditional based on the actual current system.
  (cond
   ((string-prefix? "arm" (%current-system)) "zImage")
   ((string-prefix? "mips" (%current-system)) "vmlinuz")
   ((string-prefix? "aarch64" (%current-system)) "Image")
   (else "bzImage")))

(define (operating-system-kernel-file os)
  "Return an object representing the absolute file name of the kernel image of
OS."
  (file-append (operating-system-kernel os)
               "/" (system-linux-image-file-name os)))

(define* (operating-system-directory-base-entries os #:key container?)
  "Return the basic entries of the 'system' directory of OS for use as the
value of the SYSTEM-SERVICE-TYPE service."
  (let ((locale (operating-system-locale-directory os)))
    (with-monad %store-monad
      (if container?
          (return `(("locale" ,locale)))
          (mlet %store-monad
              ((kernel  ->  (operating-system-kernel os))
               (initrd      (operating-system-initrd-file os))
               (params      (operating-system-boot-parameters-file os)))
            (return `(("kernel" ,kernel)
                      ("parameters" ,params)
                      ("initrd" ,initrd)
                      ("locale" ,locale))))))))   ;used by libc

(define* (essential-services os #:key container?)
  "Return the list of essential services for OS.  These are special services
that implement part of what's declared in OS are responsible for low-level
bookkeeping.  CONTAINER? determines whether to return the list of services for
a container or that of a \"bare metal\" system."
  (define known-fs
    (map file-system-mount-point (operating-system-file-systems os)))

  (let* ((mappings  (device-mapping-services os))
         (root-fs   (root-file-system-service))
         (other-fs  (non-boot-file-system-service os))
         (swaps     (swap-services os))
         (procs     (service user-processes-service-type))
         (host-name (host-name-service (operating-system-host-name os)))
         (entries   (operating-system-directory-base-entries
                     os #:container? container?)))
    (cons* (service system-service-type entries)
           %boot-service

           ;; %SHEPHERD-ROOT-SERVICE must come last so that the gexp that
           ;; execs shepherd comes last in the boot script (XXX).  Likewise,
           ;; the cleanup service must come first so that its gexp runs before
           ;; activation code.
           (service cleanup-service-type #f)
           %activation-service
           %shepherd-root-service

           (pam-root-service (operating-system-pam-services os))
           (account-service (append (operating-system-accounts os)
                                    (operating-system-groups os))
                            (operating-system-skeletons os))
           (operating-system-etc-service os)
           (service fstab-service-type '())
           (session-environment-service
            (operating-system-environment-variables os))
           host-name procs root-fs
           (service setuid-program-service-type
                    (operating-system-setuid-programs os))
           (service profile-service-type
                    (operating-system-packages os))
           other-fs
           (append mappings swaps

                   ;; Add the firmware service, unless we are building for a
                   ;; container.
                   (if container?
                       (list %containerized-shepherd-service)
                       (list %linux-bare-metal-service
                             (service firmware-service-type
                                      (operating-system-firmware os))))))))

(define* (operating-system-services os #:key container?)
  "Return all the services of OS, including \"internal\" services that do not
explicitly appear in OS."
  (instantiate-missing-services
   (append (operating-system-user-services os)
           (essential-services os #:container? container?))))

;;;
;;; /etc.
;;;

(define %base-firmware
  ;; Firmware usable by default.
  (list ath9k-htc-firmware
        openfwwf-firmware))

(define %base-packages
  ;; Default set of packages globally visible.  It should include anything
  ;; required for basic administrator tasks.
  (cons* procps psmisc which less zile nano
         pciutils usbutils
         util-linux
         inetutils isc-dhcp
         (@ (gnu packages admin) shadow)          ;for 'passwd'

         ;; wireless-tools is deprecated in favor of iw, but it's still what
         ;; many people are familiar with, so keep it around.
         iw wireless-tools

         iproute
         net-tools                        ; XXX: remove when Inetutils suffices
         man-db
         info-reader                     ;the standalone Info reader (no Perl)

         ;; The 'sudo' command is already in %SETUID-PROGRAMS, but we also
         ;; want the other commands and the man pages (notably because
         ;; auto-completion in Emacs shell relies on man pages.)
         sudo

         ;; Get 'insmod' & co. from kmod, not module-init-tools, since udev
         ;; already depends on it anyway.
         kmod eudev

         e2fsprogs kbd

         bash-completion

         ;; XXX: We don't use (canonical-package guile-2.2) here because that
         ;; would create a collision in the global profile between the GMP
         ;; variant propagated by 'guile-final' and the GMP variant propagated
         ;; by 'gnutls', itself propagated by 'guix'.
         guile-2.2

         ;; The packages below are also in %FINAL-INPUTS, so take them from
         ;; there to avoid duplication.
         (map canonical-package
              (list bash coreutils findutils grep sed
                    diffutils patch gawk tar gzip bzip2 xz lzip))))

(define %default-issue
  ;; Default contents for /etc/issue.
  "
This is the GNU system.  Welcome.\n")

(define (local-host-aliases host-name)
  "Return aliases for HOST-NAME, to be used in /etc/hosts."
  (string-append "127.0.0.1 localhost " host-name "\n"
                 "::1       localhost " host-name "\n"))

(define (default-/etc/hosts host-name)
  "Return the default /etc/hosts file."
  (plain-file "hosts" (local-host-aliases host-name)))

(define* (operating-system-etc-service os)
  "Return a <service> that builds containing the static part of the /etc
directory."
  (let ((login.defs
          (plain-file "login.defs"
                      (string-append
                        "# Default paths for non-login shells started by su(1).\n"
                        "ENV_PATH    /run/setuid-programs:"
                        "/run/current-system/profile/bin:"
                        "/run/current-system/profile/sbin\n"
                        "ENV_SUPATH  /run/setuid-programs:"
                        "/run/current-system/profile/bin:"
                        "/run/current-system/profile/sbin\n")))

        (issue      (plain-file "issue" (operating-system-issue os)))
        (nsswitch   (plain-file "nsswitch.conf"
                                (name-service-switch->string
                                 (operating-system-name-service-switch os))))

        ;; Startup file for POSIX-compliant login shells, which set system-wide
        ;; environment variables.
        (profile    (mixed-text-file "profile"  "\
# Crucial variables that could be missing in the profiles' 'etc/profile'
# because they would require combining both profiles.
# FIXME: See <http://bugs.gnu.org/20255>.
export MANPATH=$HOME/.guix-profile/share/man:/run/current-system/profile/share/man
export INFOPATH=$HOME/.guix-profile/share/info:/run/current-system/profile/share/info
export XDG_DATA_DIRS=$HOME/.guix-profile/share:/run/current-system/profile/share
export XDG_CONFIG_DIRS=$HOME/.guix-profile/etc/xdg:/run/current-system/profile/etc/xdg

# Make sure libXcursor finds cursors installed into user or system profiles.  See <http://bugs.gnu.org/24445>
export XCURSOR_PATH=$HOME/.icons:$HOME/.guix-profile/share/icons:/run/current-system/profile/share/icons

# Ignore the default value of 'PATH'.
unset PATH

# Load the system profile's settings.
GUIX_PROFILE=/run/current-system/profile ; \\
. /run/current-system/profile/etc/profile

# Since 'lshd' does not use pam_env, /etc/environment must be explicitly
# loaded when someone logs in via SSH.  See <http://bugs.gnu.org/22175>.
# We need 'PATH' to be defined here, for 'cat' and 'cut'.  Do this before
# reading the user's 'etc/profile' to allow variables to be overridden.
if [ -f /etc/environment -a -n \"$SSH_CLIENT\" \\
     -a -z \"$LINUX_MODULE_DIRECTORY\" ]
then
  . /etc/environment
  export `cat /etc/environment | cut -d= -f1`
fi

# Arrange so that ~/.config/guix/current comes first.
for profile in \"$HOME/.guix-profile\" \"$HOME/.config/guix/current\"
do
  if [ -f \"$profile/etc/profile\" ]
  then
    # Load the user profile's settings.
    GUIX_PROFILE=\"$profile\" ; \\
    . \"$profile/etc/profile\"
  else
    # At least define this one so that basic things just work
    # when the user installs their first package.
    export PATH=\"$profile/bin:$PATH\"
  fi
done

# Prepend setuid programs.
export PATH=/run/setuid-programs:$PATH

# Arrange so that ~/.config/guix/current/share/info comes first.
export INFOPATH=\"$HOME/.config/guix/current/share/info:$INFOPATH\"

# Set the umask, notably for users logging in via 'lsh'.
# See <http://bugs.gnu.org/22650>.
umask 022

# Allow Hunspell-based applications (IceCat, LibreOffice, etc.) to
# find dictionaries.
export DICPATH=\"$HOME/.guix-profile/share/hunspell:/run/current-system/profile/share/hunspell\"

# Allow GStreamer-based applications to find plugins.
export GST_PLUGIN_PATH=\"$HOME/.guix-profile/lib/gstreamer-1.0\"

if [ -n \"$BASH_VERSION\" -a -f /etc/bashrc ]
then
  # Load Bash-specific initialization code.
  . /etc/bashrc
fi
"))

        (bashrc    (plain-file "bashrc" "\
# Bash-specific initialization.

# The 'bash-completion' package.
if [ -f /run/current-system/profile/etc/profile.d/bash_completion.sh ]
then
  # Bash-completion sources ~/.bash_completion.  It installs a dynamic
  # completion loader that searches its own completion files as well
  # as those in ~/.guix-profile and /run/current-system/profile.
  source /run/current-system/profile/etc/profile.d/bash_completion.sh
fi\n")))
    (etc-service
     `(("services" ,(file-append net-base "/etc/services"))
       ("protocols" ,(file-append net-base "/etc/protocols"))
       ("rpc" ,(file-append net-base "/etc/rpc"))
       ("login.defs" ,#~#$login.defs)
       ("issue" ,#~#$issue)
       ("nsswitch.conf" ,#~#$nsswitch)
       ("profile" ,#~#$profile)
       ("bashrc" ,#~#$bashrc)
       ("hosts" ,#~#$(or (operating-system-hosts-file os)
                         (default-/etc/hosts (operating-system-host-name os))))
       ;; Write the operating-system-host-name to /etc/hostname to prevent
       ;; NetworkManager from changing the system's hostname when connecting
       ;; to certain networks.  Some discussion at
       ;; https://lists.gnu.org/archive/html/help-guix/2017-09/msg00037.html
       ("hostname" ,(plain-file "hostname" (operating-system-host-name os)))
       ("localtime" ,(file-append tzdata "/share/zoneinfo/"
                                  (operating-system-timezone os)))
       ("sudoers" ,(operating-system-sudoers-file os))))))

(define %root-account
  ;; Default root account.
  (user-account
   (name "root")
   (password "")
   (uid 0) (group "root")
   (comment "System administrator")
   (home-directory "/root")))

(define (operating-system-accounts os)
  "Return the user accounts for OS, including an obligatory 'root' account,
and excluding accounts requested by services."
  ;; Make sure there's a root account.
  (if (find (lambda (user)
              (and=> (user-account-uid user) zero?))
            (operating-system-users os))
      (operating-system-users os)
      (cons %root-account (operating-system-users os))))

(define (maybe-string->file file-name thing)
  "If THING is a string, return a <plain-file> with THING as its content.
Otherwise just return THING.

This is for backward-compatibility of fields that used to be strings and are
now file-like objects.."
  (match thing
    ((? string?)
     (warning (G_ "using a string for file '~a' is deprecated; \
use 'plain-file' instead~%")
              file-name)
     (plain-file file-name thing))
    (x
     x)))

(define (maybe-file->monadic file-name thing)
  "If THING is a value in %STORE-MONAD, return it as is; otherwise return
THING in the %STORE-MONAD.

This is for backward-compatibility of fields that used to be monadic values
and are now file-like objects."
  (with-monad %store-monad
    (match thing
      ((? procedure?)
       (warning (G_ "using a monadic value for '~a' is deprecated; \
use 'plain-file' instead~%")
                file-name)
       thing)
      (x
       (return x)))))

(define (operating-system-etc-directory os)
  "Return that static part of the /etc directory of OS."
  (etc-directory
   (fold-services (operating-system-services os)
                  #:target-type etc-service-type)))

(define (operating-system-environment-variables os)
  "Return the environment variables of OS for
@var{session-environment-service-type}, to be used in @file{/etc/environment}."
  `(("LANG" . ,(operating-system-locale os))
    ;; Note: No need to set 'TZ' since (1) we provide /etc/localtime, and (2)
    ;; it doesn't work for setuid binaries.  See <https://bugs.gnu.org/29212>.
    ("TZDIR" . ,(file-append tzdata "/share/zoneinfo"))
    ;; Tell 'modprobe' & co. where to look for modules.
    ("LINUX_MODULE_DIRECTORY" . "/run/booted-system/kernel/lib/modules")
    ;; These variables are honored by OpenSSL (libssl) and Git.
    ("SSL_CERT_DIR" . "/etc/ssl/certs")
    ("SSL_CERT_FILE" . "/etc/ssl/certs/ca-certificates.crt")
    ("GIT_SSL_CAINFO" . "/etc/ssl/certs/ca-certificates.crt")

    ;; 'GTK_DATA_PREFIX' must name one directory where GTK+ themes are
    ;; searched for.
    ("GTK_DATA_PREFIX" . "/run/current-system/profile")

    ;; By default, applications that use D-Bus, such as Emacs, abort at startup
    ;; when /etc/machine-id is missing.  Make sure these warnings are non-fatal.
    ("DBUS_FATAL_WARNINGS" . "0")

    ;; XXX: Normally we wouldn't need to do this, but our glibc@2.23 package
    ;; used to look things up in 'PREFIX/lib/locale' instead of
    ;; '/run/current-system/locale' as was intended.  Keep this hack around so
    ;; that people who still have glibc@2.23-using packages in their profiles
    ;; can use them correctly.
    ;; TODO: Remove when glibc@2.23 is long gone.
    ("GUIX_LOCPATH" . "/run/current-system/locale")))

(define %setuid-programs
  ;; Default set of setuid-root programs.
  (let ((shadow (@ (gnu packages admin) shadow)))
    (list (file-append shadow "/bin/passwd")
          (file-append shadow "/bin/su")
          (file-append shadow "/bin/newuidmap")
          (file-append shadow "/bin/newgidmap")
          (file-append inetutils "/bin/ping")
          (file-append inetutils "/bin/ping6")
          (file-append sudo "/bin/sudo")
          (file-append fuse "/bin/fusermount"))))

(define %sudoers-specification
  ;; Default /etc/sudoers contents: 'root' and all members of the 'wheel'
  ;; group can do anything.  See
  ;; <http://www.sudo.ws/sudo/man/1.8.10/sudoers.man.html>.
  ;; TODO: Add a declarative API.
  (plain-file "sudoers" "\
root ALL=(ALL) ALL
%wheel ALL=(ALL) ALL\n"))

(define* (operating-system-activation-script os #:key container?)
  "Return the activation script for OS---i.e., the code that \"activates\" the
stateful part of OS, including user accounts and groups, special directories,
etc."
  (let* ((services   (operating-system-services os #:container? container?))
         (activation (fold-services services
                                    #:target-type activation-service-type)))
    (activation-service->script activation)))

(define* (operating-system-boot-script os #:key container?)
  "Return the boot script for OS---i.e., the code started by the initrd once
we're running in the final root.  When CONTAINER? is true, skip all
hardware-related operations as necessary when booting a Linux container."
  (let* ((services (operating-system-services os #:container? container?))
         (boot     (fold-services services #:target-type boot-service-type)))
    (service-value boot)))

(define (operating-system-user-accounts os)
  "Return the list of user accounts of OS."
  (let* ((services (operating-system-services os))
         (account  (fold-services services
                                  #:target-type account-service-type)))
    (filter user-account?
            (service-value account))))

(define (operating-system-shepherd-service-names os)
  "Return the list of Shepherd service names for OS."
  (append-map shepherd-service-provision
              (service-value
               (fold-services (operating-system-services os)
                              #:target-type
                              shepherd-root-service-type))))

(define* (operating-system-derivation os #:key container?)
  "Return a derivation that builds OS."
  (let* ((services (operating-system-services os #:container? container?))
         (system   (fold-services services)))
    ;; SYSTEM contains the derivation as a monadic value.
    (service-value system)))

(define* (operating-system-profile os #:key container?)
  "Return a derivation that builds the system profile of OS."
  (mlet* %store-monad
      ((services -> (operating-system-services os #:container? container?))
       (profile (fold-services services
                               #:target-type profile-service-type)))
    (match profile
      (("profile" profile)
       (return profile)))))

(define (operating-system-root-file-system os)
  "Return the root file system of OS."
  (find (lambda (fs)
          (string=? "/" (file-system-mount-point fs)))
        (operating-system-file-systems os)))

(define (operating-system-initrd-file os)
  "Return a gexp denoting the initrd file of OS."
  (define boot-file-systems
    (filter file-system-needed-for-boot?
            (operating-system-file-systems os)))

  (define mapped-devices
    (operating-system-boot-mapped-devices os))

  (define make-initrd
    (operating-system-initrd os))

  (mlet %store-monad ((initrd (make-initrd boot-file-systems
                                           #:linux (operating-system-kernel os)
                                           #:linux-modules
                                           (operating-system-initrd-modules os)
                                           #:mapped-devices mapped-devices)))
    (return (file-append initrd "/initrd"))))

(define (locale-name->definition* name)
  "Variant of 'locale-name->definition' that raises an error upon failure."
  (match (locale-name->definition name)
    (#f
     (raise (condition
             (&message
              (message (format #f (G_ "~a: invalid locale name") name))))))
    (def def)))

(define (operating-system-locale-directory os)
  "Return the directory containing the locales compiled for the definitions
listed in OS.  The C library expects to find it under
/run/current-system/locale."
  (define name
    (operating-system-locale os))

  (define definitions
    ;; While we're at it, check whether NAME is defined and add it if needed.
    (if (member name (map locale-definition-name
                          (operating-system-locale-definitions os)))
        (operating-system-locale-definitions os)
        (cons (locale-name->definition* name)
              (operating-system-locale-definitions os))))

  (locale-directory definitions
                    #:libcs (operating-system-locale-libcs os)))

(define (kernel->boot-label kernel)
  "Return a label for the bootloader menu entry that boots KERNEL."
  (string-append "GNU with "
                 (string-titlecase (package-name kernel)) " "
                 (package-version kernel)
                 " (beta)"))

(define (store-file-system file-systems)
  "Return the file system object among FILE-SYSTEMS that contains the store."
  (match (filter (lambda (fs)
                   (and (file-system-mount? fs)
                        (not (memq 'bind-mount (file-system-flags fs)))
                        (string-prefix? (file-system-mount-point fs)
                                        (%store-prefix))))
                 file-systems)
    ((and candidates (head . tail))
     (reduce (lambda (fs1 fs2)
               (if (> (string-length (file-system-mount-point fs1))
                      (string-length (file-system-mount-point fs2)))
                   fs1
                   fs2))
             head
             candidates))))

(define (operating-system-store-file-system os)
  "Return the file system that contains the store of OS."
  (store-file-system (operating-system-file-systems os)))

(define* (operating-system-bootcfg os #:optional (old-entries '()))
  "Return the bootloader configuration file for OS.  Use OLD-ENTRIES
(which is a list of <menu-entry>) to populate the \"old entries\" menu."
  (mlet* %store-monad
      ((system      (operating-system-derivation os))
       (root-fs ->  (operating-system-root-file-system os))
       (root-device -> (file-system-device root-fs))
       (params (operating-system-boot-parameters os system root-device))
       (entry -> (boot-parameters->menu-entry params))
       (bootloader-conf -> (operating-system-bootloader os)))
    ((bootloader-configuration-file-generator
      (bootloader-configuration-bootloader bootloader-conf))
     bootloader-conf (list entry) #:old-entries old-entries)))

(define (operating-system-boot-parameters os system.drv root-device)
  "Return a monadic <boot-parameters> record that describes the boot parameters
of OS.  SYSTEM.DRV is either a derivation or #f.  If it's a derivation, adds
kernel arguments for that derivation to <boot-parameters>."
  (mlet* %store-monad
      ((initrd (operating-system-initrd-file os))
       (store -> (operating-system-store-file-system os))
       (bootloader  -> (bootloader-configuration-bootloader
                        (operating-system-bootloader os)))
       (bootloader-name -> (bootloader-name bootloader))
       (label -> (kernel->boot-label (operating-system-kernel os))))
    (return (boot-parameters
             (label label)
             (root-device root-device)
             (kernel (operating-system-kernel-file os))
             (kernel-arguments
              (if system.drv
                (operating-system-kernel-arguments os system.drv root-device)
                (operating-system-user-kernel-arguments os)))
             (initrd initrd)
             (bootloader-name bootloader-name)
             (store-device (ensure-not-/dev (file-system-device store)))
             (store-mount-point (file-system-mount-point store))))))

(define (device->sexp device)
  "Serialize DEVICE as an sexp (really, as an object with a read syntax.)"
  (match device
    ((? uuid? uuid)
     `(uuid ,(uuid-type uuid) ,(uuid-bytevector uuid)))
    ((? file-system-label? label)
     `(file-system-label ,(file-system-label->string label)))
    (_
     device)))

(define* (operating-system-boot-parameters-file os #:optional (system.drv #f))
   "Return a file that describes the boot parameters of OS.  The primary use of
this file is the reconstruction of GRUB menu entries for old configurations.
SYSTEM.DRV is optional.  If given, adds kernel arguments for that system to the
returned file (since the returned file is then usually stored into the
content-addressed \"system\" directory, it's usually not a good idea
to give it because the content hash would change by the content hash
being stored into the \"parameters\" file)."
  (mlet* %store-monad ((root -> (operating-system-root-file-system os))
                       (device -> (file-system-device root))
                       (params (operating-system-boot-parameters os
                                                                 system.drv
                                                                 device)))
     (gexp->file "parameters"
                 #~(boot-parameters
                    (version 0)
                    (label #$(boot-parameters-label params))
                    (root-device
                     #$(device->sexp
                        (boot-parameters-root-device params)))
                    (kernel #$(boot-parameters-kernel params))
                    (kernel-arguments
                     #$(boot-parameters-kernel-arguments params))
                    (initrd #$(boot-parameters-initrd params))
                    (bootloader-name #$(boot-parameters-bootloader-name params))
                    (store
                     (device
                      #$(device->sexp (boot-parameters-store-device params)))
                     (mount-point #$(boot-parameters-store-mount-point params))))
                 #:set-load-path? #f)))

(define-gexp-compiler (operating-system-compiler (os <operating-system>)
                                                 system target)
  ((store-lift
    (lambda (store)
      ;; XXX: This is not super elegant but we can't pass SYSTEM and TARGET to
      ;; 'operating-system-derivation'.
      (run-with-store store (operating-system-derivation os)
                      #:system system
                      #:target target)))))

;;; system.scm ends here


code:
;; This is an operating system configuration template
;; for a "bare bones" setup, with no X11 display server.

(use-modules (gnu))
(use-service-modules networking ssh)
(use-package-modules screen ssh)

(operating-system
  (host-name "komputilo")
  (timezone "Europe/Berlin")
  (locale "en_US.utf8")

  ;; Boot in "legacy" BIOS mode, assuming /dev/sdX is the
  ;; target hard disk, and "my-root" is the label of the target
  ;; root file system.
  (bootloader (bootloader-configuration
                (bootloader grub-bootloader)
                (target "/dev/sdX")))
  (file-systems (cons (file-system
                        (device (file-system-label "my-root"))
                        (mount-point "/")
                        (type "ext4"))
                      %base-file-systems))

  ;; This is where user accounts are specified.  The "root"
  ;; account is implicit, and is initially created with the
  ;; empty password.
  (users (cons (user-account
                (name "alice")
                (comment "Bob's sister")
                (group "users")

                ;; Adding the account to the "wheel" group
                ;; makes it a sudoer.  Adding it to "audio"
                ;; and "video" allows the user to play sound
                ;; and access the webcam.
                (supplementary-groups '("wheel"
                                        "audio" "video"))
                (home-directory "/home/alice"))
               %base-user-accounts))

  ;; Globally-installed packages.
  (packages (cons* screen openssh %base-packages))

  ;; Add services to the baseline: a DHCP client and
  ;; an SSH server.
  (services (cons* (dhcp-client-service)
                   (service openssh-service-type
                            (openssh-configuration
                              (port-number 2222)))
                   %base-services)))

license: mit


code:
;; This is an operating system configuration template
;; for a "bare bones" setup on BeagleBone Black board.

(use-modules (gnu) (gnu bootloader u-boot))
(use-service-modules networking)
(use-package-modules bootloaders screen ssh)

(operating-system
  (host-name "komputilo")
  (timezone "Europe/Berlin")
  (locale "en_US.utf8")

  ;; Assuming /dev/mmcblk1 is the eMMC, and "my-root" is
  ;; the label of the target root file system.
  (bootloader (bootloader-configuration
               (bootloader u-boot-beaglebone-black-bootloader)
               (target "/dev/mmcblk1")))

  ;; This module is required to mount the SD card.
  (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))

  (file-systems (cons (file-system
                        (device (file-system-label "my-root"))
                        (mount-point "/")
                        (type "ext4"))
                      %base-file-systems))

  ;; This is where user accounts are specified.  The "root"
  ;; account is implicit, and is initially created with the
  ;; empty password.
  (users (cons (user-account
                (name "alice")
                (comment "Bob's sister")
                (group "users")

                ;; Adding the account to the "wheel" group
                ;; makes it a sudoer.  Adding it to "audio"
                ;; and "video" allows the user to play sound
                ;; and access the webcam.
                (supplementary-groups '("wheel"
                                        "audio" "video"))
                (home-directory "/home/alice"))
               %base-user-accounts))

  ;; Globally-installed packages.
  (packages (cons* screen openssh %base-packages))

  (services (cons* (dhcp-client-service)
                   ;; mingetty does not work on serial lines.
                   ;; Use agetty with board-specific serial parameters.
                   (agetty-service
                    (agetty-configuration
                     (extra-options '("-L"))
                     (baud-rate "115200")
                     (term "vt100")
                     (tty "ttyO0")))
                   %base-services)))


code:
;; This is an operating system configuration template
;; for a "desktop" setup with GNOME and Xfce where the
;; root partition is encrypted with LUKS.

(use-modules (gnu) (gnu system nss))
(use-service-modules desktop)
(use-package-modules certs gnome)

(operating-system
  (host-name "antelope")
  (timezone "Europe/Paris")
  (locale "en_US.utf8")

  ;; Use the UEFI variant of GRUB with the EFI System
  ;; Partition mounted on /boot/efi.
  (bootloader (bootloader-configuration
                (bootloader grub-efi-bootloader)
                (target "/boot/efi")))

  ;; Specify a mapped device for the encrypted root partition.
  ;; The UUID is that returned by 'cryptsetup luksUUID'.
  (mapped-devices
   (list (mapped-device
          (source (uuid "12345678-1234-1234-1234-123456789abc"))
          (target "my-root")
          (type luks-device-mapping))))

  (file-systems (cons (file-system
                        (device "my-root")
                        (mount-point "/")
                        (type "ext4")
                        (dependencies mapped-devices))
                      %base-file-systems))

  (users (cons (user-account
                (name "bob")
                (comment "Alice's brother")
                (group "users")
                (supplementary-groups '("wheel" "netdev"
                                        "audio" "video"))
                (home-directory "/home/bob"))
               %base-user-accounts))

  ;; This is where we specify system-wide packages.
  (packages (cons* nss-certs         ;for HTTPS access
                   gvfs              ;for user mounts
                   %base-packages))

  ;; Add GNOME and/or Xfce---we can choose at the log-in
  ;; screen with F1.  Use the "desktop" services, which
  ;; include the X11 log-in service, networking with
  ;; NetworkManager, and more.
  (services (cons* (gnome-desktop-service)
                   (xfce-desktop-service)
                   %desktop-services))

  ;; Allow resolution of '.local' host names with mDNS.
  (name-service-switch %mdns-host-lookup-nss))


code:
;; This is an operating system configuration template for a "Docker image"
;; setup, so it has barely any services at all.

(use-modules (gnu))

(operating-system
  (host-name "komputilo")
  (timezone "Europe/Berlin")
  (locale "en_US.utf8")

  ;; This is where user accounts are specified.  The "root" account is
  ;; implicit, and is initially created with the empty password.
  (users (cons (user-account
                (name "alice")
                (comment "Bob's sister")
                (group "users")
                (supplementary-groups '("wheel"
                                        "audio" "video"))
                (home-directory "/home/alice"))
               %base-user-accounts))

  ;; Globally-installed packages.
  (packages %base-packages)

  ;; Because the system will run in a Docker container, we may omit many
  ;; things that would normally be required in an operating system
  ;; configuration file.  These things include:
  ;;
  ;;   * bootloader
  ;;   * file-systems
  ;;   * services such as mingetty, udevd, slim, networking, dhcp
  ;;
  ;; Either these things are simply not required, or Docker provides
  ;; similar services for us.

  ;; This will be ignored.
  (bootloader (bootloader-configuration
               (bootloader grub-bootloader)
               (target "does-not-matter")))
  ;; This will be ignored, too.
  (file-systems (list (file-system
                        (device "does-not-matter")
                        (mount-point "/")
                        (type "does-not-matter"))))

  ;; Guix is all you need!
  (services (list (guix-service))))


code:
;; This is an operating system configuration template
;; for a "desktop" setup without full-blown desktop
;; environments.

(use-modules (gnu) (gnu system nss))
(use-service-modules desktop)
(use-package-modules bootloaders certs ratpoison suckless wm)

(operating-system
  (host-name "antelope")
  (timezone "Europe/Paris")
  (locale "en_US.utf8")

  ;; Use the UEFI variant of GRUB with the EFI System
  ;; Partition mounted on /boot/efi.
  (bootloader (bootloader-configuration
                (bootloader grub-efi-bootloader)
                (target "/boot/efi")))

  ;; Assume the target root file system is labelled "my-root",
  ;; and the EFI System Partition has UUID 1234-ABCD.
  (file-systems (cons* (file-system
                         (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       (file-system
                         (device (uuid "1234-ABCD" 'fat))
                         (mount-point "/boot/efi")
                         (type "vfat"))
                       %base-file-systems))

  (users (cons (user-account
                (name "alice")
                (comment "Bob's sister")
                (group "users")
                (supplementary-groups '("wheel" "netdev"
                                        "audio" "video"))
                (home-directory "/home/alice"))
               %base-user-accounts))

  ;; Add a bunch of window managers; we can choose one at
  ;; the log-in screen with F1.
  (packages (cons* ratpoison i3-wm i3status dmenu ;window managers
                   nss-certs                      ;for HTTPS access
                   %base-packages))

  ;; Use the "desktop" services, which include the X11
  ;; log-in service, networking with NetworkManager, and more.
  (services %desktop-services)

  ;; Allow resolution of '.local' host names with mDNS.
  (name-service-switch %mdns-host-lookup-nss))


code:
;;; This is an operating system configuration template for a "bare-bones" setup,
;;; suitable for booting in a virtualized environment, including virtual private
;;; servers (VPS).

(use-modules (gnu))
(use-package-modules bootloaders disk nvi)

(define vm-image-motd (plain-file "motd" "
This is the GNU system.  Welcome!

This instance of GuixSD is a bare-bones template for virtualized environments.

You will probably want to do these things first if you booted in a virtual
private server (VPS):

* Set a password for 'root'.
* Set up networking.
* Expand the root partition to fill the space available by 0) deleting and
recreating the partition with fdisk, 1) reloading the partition table with
partprobe, and then 2) resizing the filesystem with resize2fs.\n"))

(operating-system
  (host-name "gnu")
  (timezone "Etc/UTC")
  (locale "en_US.utf8")

  ;; Assuming /dev/sdX is the target hard disk, and "my-root" is
  ;; the label of the target root file system.
  (bootloader (bootloader-configuration
               (bootloader grub-bootloader)
               (target "/dev/sda")
               (terminal-outputs '(console))))
  (file-systems (cons (file-system
                        (device (file-system-label "my-root"))
                        (mount-point "/")
                        (type "ext4"))
                      %base-file-systems))

  ;; This is where user accounts are specified.  The "root"
  ;; account is implicit, and is initially created with the
  ;; empty password.
  (users %base-user-accounts)

  ;; Globally-installed packages.
  (packages (cons* nvi fdisk
                   grub   ; mostly so xrefs to its manual work
                   parted ; partprobe
                   %base-packages))

  (services (modify-services %base-services
              (login-service-type config =>
                                  (login-configuration
                                    (inherit config)
                                    (motd vm-image-motd))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 file-systems)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (guix records)
  #:use-module (gnu system uuid)
  #:re-export (uuid                               ;backward compatibility
               string->uuid
               uuid->string)
  #:export (file-system
            file-system?
            file-system-device
            file-system-title                     ;deprecated
            file-system-mount-point
            file-system-type
            file-system-needed-for-boot?
            file-system-flags
            file-system-options
            file-system-mount?
            file-system-check?
            file-system-create-mount-point?
            file-system-dependencies
            file-system-location

            file-system-type-predicate

            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
            %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))
  (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,
where both FILE1 and FILE2 are absolute file name.  For example:

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

  (file-prefix? \"/gn\" \"/gnu/store\")
  => #f
"
  (and (string-prefix? "/" file1)
       (string-prefix? "/" 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)))))))

(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 _ _ check?)
     (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 check?))))

(define (spec->file-system sexp)
  "Deserialize SEXP, a list, to the corresponding <file-system> object."
  (match sexp
    ((device mount-point type flags options check?)
     (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)
       (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 %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))))

(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")))))

(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
        %shared-memory-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)))

;;; file-systems.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018 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 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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 bootloader u-boot)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module ((guix store) #:select (%store-prefix))
  #: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 guile)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages ssh)
  #:use-module (gnu packages cryptsetup)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages texinfo)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages nvi)
  #: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
            pine64-plus-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:

(define (log-to-info)
  "Return a script that spawns the Info reader on the right section of the
manual."
  (program-file "log-to-info"
                #~(begin
                    ;; 'gunzip' is needed to decompress the doc.
                    (setenv "PATH" (string-append #$gzip "/bin"))

                    (execl (string-append #$info-reader "/bin/info") "info"
                           "-d" "/run/current-system/profile/share/info"
                           "-f" (string-append #$guix "/share/info/guix.info")
                           "-n" "System Installation"))))

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

(define (make-cow-store target)
  "Return a gexp that makes the store copy-on-write, using TARGET as the
backing store.  This is useful when TARGET is on a hard disk, whereas the
current store is on a RAM disk."

  (define (set-store-permissions directory)
    ;; Set the right perms on DIRECTORY to use it as the store.
    #~(begin
        (chown #$directory 0 30000)             ;use the fixed 'guixbuild' GID
        (chmod #$directory #o1775)))

  #~(begin
      ;; Bind-mount TARGET's /tmp in case we need space to build things.
      (let ((tmpdir (string-append #$target "/tmp")))
        (mkdir-p tmpdir)
        (mount tmpdir "/tmp" "none" MS_BIND))

      (let* ((rw-dir (string-append target #$%backing-directory))
             (work-dir (string-append rw-dir "/../.overlayfs-workdir")))
        (mkdir-p rw-dir)
        (mkdir-p work-dir)
        (mkdir-p "/.rw-store")
        #$(set-store-permissions #~rw-dir)
        #$(set-store-permissions "/.rw-store")

        ;; Mount the overlay, then atomically make it the store.
        (mount "none" "/.rw-store" "overlay" 0
               (string-append "lowerdir=" #$(%store-prefix) ","
                              "upperdir=" rw-dir ","
                              "workdir=" work-dir))
        (mount "/.rw-store" #$(%store-prefix) "" MS_MOVE)
        (rmdir "/.rw-store"))))

(define cow-store-service-type
  (shepherd-service-type
   'cow-store
   (lambda _
     (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)

      (start #~(case-lambda
                 ((target)
                  #$(make-cow-store #~target)
                  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))))))))

(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 (file f)
    (local-file (string-append "examples/" f)))

  (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)))
                                   '(#$(file "bare-bones.tmpl")
                                     #$(file "beaglebone-black.tmpl")
                                     #$(file "desktop.tmpl")
                                     #$(file "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

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

\x1b[2mThere is NO WARRANTY, to the extent permitted by law.  In particular, you may
LOSE ALL YOUR DATA as a side effect of the installation process.  Furthermore,
it is 'beta' software, so it may contain bugs.

You have been warned.  Thanks for being so brave.\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)

          (mingetty-service (mingetty-configuration
                             (tty "tty1")
                             (auto-login "root")))

          (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.
          (mingetty-service (mingetty-configuration
                             (tty "tty2")
                             (auto-login "guest")
                             (login-program (log-to-info))))

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

          ;; The build daemon.  Register the hydra.gnu.org key as trusted.
          ;; This allows the installation process to use substitutes by
          ;; default.
          (guix-service (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.  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)).
          (service console-font-service-type
                   (map (lambda (tty)
                          (cons tty "lat9u-16"))
                        '("tty1" "tty2" "tty3" "tty4" "tty5" "tty6")))

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

          ;; 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 (canonical-package 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)))))

          ;; 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
                   (list bare-bones-os
                         glibc-utf8-locales
                         texinfo
                         (canonical-package guile-2.2))))))

(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")
    (bootloader (bootloader-configuration
                 (bootloader grub-bootloader)
                 (target "/dev/sda")))
    (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 "GuixSD_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
                  %immutable-store)))

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

    (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 (cons* (canonical-package glibc) ;for 'tzselect' & co.
                     parted gptfdisk ddrescue
                     grub                  ;mostly so xrefs to its manual work
                     cryptsetup
                     mdadm
                     dosfstools         ;mkfs.fat, for the UEFI boot partition
                     btrfs-progs
                     openssh    ;we already have sshd, having ssh/scp can help
                     wireless-tools iw wpa-supplicant-minimal iproute
                     ;; XXX: We used to have GNU fdisk here, but as of version
                     ;; 2.0.0a, that pulls Guile 1.8, which takes unreasonable
                     ;; space; furthermore util-linux's fdisk is already
                     ;; available here, so we keep that.
                     bash-completion
                     nvi                          ;:wq!
                     %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 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 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 © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017 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 linux-container)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (guix config)
  #:use-module (guix store)
  #:use-module (guix gexp)
  #:use-module (guix derivations)
  #:use-module (guix monads)
  #:use-module (guix modules)
  #:use-module (gnu build linux-container)
  #:use-module (gnu services)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:export (system-container
            containerized-operating-system
            container-script))

(define (containerized-operating-system os mappings)
  "Return an operating system based on OS for use in a Linux container
environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
containerized OS."
  (define user-file-systems
    (remove (lambda (fs)
              (let ((target (file-system-mount-point fs))
                    (source (file-system-device fs)))
                (or (string=? target (%store-prefix))
                    (string=? target "/")
                    (and (string? source)
                         (string-prefix? "/dev/" source))
                    (string-prefix? "/dev" target)
                    (string-prefix? "/sys" target))))
            (operating-system-file-systems os)))

  (define (mapping->fs fs)
    (file-system (inherit (file-system-mapping->bind-mount fs))
      (needed-for-boot? #t)))

  (operating-system (inherit os)
    (swap-devices '()) ; disable swap
    (file-systems (append (map mapping->fs (cons %store-mapping mappings))
                          %container-file-systems
                          user-file-systems))))

(define* (container-script os #:key (mappings '()))
  "Return a derivation of a script that runs OS as a Linux container.
MAPPINGS is a list of <file-system> objects that specify the files/directories
that will be shared with the host system."
  (let* ((os           (containerized-operating-system os mappings))
         (file-systems (filter file-system-needed-for-boot?
                               (operating-system-file-systems os)))
         (specs        (map file-system->spec file-systems)))

    (mlet* %store-monad ((os-drv (operating-system-derivation
                                  os
                                  #:container? #t)))

      (define script
        (with-imported-modules (source-module-closure
                                '((guix build utils)
                                  (gnu build linux-container)))
          #~(begin
              (use-modules (gnu build linux-container)
                           (gnu system file-systems) ;spec->file-system
                           (guix build utils))

              (call-with-container (map spec->file-system '#$specs)
                (lambda ()
                  (setenv "HOME" "/root")
                  (setenv "TMPDIR" "/tmp")
                  (setenv "GUIX_NEW_SYSTEM" #$os-drv)
                  (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                  (primitive-load (string-append #$os-drv "/boot")))
                ;; A range of 65536 uid/gids is used to cover 16 bits worth of
                ;; users and groups, which is sufficient for most cases.
                ;;
                ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
                #:host-uids 65536))))

      (gexp->script "run-container" script))))