code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org>
;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2020 Google LLC
;;;
;;; 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 services base)
  #:use-module (gnu services networking)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:export (system-container
            containerized-operating-system
            container-script
            eval/container))

(define* (container-essential-services os #:key shared-network?)
  "Return a list of essential services corresponding to OS, a
non-containerized OS.  This procedure essentially strips essential services
from OS that are needed on the bare metal and not in a container."
  (define base
    (remove (lambda (service)
              (memq (service-kind service)
                    (list (service-kind %linux-bare-metal-service)
                          firmware-service-type
                          system-service-type)))
            (operating-system-default-essential-services os)))

  (cons (service system-service-type
                 `(("locale" ,(operating-system-locale-directory os))))
        ;; If network is to be shared with the host, remove network
        ;; configuration files from etc-service.
        (if shared-network?
            (modify-services base
              (etc-service-type
               files => (remove
                         (match-lambda
                           ((filename _)
                            (member filename
                                    (map basename %network-configuration-files))))
                         files)))
            base)))

(define dummy-networking-service-type
  (shepherd-service-type
   'dummy-networking
   (const (shepherd-service
           (documentation "Provide loopback and networking without actually
doing anything.")
           (provision '(loopback networking))
           (start #~(const #t))))
   #f
   (description "Provide loopback and networking without actually doing
anything.  This service is used by guest systems running in containers, where
networking support is provided by the host.")))

(define %nscd-container-caches
  ;; Similar to %nscd-default-caches but with smaller cache sizes. This allows
  ;; many containers to coexist on the same machine without exhausting RAM.
  (map (lambda (cache)
         (nscd-cache
          (inherit cache)
          (max-database-size (expt 2 18)))) ;256KiB
       %nscd-default-caches))

(define* (containerized-operating-system os mappings
                                         #:key
                                         shared-network?
                                         (extra-file-systems '()))
  "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.  EXTRA-FILE-SYSTEMS is a list of file systems to add to 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)))

  (define services-to-drop
    ;; Service types to filter from the original operating-system. Some of
    ;; these make no sense in a container (e.g., those that access
    ;; /dev/tty[0-9]), while others just need to be reinstantiated with
    ;; different configs that are better suited to containers.
    (append (list console-font-service-type
                  mingetty-service-type
                  agetty-service-type
                  ;; Reinstantiated below with smaller caches.
                  nscd-service-type)
            (if shared-network?
                ;; Replace these with dummy-networking-service-type below.
                (list
                 static-networking-service-type
                 dhcp-client-service-type
                 network-manager-service-type
                 connman-service-type
                 wicd-service-type)
                (list))))

  (define services-to-add
    (append
     ;; Many Guix services depend on a 'networking' shepherd
     ;; service, so make sure to provide a dummy 'networking'
     ;; service when we are sure that networking is already set up
     ;; in the host and can be used.  That prevents double setup.
     (if shared-network?
         (list (service dummy-networking-service-type))
         '())
     (list
      (nscd-service (nscd-configuration
                     (caches %nscd-container-caches))))))

  (operating-system
    (inherit os)
    (swap-devices '()) ; disable swap
    (essential-services (container-essential-services
                         this-operating-system
                         #:shared-network? shared-network?))
    (services (append (remove (lambda (service)
                                (memq (service-kind service)
                                      services-to-drop))
                              (operating-system-user-services os))
                      services-to-add))
    (file-systems (append (map mapping->fs
                               (if shared-network?
                                   (append %network-file-mappings mappings)
                                   mappings))
                          extra-file-systems
                          user-file-systems

                          ;; Provide a dummy root file system so we can create
                          ;; a 'boot-parameters' file.
                          (list (file-system
                                  (mount-point "/")
                                  (device "nothing")
                                  (type "dummy")))))))

(define* (container-script os #:key (mappings '()) shared-network?)
  "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."
  (define (mountable-file-system? file-system)
    ;; Return #t if FILE-SYSTEM should be mounted in the container.
    (and (not (string=? "/" (file-system-mount-point file-system)))
         (file-system-needed-for-boot? file-system)))

  (define (os-file-system-specs os)
    (map file-system->spec
         (filter mountable-file-system?
                 (operating-system-file-systems os))))

  (let* ((os (containerized-operating-system
              os (cons %store-mapping mappings)
              #:shared-network? shared-network?
              #:extra-file-systems %container-file-systems))
         (specs (os-file-system-specs os)))

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

            (define file-systems
              (filter-map (lambda (spec)
                            (let* ((fs    (spec->file-system spec))
                                   (flags (file-system-flags fs)))
                              (and (or (not (memq 'bind-mount flags))
                                       (file-exists? (file-system-device fs)))
                                   fs)))
                          '#$specs))

            (define (explain pid)
              ;; XXX: We can't quite call 'bindtextdomain' so there's actually
              ;; no i18n.
              ;; XXX: Should we really give both options? 'guix container exec'
              ;; is a more verbose command.  Hard to fail to enter the container
              ;; when we list two options.
              (info (G_ "system container is running as PID ~a~%") pid)
              (info (G_ "Run 'sudo guix container exec ~a /run/current-system/profile/bin/bash --login'\n")
                    pid)
              (info (G_ "or run 'sudo nsenter -a -t ~a' to get a shell into it.~%") pid)
              (newline (guix-warning-port)))

            (call-with-container file-systems
              (lambda ()
                (setenv "HOME" "/root")
                (setenv "TMPDIR" "/tmp")
                (setenv "GUIX_NEW_SYSTEM" #$os)
                (for-each mkdir-p '("/run" "/bin" "/etc" "/home" "/var"))
                (primitive-load (string-append #$os "/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
              #:namespaces (if #$shared-network?
                               (delq 'net %namespaces)
                               %namespaces)
              #:process-spawned-hook explain))))

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

(define* (eval/container exp
                         #:key
                         (mappings '())
                         (namespaces %namespaces))
  "Evaluate EXP, a gexp, in a new process executing in separate namespaces as
listed in NAMESPACES.  Add MAPPINGS, a list of <file-system-mapping>, to the
set of directories visible in the process's mount namespace.  Return the
process' exit status as a monadic value.

This is useful to implement processes that, unlike derivations, are not
entirely pure and need to access the outside world or to perform side
effects."
  (mlet %store-monad ((lowered (lower-gexp exp)))
    (define inputs
      (cons (lowered-gexp-guile lowered)
            (lowered-gexp-inputs lowered)))

    (define items
      (append (append-map derivation-input-output-paths inputs)
              (lowered-gexp-sources lowered)))

    (mbegin %store-monad
      (built-derivations inputs)
      (mlet %store-monad ((closure ((store-lift requisites) items)))
        (return (call-with-container (map file-system-mapping->bind-mount
                                          (append (map (lambda (item)
                                                         (file-system-mapping
                                                          (source item)
                                                          (target source)))
                                                       closure)
                                                  mappings))
                  (lambda ()
                    (apply execl
                           (string-append (derivation-input-output-path
                                           (lowered-gexp-guile lowered))
                                          "/bin/guile")
                           "guile"
                           (append (append-map (lambda (directory)
                                                 `("-L" ,directory))
                                               (lowered-gexp-load-path lowered))
                                   (append-map (lambda (directory)
                                                 `("-C" ,directory))
                                               (lowered-gexp-load-compiled-path
                                                lowered))
                                   (list "-c"
                                         (object->string
                                          (lowered-gexp-sexp lowered))))))))))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2017, 2019 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2019, 2020 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 linux-initrd)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module ((guix store)
                #:select (%store-prefix))
  #:use-module ((guix derivations)
                #:select (derivation->output-path))
  #:use-module (guix modules)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages disk)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages file-systems)
  #:use-module (gnu packages guile)
  #:use-module ((gnu packages xorg)
                #:select (console-setup xkeyboard-config))
  #:use-module ((gnu packages make-bootstrap)
                #:select (%guile-static-stripped))
  #:use-module (gnu system file-systems)
  #:use-module (gnu system mapped-devices)
  #:use-module (gnu system keyboard)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 vlist)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (expression->initrd
            %base-initrd-modules
            raw-initrd
            file-system-packages
            base-initrd))

;;; Commentary:
;;;
;;; Tools to build initial RAM disks (initrd's) for Linux-Libre, and in
;;; particular initrd's that run Guile.
;;;
;;; Code:

(define* (expression->initrd exp
                             #:key
                             (guile %guile-static-stripped)
                             (gzip gzip)
                             (name "guile-initrd")
                             (system (%current-system)))
  "Return as a file-like object a Linux initrd (a gzipped cpio archive)
containing GUILE and that evaluates EXP, a G-expression, upon booting.  All
the derivations referenced by EXP are automatically copied to the initrd."

  ;; General Linux overview in `Documentation/early-userspace/README' and
  ;; `Documentation/filesystems/ramfs-rootfs-initramfs.txt'.

  (define init
    (program-file "init" exp #:guile guile))

  (define (import-module? module)
    ;; Since we don't use deduplication support in 'populate-store', don't
    ;; import (guix store deduplication) and its dependencies, which includes
    ;; Guile-Gcrypt.  That way we can run tests with '--bootstrap'.
    (and (guix-module-name? module)
         (not (equal? module '(guix store deduplication)))))

  (define builder
    ;; Do not use "guile-zlib" extension here, otherwise it would drag the
    ;; non-static "zlib" package to the initrd closure.  It is not needed
    ;; anyway because the modules are stored uncompressed within the initrd.
    (with-imported-modules (source-module-closure
                            '((gnu build linux-initrd))
                            #:select? import-module?)
      #~(begin
          (use-modules (gnu build linux-initrd))

          (mkdir #$output)

          ;; The guile used in the initrd must be present in the store, so
          ;; that module loading works once the root is switched.
          ;;
          ;; To ensure that is the case, add an explicit reference to the
          ;; guile package used in the initrd to the output.
          ;;
          ;; This fixes guix-patches bug #28399, "Fix mysql activation, and
          ;; add a basic test".
          (call-with-output-file (string-append #$ output "/references")
            (lambda (port)
              (simple-format port "~A\n" #$guile)))

          (build-initrd (string-append #$output "/initrd.cpio.gz")
                        #:guile #$guile
                        #:init #$init
                        ;; Copy everything INIT refers to into the initrd.
                        #:references-graphs '("closure")
                        #:gzip (string-append #+gzip "/bin/gzip")))))

  (file-append (computed-file name builder
                              #:options
                              `(#:references-graphs (("closure" ,init))))
               "/initrd.cpio.gz"))

(define (flat-linux-module-directory linux modules)
  "Return a flat directory containing the Linux kernel modules listed in
MODULES and taken from LINUX."
  (define imported-modules
    (source-module-closure '((gnu build linux-modules)
                             (guix build utils))))

  (define build-exp
    (with-imported-modules imported-modules
      (with-extensions (list guile-zlib)
        #~(begin
            (use-modules (gnu build linux-modules)
                         (guix build utils)
                         (srfi srfi-1)
                         (srfi srfi-26))

            (define module-dir
              (string-append #$linux "/lib/modules"))

            (define modules
              (let* ((lookup  (cut find-module-file module-dir <>))
                     (modules (map lookup '#$modules)))
                (append modules
                        (recursive-module-dependencies
                         modules
                         #:lookup-module lookup))))

            (define (maybe-uncompress file)
              ;; If FILE is a compressed module, uncompress it, as the initrd
              ;; is already gzipped as a whole.
              (cond
               ((string-contains file ".ko.gz")
                (invoke #+(file-append gzip "/bin/gunzip") file))))

            (mkdir #$output)
            (for-each (lambda (module)
                        (let ((out-module
                               (string-append #$output "/"
                                              (basename module))))
                          (format #t "copying '~a'...~%" module)
                          (copy-file module out-module)
                          (maybe-uncompress out-module)))
                      (delete-duplicates modules))

            ;; Hyphen or underscore?  This database tells us.
            (write-module-name-database #$output)))))

  (computed-file "linux-modules" build-exp))

(define* (raw-initrd file-systems
                      #:key
                      (linux linux-libre)
                      (linux-modules '())
                      (mapped-devices '())
                      (keyboard-layout #f)
                      (helper-packages '())
                      qemu-networking?
                      volatile-root?
                      (on-error 'debug))
  "Return as a file-like object a raw initrd, with kernel
modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
mounted by the initrd, possibly in addition to the root file system specified
on the kernel command line via '--root'. LINUX-MODULES is a list of kernel
modules to be loaded at boot time. MAPPED-DEVICES is a list of device
mappings to realize before FILE-SYSTEMS are mounted.
HELPER-PACKAGES is a list of packages to be copied in the initrd. It may include
e2fsck/static or other packages needed by the initrd to check root partition.

When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
console keyboard layout.  This is done before MAPPED-DEVICES are set up and
before FILE-SYSTEMS are mounted such that, should the user need to enter a
passphrase or use the REPL, this happens using the intended keyboard layout.

When QEMU-NETWORKING? is true, set up networking with the standard QEMU
parameters.

When VOLATILE-ROOT? is true, the root file system is writable but any changes
to it are lost.

ON-ERROR is passed to 'call-with-error-handling'; it determines what happens
upon error."
  (define device-mapping-commands
    ;; List of gexps to open the mapped devices.
    (map (lambda (md)
           (let* ((source  (mapped-device-source md))
                  (targets (mapped-device-targets md))
                  (type    (mapped-device-type md))
                  (open    (mapped-device-kind-open type)))
             (open source targets)))
         mapped-devices))

  (define kodir
    (flat-linux-module-directory linux linux-modules))

  (expression->initrd
   (with-imported-modules (source-module-closure
                           '((gnu build linux-boot)
                             (guix build utils)
                             (guix build bournish)
                             (gnu system file-systems)
                             (gnu build file-systems)))
     #~(begin
         (use-modules (gnu build linux-boot)
                      (gnu system file-systems)
                      ((guix build utils) #:hide (delete))
                      (guix build bournish)   ;add the 'bournish' meta-command
                      (srfi srfi-1)           ;for lvm-device-mapping
                      (srfi srfi-26)

                      ;; FIXME: The following modules are for
                      ;; LUKS-DEVICE-MAPPING.  We should instead propagate
                      ;; this info via gexps.
                      ((gnu build file-systems)
                       #:select (find-partition-by-luks-uuid))
                      (rnrs bytevectors))

         (with-output-to-port (%make-void-port "w")
           (lambda ()
             (set-path-environment-variable "PATH" '("bin" "sbin")
                                            '#$helper-packages)))

         (parameterize ((current-warning-port (%make-void-port "w")))
           (boot-system #:mounts
                        (map spec->file-system
                             '#$(map file-system->spec file-systems))
                        #:pre-mount (lambda ()
                                      (and #$@device-mapping-commands))
                        #:linux-modules '#$linux-modules
                        #:linux-module-directory '#$kodir
                        #:keymap-file #+(and=> keyboard-layout
                                               keyboard-layout->console-keymap)
                        #:qemu-guest-networking? #$qemu-networking?
                        #:volatile-root? '#$volatile-root?
                        #:on-error '#$on-error))))
   #:name "raw-initrd"))

(define* (file-system-packages file-systems #:key (volatile-root? #f))
  "Return the list of statically-linked, stripped packages to check
FILE-SYSTEMS."
  `(,@(if (find (lambda (fs)
                  (string-prefix? "ext" (file-system-type fs)))
                file-systems)
          (list e2fsck/static)
          '())
    ,@(if (find (lambda (fs)
                  (string-suffix? "fat" (file-system-type fs)))
                file-systems)
          (list fatfsck/static)
          '())
    ,@(if (find (file-system-type-predicate "bcachefs") file-systems)
          (list bcachefs-tools/static)
          '())
    ,@(if (find (file-system-type-predicate "btrfs") file-systems)
          (list btrfs-progs/static)
          '())
    ,@(if (find (file-system-type-predicate "jfs") file-systems)
          (list jfs_fsck/static)
          '())
    ,@(if (find (file-system-type-predicate "f2fs") file-systems)
          (list f2fs-fsck/static)
          '())))

(define-syntax vhash                              ;TODO: factorize
  (syntax-rules (=>)
    "Build a vhash with the given key/value mappings."
    ((_)
     vlist-null)
    ((_ (key others ... => value) rest ...)
     (vhash-cons key value
                 (vhash (others ... => value) rest ...)))
    ((_ (=> value) rest ...)
     (vhash rest ...))))

(define-syntax lookup-procedure
  (syntax-rules (else)
    "Return a procedure that lookups keys in the given dictionary."
    ((_ mapping ... (else default))
     (let ((table (vhash mapping ...)))
       (lambda (key)
         (match (vhash-assoc key table)
           (#f            default)
           ((key . value) value)))))))

(define file-system-type-modules
  ;; Given a file system type, return the list of modules it needs.
  (lookup-procedure ("cifs" => '("md4" "ecb" "cifs"))
                    ("9p" => '("9p" "9pnet_virtio"))
                    ("bcachefs" => '("bcachefs"))
                    ("btrfs" => '("btrfs"))
                    ("iso9660" => '("isofs"))
                    ("jfs" => '("jfs"))
                    ("f2fs" => '("f2fs" "crc32_generic"))
                    (else '())))

(define (file-system-modules file-systems)
  "Return the list of Linux modules needed to mount FILE-SYSTEMS."
  (append-map (compose file-system-type-modules file-system-type)
              file-systems))

(define* (default-initrd-modules
           #:optional
           (system (or (%current-target-system)
                       (%current-system))))
  "Return the list of modules included in the initrd by default."
  (define virtio-modules
    ;; Modules for Linux para-virtualized devices, for use in QEMU guests.
    '("virtio_pci" "virtio_balloon" "virtio_blk" "virtio_net"
      "virtio_console" "virtio-rng"))

  `("ahci"                                  ;for SATA controllers
    "usb-storage" "uas"                     ;for the installation image etc.
    "usbhid" "hid-generic" "hid-apple"      ;keyboards during early boot
    "dm-crypt" "xts" "serpent_generic" "wp512" ;for encrypted root partitions
    "nls_iso8859-1"                            ;for `mkfs.fat`, et.al
    ,@(if (string-match "^(x86_64|i[3-6]86)-" system)
          '("pata_acpi" "pata_atiixp"    ;for ATA controllers
            "isci")                      ;for SAS controllers like Intel C602
          '())

    ,@virtio-modules))

(define-syntax %base-initrd-modules
  ;; This more closely matches our naming convention.
  (identifier-syntax (default-initrd-modules)))

(define* (base-initrd file-systems
                      #:key
                      (linux linux-libre)
                      (linux-modules '())
                      (mapped-devices '())
                      (keyboard-layout #f)
                      qemu-networking?
                      volatile-root?
                      (extra-modules '())         ;deprecated
                      (on-error 'debug))
  "Return as a file-like object a generic initrd, with kernel
modules taken from LINUX.  FILE-SYSTEMS is a list of file-systems to be
mounted by the initrd, possibly in addition to the root file system specified
on the kernel command line via '--root'.  MAPPED-DEVICES is a list of device
mappings to realize before FILE-SYSTEMS are mounted.

When true, KEYBOARD-LAYOUT is a <keyboard-layout> record denoting the desired
console keyboard layout.  This is done before MAPPED-DEVICES are set up and
before FILE-SYSTEMS are mounted such that, should the user need to enter a
passphrase or use the REPL, this happens using the intended keyboard layout.

QEMU-NETWORKING? and VOLATILE-ROOT? behaves as in raw-initrd.

The initrd is automatically populated with all the kernel modules necessary
for FILE-SYSTEMS and for the given options.  Additional kernel
modules can be listed in LINUX-MODULES.  They will be added to the initrd, and
loaded at boot time in the order in which they appear."
  (define linux-modules*
    ;; Modules added to the initrd and loaded from the initrd.
    `(,@linux-modules
      ,@(file-system-modules file-systems)
      ,@(if volatile-root?
            '("overlay")
            '())
      ,@extra-modules))

  (define helper-packages
    (append (file-system-packages file-systems
                                  #:volatile-root? volatile-root?)
            (if keyboard-layout
                (list loadkeys-static)
                '())))

  (raw-initrd file-systems
              #:linux linux
              #:linux-modules linux-modules*
              #:mapped-devices mapped-devices
              #:helper-packages helper-packages
              #:keyboard-layout keyboard-layout
              #:qemu-networking? qemu-networking?
              #:volatile-root? volatile-root?
              #:on-error on-error))

;;; linux-initrd.scm ends here

repo_name: maximed/guix

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.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 locale)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix utils)
  #:use-module (gnu packages base)
  #:use-module (gnu packages compression)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:export (locale-definition
            locale-definition?
            locale-definition-name
            locale-definition-source
            locale-definition-charset

            locale-name->definition
            locale-directory

            %default-locale-libcs
            %default-locale-definitions

            glibc-supported-locales))

;;; Commentary:
;;;
;;; Locale definitions, and compilation thereof.
;;;
;;; Code:

(define-record-type* <locale-definition> locale-definition
  make-locale-definition
  locale-definition?
  (name    locale-definition-name)                ;string--e.g., "fr_FR.utf8"
  (source  locale-definition-source)              ;string--e.g., "fr_FR"
  (charset locale-definition-charset              ;string--e.g., "UTF-8"
           (default "UTF-8")))

(define %not-dot
  (char-set-complement (char-set #\.)))

(define (denormalize-codeset codeset)
  "Attempt to guess the \"real\" name of CODESET, a normalized codeset as
defined in (info \"(libc) Using gettextized software\")."
  (cond ((string=? codeset "utf8")
         "UTF-8")
        ((string-prefix? "iso8859" codeset)
         (string-append "ISO-8859-" (string-drop codeset 7)))
        ((string=? codeset "eucjp")
         "EUC-JP")
        (else                                ;cross fingers, hope for the best
         codeset)))

(define (locale-name->definition name)
  "Return a <locale-definition> corresponding to NAME, guessing the charset,
or #f on failure."
  (match (string-tokenize name %not-dot)
    ((source charset)
     ;; XXX: NAME is supposed to use the "normalized codeset", such as "utf8",
     ;; whereas the actual name used is different.  Add a special case to make
     ;; the right guess for UTF-8.
     (locale-definition (name name)
                        (source source)
                        (charset (denormalize-codeset charset))))
    (_
     #f)))

(define* (single-locale-directory locales
                                  #:key (libc glibc))
  "Return a directory containing all of LOCALES for LIBC compiled.

Because locale data formats are incompatible when switching from one libc to
another, locale data is put in a sub-directory named after the 'version' field
of LIBC."
  (define version
    (version-major+minor (package-version libc)))

  (define build
    (with-imported-modules (source-module-closure
                            '((gnu build locale)))
     #~(begin
         (use-modules (gnu build locale))

         (mkdir #$output)
         (mkdir (string-append #$output "/" #$version))

         ;; 'localedef' executes 'gzip' to access compressed locale sources.
         (setenv "PATH"
                 (string-append #+gzip "/bin:" #+libc "/bin"))

         (setvbuf (current-output-port) 'line)
         (setvbuf (current-error-port) 'line)
         (for-each (lambda (locale codeset name)
                     (build-locale locale
                                   #:codeset codeset
                                   #:name name
                                   #:directory
                                   (string-append #$output "/" #$version)))
                   '#$(map locale-definition-source locales)
                   '#$(map locale-definition-charset locales)
                   '#$(map locale-definition-name locales)))))

  (computed-file (string-append "locale-" version) build))

(define* (locale-directory locales
                           #:key (libcs %default-locale-libcs))
  "Return a locale directory containing all of LOCALES for each libc package
listed in LIBCS.

It is useful to list more than one libc when willing to support
already-installed packages built against a different libc since the locale
data format changes between libc versions."
  (match libcs
    ((libc)
     (single-locale-directory locales #:libc libc))
    ((libcs ..1)
     (let ((dirs (map (lambda (libc)
                        (single-locale-directory locales #:libc libc))
                      libcs)))
       (computed-file "locale-multiple-versions"
                      (with-imported-modules '((guix build union))
                        #~(begin
                            (use-modules (guix build union))
                            (union-build #$output (list #$@dirs))))
                      #:options '(#:local-build? #t
                                  #:substitutable? #f))))))

(define %default-locale-libcs
  ;; The libcs for which we build locales by default.
  ;; List the previous and current libc to ease transition.
  (list glibc))

(define %default-locale-definitions
  ;; Arbitrary set of locales that are built by default.  They are here mostly
  ;; to facilitate first-time use to some people, while others may have to add
  ;; a specific <locale-definition>.
  (letrec-syntax ((utf8-locale (syntax-rules ()
                                 ((_ name*)
                                  (locale-definition
                                   ;; Note: We choose "utf8", which is the
                                   ;; "normalized codeset".
                                   (name (string-append name* ".utf8"))
                                   (source name*)
                                   (charset "UTF-8")))))
                  (utf8-locales (syntax-rules ()
                                  ((_ name ...)
                                   (list (utf8-locale name) ...)))))
    ;; Add "en_US.UTF-8" for compatibility with Guix 0.8.
    (cons (locale-definition
           (name "en_US.UTF-8")
           (source "en_US")
           (charset "UTF-8"))
          (utf8-locales "ca_ES"
                        "cs_CZ"
                        "da_DK"
                        "de_DE"
                        "el_GR"
                        "en_AU"
                        "en_CA"
                        "en_GB"
                        "en_US"
                        "es_AR"
                        "es_CL"
                        "es_ES"
                        "es_MX"
                        "fi_FI"
                        "fr_BE"
                        "fr_CA"
                        "fr_CH"
                        "fr_FR"
                        "ga_IE"
                        "it_IT"
                        "ja_JP"
                        "ko_KR"
                        "nb_NO"
                        "nl_NL"
                        "pl_PL"
                        "pt_PT"
                        "ro_RO"
                        "ru_RU"
                        "sv_SE"
                        "tr_TR"
                        "uk_UA"
                        "vi_VN"
                        "zh_CN"))))

;;;
;;; Locales supported by glibc.
;;;

(define* (glibc-supported-locales #:optional (glibc glibc))
  "Return a file-like object that contains a list of locale name/encoding
pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\").  Each pair corresponds to a
locale supported by GLIBC."
  (define build
    (with-imported-modules (source-module-closure
                            '((guix build gnu-build-system)
                              (gnu build locale)))
      #~(begin
          (use-modules (guix build gnu-build-system)
                       (gnu build locale)
                       (ice-9 pretty-print))

          (define unpack
            (assq-ref %standard-phases 'unpack))

          (setenv "PATH"
                  (string-append #+(file-append tar "/bin") ":"
                                 #+(file-append xz "/bin") ":"
                                 #+(file-append gzip "/bin")))
          (unpack #:source #+(package-source glibc))

          (let ((locales (call-with-input-file "localedata/SUPPORTED"
                           read-supported-locales)))
            (call-with-output-file #$output
              (lambda (port)
                (pretty-print locales port)))))))

  (computed-file "glibc-supported-locales.scm" build))

;;; locale.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2017, 2018 Mark H Weaver <mhw@netris.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 mapped-devices)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module ((guix modules) #:hide (file-name->module-name))
  #:use-module (guix i18n)
  #:use-module ((guix diagnostics)
                #:select (source-properties->location
                          formatted-message
                          &fix-hint
                          &error-location))
  #:use-module (guix deprecation)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu system uuid)
  #:autoload   (gnu build file-systems) (find-partition-by-luks-uuid)
  #:autoload   (gnu build linux-modules)
                 (missing-modules)
  #:autoload   (gnu packages cryptsetup) (cryptsetup-static)
  #:autoload   (gnu packages linux) (mdadm-static lvm2-static)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (%mapped-device
            mapped-device
            mapped-device?
            mapped-device-source
            mapped-device-target
            mapped-device-targets
            mapped-device-type
            mapped-device-location

            mapped-device-kind
            mapped-device-kind?
            mapped-device-kind-open
            mapped-device-kind-close
            mapped-device-kind-check

            device-mapping-service-type
            device-mapping-service

            check-device-initrd-modules           ;XXX: needs a better place

            luks-device-mapping
            raid-device-mapping
            lvm-device-mapping))

;;; Commentary:
;;;
;;; This module supports "device mapping", a concept implemented by Linux's
;;; device-mapper.
;;;
;;; Code:

(define-record-type* <mapped-device> %mapped-device
  make-mapped-device
  mapped-device?
  (source    mapped-device-source)                ;string | list of strings
  (targets   mapped-device-targets)               ;list of strings
  (type      mapped-device-type)                  ;<mapped-device-kind>
  (location  mapped-device-location
             (default (current-source-location)) (innate)))

(define-syntax mapped-device-compatibility-helper
  (syntax-rules (target)
    ((_ () (fields ...))
     (%mapped-device fields ...))
    ((_ ((target exp) rest ...) (others ...))
     (%mapped-device others ...
                      (targets (list exp))
                      rest ...))
    ((_ (field rest ...) (others ...))
     (mapped-device-compatibility-helper (rest ...)
                                         (others ... field)))))

(define-syntax-rule (mapped-device fields ...)
  "Build an <mapped-device> record, automatically converting 'target' field
specifications to 'targets'."
  (mapped-device-compatibility-helper (fields ...) ()))

(define-deprecated (mapped-device-target md)
  mapped-device-targets
  (car (mapped-device-targets md)))

(define-record-type* <mapped-device-type> mapped-device-kind
  make-mapped-device-kind
  mapped-device-kind?
  (open      mapped-device-kind-open)             ;source target -> gexp
  (close     mapped-device-kind-close             ;source target -> gexp
             (default (const #~(const #f))))
  (check     mapped-device-kind-check             ;source -> Boolean
             (default (const #t))))

;;;
;;; Device mapping as a Shepherd service.
;;;

(define device-mapping-service-type
  (shepherd-service-type
   'device-mapping
   (match-lambda
     (($ <mapped-device> source targets
                         ($ <mapped-device-type> open close))
      (shepherd-service
       (provision (list (symbol-append 'device-mapping- (string->symbol (string-join targets "-")))))
       (requirement '(udev))
       (documentation "Map a device node using Linux's device mapper.")
       (start #~(lambda () #$(open source targets)))
       (stop #~(lambda _ (not #$(close source targets))))
       (respawn? #f))))
   (description "Map a device node using Linux's device mapper.")))

(define (device-mapping-service mapped-device)
  "Return a service that sets up @var{mapped-device}."
  (service device-mapping-service-type mapped-device))

;;;
;;; Static checks.
;;;

(define (check-device-initrd-modules device linux-modules location)
  "Raise an error if DEVICE needs modules beyond LINUX-MODULES to operate.
DEVICE must be a \"/dev\" file name."
  (define missing
    ;; Attempt to determine missing modules.
    (catch 'system-error
      (lambda ()
        (missing-modules device linux-modules))

      ;; If we can't do that (e.g., EPERM), skip the whole thing.
      (const '())))

  (unless (null? missing)
    ;; Note: What we suggest here is a list of module names (e.g.,
    ;; "usb_storage"), not file names (e.g., "usb-storage.ko").  This is
    ;; OK because we have machinery that accepts both the hyphen and the
    ;; underscore version.
    (raise (make-compound-condition
            (formatted-message (G_ "you may need these modules \
in the initrd for ~a:~{ ~a~}")
                               device missing)
            (condition
             (&fix-hint
              (hint (format #f (G_ "Try adding them to the
@code{initrd-modules} field of your @code{operating-system} declaration, along
these lines:

@example
 (operating-system
   ;; @dots{}
   (initrd-modules (append (list~{ ~s~})
                           %base-initrd-modules)))
@end example

If you think this diagnostic is inaccurate, use the @option{--skip-checks}
option of @command{guix system}.\n")
                            missing))))
            (condition
             (&error-location
              (location (source-properties->location location))))))))

;;;
;;; Common device mappings.
;;;

(define (open-luks-device source targets)
  "Return a gexp that maps SOURCE to TARGET as a LUKS device, using
'cryptsetup'."
  (with-imported-modules (source-module-closure
                          '((gnu build file-systems)))
    (match targets
      ((target)
       #~(let ((source #$(if (uuid? source)
                             (uuid-bytevector source)
                             source)))
           ;; XXX: 'use-modules' should be at the top level.
           (use-modules (rnrs bytevectors) ;bytevector?
                        ((gnu build file-systems)
                         #:select (find-partition-by-luks-uuid)))

           ;; Use 'cryptsetup-static', not 'cryptsetup', to avoid pulling the
           ;; whole world inside the initrd (for when we're in an initrd).
           (zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                           "open" "--type" "luks"

                           ;; Note: We cannot use the "UUID=source" syntax here
                           ;; because 'cryptsetup' implements it by searching the
                           ;; udev-populated /dev/disk/by-id directory but udev may
                           ;; be unavailable at the time we run this.
                           (if (bytevector? source)
                               (or (let loop ((tries-left 10))
                                     (and (positive? tries-left)
                                          (or (find-partition-by-luks-uuid source)
                                              ;; If the underlying partition is
                                              ;; not found, try again after
                                              ;; waiting a second, up to ten
                                              ;; times.  FIXME: This should be
                                              ;; dealt with in a more robust way.
                                              (begin (sleep 1)
                                                     (loop (- tries-left 1))))))
                                   (error "LUKS partition not found" source))
                               source)

                           #$target)))))))

(define (close-luks-device source targets)
  "Return a gexp that closes TARGET, a LUKS device."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append cryptsetup-static "/sbin/cryptsetup")
                       "close" #$target)))))

(define* (check-luks-device md #:key
                            needed-for-boot?
                            (initrd-modules '())
                            #:allow-other-keys
                            #:rest rest)
  "Ensure the source of MD is valid."
  (let ((source   (mapped-device-source md))
        (location (mapped-device-location md)))
    (or (not (zero? (getuid)))
        (if (uuid? source)
            (match (find-partition-by-luks-uuid (uuid-bytevector source))
              (#f
               (raise (make-compound-condition
                       (formatted-message (G_ "no LUKS partition with UUID '~a'")
                                          (uuid->string source))
                       (condition
                        (&error-location
                         (location (source-properties->location
                                    (mapped-device-location md))))))))
              ((? string? device)
               (check-device-initrd-modules device initrd-modules location)))
            (check-device-initrd-modules source initrd-modules location)))))

(define luks-device-mapping
  ;; The type of LUKS mapped devices.
  (mapped-device-kind
   (open open-luks-device)
   (close close-luks-device)
   (check check-luks-device)))

(define (open-raid-device sources targets)
  "Return a gexp that assembles SOURCES (a list of devices) to the RAID device
TARGET (e.g., \"/dev/md0\"), using 'mdadm'."
  (match targets
    ((target)
     #~(let ((sources '#$sources)

             ;; XXX: We're not at the top level here.  We could use a
             ;; non-top-level 'use-modules' form but that doesn't work when the
             ;; code is eval'd, like the Shepherd does.
             (every   (@ (srfi srfi-1) every))
             (format  (@ (ice-9 format) format)))
         (let loop ((attempts 0))
           (unless (every file-exists? sources)
             (when (> attempts 20)
               (error "RAID devices did not show up; bailing out"
                      sources))

             (format #t "waiting for RAID source devices~{ ~a~}...~%"
                     sources)
             (sleep 1)
             (loop (+ 1 attempts))))

         ;; Use 'mdadm-static' rather than 'mdadm' to avoid pulling its whole
         ;; closure (80 MiB) in the initrd when a RAID device is needed for boot.
         (zero? (apply system* #$(file-append mdadm-static "/sbin/mdadm")
                       "--assemble" #$target sources))))))

(define (close-raid-device sources targets)
  "Return a gexp that stops the RAID device TARGET."
  (match targets
    ((target)
     #~(zero? (system* #$(file-append mdadm-static "/sbin/mdadm")
                       "--stop" #$target)))))

(define raid-device-mapping
  ;; The type of RAID mapped devices.
  (mapped-device-kind
   (open open-raid-device)
   (close close-raid-device)))

(define (open-lvm-device source targets)
  #~(and
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgchange" "--activate" "ay" #$source))
     ; /dev/mapper nodes are usually created by udev, but udev may be unavailable at the time we run this. So we create them here.
     (zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                     "vgscan" "--mknodes"))
     (every file-exists? (map (lambda (file) (string-append "/dev/mapper/" file))
                              '#$targets))))

(define (close-lvm-device source targets)
  #~(zero? (system* #$(file-append lvm2-static "/sbin/lvm")
                    "vgchange" "--activate" "n" #$source)))

(define lvm-device-mapping
  (mapped-device-kind
   (open open-lvm-device)
   (close close-lvm-device)))

;;; mapped-devices.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015, 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 nss)
  #:use-module (rnrs enums)
  #:use-module (guix records)
  #:use-module (srfi srfi-9)
  #:use-module (ice-9 match)
  #:export (name-service-switch?
            name-service-switch
            name-service?
            name-service

            lookup-specification

            %default-nss
            %mdns-host-lookup-nss

            %files
            %compat
            %dns

            name-service-switch->string))

;;; Commentary:
;;;
;;; Bindings for libc's name service switch (NSS) configuration.
;;;
;;; Code:

(define-record-type* <name-service> name-service
  make-name-service
  name-service?
  (name     name-service-name)
  (reaction name-service-reaction
            (default (lookup-specification))))

;; Lookup specification (info "(libc) Actions in the NSS Configuration").

(define-enumeration lookup-action
  (return continue)
  make-lookup-action)

(define-enumeration lookup-status
  (success
   not-found
   unavailable
   try-again)
  make-lookup-status)

(define-record-type <lookup-status-negation>
  (lookup-status-negation status)
  lookup-status-negation?
  (status lookup-status-negation-status))

(define-record-type <lookup-reaction>
  (make-lookup-reaction status action)
  lookup-reaction?
  (status  lookup-reaction-status)
  (action  lookup-reaction-action))

(define-syntax lookup-reaction
  (syntax-rules (not =>)
    ((_ ((not status) => action))
     (make-lookup-reaction (lookup-status-negation (lookup-status status))
                           (lookup-action action)))
    ((_ (status => action))
     (make-lookup-reaction (lookup-status status)
                           (lookup-action action)))))

(define-syntax-rule (lookup-specification reaction ...)
  "Return an NSS lookup specification."
  (list (lookup-reaction reaction) ...))

;;;
;;; Common name services and default NSS configuration.
;;;

(define %compat
  ;; Note: Starting from version 2.26, libc no longer provides libnss_compat
  ;; so this specification has become useless.
  (name-service
    (name "compat")
    (reaction (lookup-specification (not-found => return)))))

(define %files
  (name-service (name "files")))

(define %dns
  ;; DNS is supposed to be authoritative, so unless it's unavailable, return
  ;; what it finds.
  (name-service
    (name "dns")
    (reaction (lookup-specification ((not unavailable) => return)))))

;; The NSS.  We list all the databases here because that allows us to
;; statically ensure that the user's configuration refers to existing
;; databases.  See libc/nss/databases.def for the list of databases.  Default
;; values obtained by looking for "DEFAULT_CONFIG" in libc/nss/*.c.
;;
;; Although libc places 'dns' before 'files' in the default configurations of
;; the 'hosts' and 'networks' databases, we choose to put 'files' before 'dns'
;; by default, so that users can override host/address mappings in /etc/hosts
;; and bypass DNS to improve their privacy and escape NSA's MORECOWBELL.
(define-record-type* <name-service-switch> name-service-switch
  make-name-service-switch
  name-service-switch?
  (aliases    name-service-switch-aliases
              (default '()))
  (ethers     name-service-switch-ethers
              (default '()))
  (group      name-service-switch-group
              (default (list %files)))
  (gshadow    name-service-switch-gshadow
              (default '()))
  (hosts      name-service-switch-hosts
              (default (list %files %dns)))
  (initgroups name-service-switch-initgroups
              (default '()))
  (netgroup   name-service-switch-netgroup
              (default '()))
  (networks   name-service-switch-networks
              (default (list %files %dns)))
  (password   name-service-switch-password
              (default (list %files)))
  (public-key name-service-switch-public-key
              (default '()))
  (rpc        name-service-switch-rpc
              (default '()))
  (services   name-service-switch-services
              (default '()))
  (shadow     name-service-switch-shadow
              (default (list %files))))

(define %default-nss
  ;; Default NSS configuration.
  (name-service-switch))

(define %mdns-host-lookup-nss
  (name-service-switch
    (hosts (list %files                           ;first, check /etc/hosts

                 ;; If the above did not succeed, try with 'mdns_minimal'.
                 (name-service
                   (name "mdns_minimal")

                   ;; 'mdns_minimal' is authoritative for '.local'.  When it
                   ;; returns "not found", no need to try the next methods.
                   (reaction (lookup-specification
                              (not-found => return))))

                 ;; Then fall back to DNS.
                 (name-service
                   (name "dns"))

                 ;; Finally, try with the "full" 'mdns'.
                 (name-service
                   (name "mdns"))))))

;;;
;;; Serialization.
;;;

(define (lookup-status->string status)
  (match status
    ('success     "SUCCESS")
    ('not-found   "NOTFOUND")
    ('unavailable "UNAVAIL")
    ('try-again   "TRYAGAIN")
    (($ <lookup-status-negation> status)
     (string-append "!" (lookup-status->string status)))))

(define lookup-reaction->string
  (match-lambda
   (($ <lookup-reaction> status action)
    (string-append (lookup-status->string status) "="
                   (symbol->string action)))))

(define name-service->string
  (match-lambda
   (($ <name-service> name ())
    name)
   (($ <name-service> name reactions)
    (string-append name " ["
                   (string-join (map lookup-reaction->string reactions))
                   "]"))))

(define (name-service-switch->string nss)
  "Return the 'nsswitch.conf' contents for NSS as a string.  See \"NSS
Configuration File\" in the libc manual."
  (let-syntax ((->string
                (syntax-rules ()
                  ((_ name field)
                   (match (field nss)
                     (()                          ;keep the default config
                      "")
                     ((services (... ...))
                      (string-append name ":\t"
                                     (string-join
                                      (map name-service->string services))
                                     "\n")))))))
    (string-append (->string "aliases"    name-service-switch-aliases)
                   (->string "ethers"     name-service-switch-ethers)
                   (->string "group"      name-service-switch-group)
                   (->string "gshadow"    name-service-switch-gshadow)
                   (->string "hosts"      name-service-switch-hosts)
                   (->string "initgroups" name-service-switch-initgroups)
                   (->string "netgroup"   name-service-switch-netgroup)
                   (->string "networks"   name-service-switch-networks)
                   (->string "passwd"     name-service-switch-password)
                   (->string "publickey"  name-service-switch-public-key)
                   (->string "rpc"        name-service-switch-rpc)
                   (->string "services"   name-service-switch-services)
                   (->string "shadow"     name-service-switch-shadow))))

;;; Local Variables:
;;; eval: (put 'name-service 'scheme-indent-function 0)
;;; eval: (put 'name-service-switch 'scheme-indent-function 0)
;;; End:

;;; nss.scm ends here


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system pam)
  #:use-module (guix records)
  #:use-module (guix derivations)
  #:use-module (guix gexp)
  #:use-module (gnu services)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module ((guix utils) #:select (%current-system))
  #:export (pam-service
            pam-service-name
            pam-service-account
            pam-service-auth
            pam-service-password
            pam-service-session

            pam-entry
            pam-entry-control
            pam-entry-module
            pam-entry-arguments

            pam-limits-entry
            pam-limits-entry-domain
            pam-limits-entry-type
            pam-limits-entry-item
            pam-limits-entry-value
            pam-limits-entry->string

            pam-services->directory
            unix-pam-service
            base-pam-services

            session-environment-service
            session-environment-service-type

            pam-root-service-type
            pam-root-service))

;;; Commentary:
;;;
;;; Configuration of the pluggable authentication modules (PAM).
;;;
;;; Code:

;; PAM services (see
;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-file.html>.)
(define-record-type* <pam-service> pam-service
  make-pam-service
  pam-service?
  (name       pam-service-name)                   ; string

  ;; The four "management groups".
  (account    pam-service-account                 ; list of <pam-entry>
              (default '()))
  (auth       pam-service-auth
              (default '()))
  (password   pam-service-password
              (default '()))
  (session    pam-service-session
              (default '())))

(define-record-type* <pam-entry> pam-entry
  make-pam-entry
  pam-entry?
  (control    pam-entry-control)         ; string
  (module     pam-entry-module)          ; file name
  (arguments  pam-entry-arguments        ; list of string-valued g-expressions
              (default '())))

;; PAM limits entries are used by the pam_limits PAM module to set or override
;; limits on system resources for user sessions.  The format is specified
;; here: http://linux-pam.org/Linux-PAM-html/sag-pam_limits.html
(define-record-type <pam-limits-entry>
  (make-pam-limits-entry domain type item value)
  pam-limits-entry?
  (domain     pam-limits-entry-domain)   ; string
  (type       pam-limits-entry-type)     ; symbol
  (item       pam-limits-entry-item)     ; symbol
  (value      pam-limits-entry-value))   ; symbol or number

(define (pam-limits-entry domain type item value)
  "Construct a pam-limits-entry ensuring that the provided values are valid."
  (define (valid? value)
    (case item
      ((priority) (number? value))
      ((nice)     (and (number? value)
                       (>= value -20)
                       (<= value 19)))
      (else       (or (and (number? value)
                           (>= value -1))
                      (member value '(unlimited infinity))))))
  (define items
    (list 'core      'data       'fsize
          'memlock   'nofile     'rss
          'stack     'cpu        'nproc
          'as        'maxlogins  'maxsyslogins
          'priority  'locks      'sigpending
          'msgqueue  'nice       'rtprio))
  (when (not (member type '(hard soft both)))
    (error "invalid limit type" type))
  (when (not (member item items))
    (error "invalid limit item" item))
  (when (not (valid? value))
    (error "invalid limit value" value))
  (make-pam-limits-entry domain type item value))

(define (pam-limits-entry->string entry)
  "Convert a pam-limits-entry record to a string."
  (match entry
    (($ <pam-limits-entry> domain type item value)
     (string-join (list domain
                        (if (eq? type 'both)
                            "-"
                            (symbol->string type))
                        (symbol->string item)
                        (cond
                         ((symbol? value)
                          (symbol->string value))
                         (else
                          (number->string value))))
                  "	"))))

(define (pam-service->configuration service)
  "Return the derivation building the configuration file for SERVICE, to be
dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE."
  (define (entry->gexp type entry)
    (match entry
      (($ <pam-entry> control module (arguments ...))
       #~(format #t "~a ~a ~a ~a~%"
                 #$type #$control #$module
                 (string-join (list #$@arguments))))))

  (match service
    (($ <pam-service> name account auth password session)
     (define builder
       #~(begin
           (with-output-to-file #$output
             (lambda ()
               #$@(append (map (cut entry->gexp "account" <>) account)
                          (map (cut entry->gexp "auth" <>) auth)
                          (map (cut entry->gexp "password" <>) password)
                          (map (cut entry->gexp "session" <>) session))
               #t))))

     (computed-file name builder))))

(define (pam-services->directory services)
  "Return the derivation to build the configuration directory to be used as
/etc/pam.d for SERVICES."
  (let ((names (map pam-service-name services))
        (files (map pam-service->configuration services)))
    (define builder
      #~(begin
          (use-modules (ice-9 match)
                       (srfi srfi-1))

          (mkdir #$output)
          (for-each (match-lambda
                      ((name file)
                       (symlink file (string-append #$output "/" name))))

                    ;; Since <pam-service> objects cannot be compared with
                    ;; 'equal?' since they contain gexps, which contain
                    ;; closures, use 'delete-duplicates' on the build-side
                    ;; instead.  See <http://bugs.gnu.org/20037>.
                    (delete-duplicates '#$(zip names files)))))

    (computed-file "pam.d" builder)))

(define %pam-other-services
  ;; The "other" PAM configuration, which denies everything (see
  ;; <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.)
  (let ((deny (pam-entry
               (control "required")
               (module "pam_deny.so"))))
    (pam-service
     (name "other")
     (account (list deny))
     (auth (list deny))
     (password (list deny))
     (session (list deny)))))

(define unix-pam-service
  (let ((unix (pam-entry
               (control "required")
               (module "pam_unix.so")))
        (env  (pam-entry ; to honor /etc/environment.
               (control "required")
               (module "pam_env.so"))))
    (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd
                   login-uid?)
      "Return a standard Unix-style PAM service for NAME.  When
ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords.  When ALLOW-ROOT? is
true, allow root to run the command without authentication.  When MOTD is
true, it should be a file-like object used as the message-of-the-day.
When LOGIN-UID? is true, require the 'pam_loginuid' module; that module sets
/proc/self/loginuid, which the libc 'getlogin' function relies on."
      ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
      (pam-service
       (name name)
       (account (list unix))
       (auth (append (if allow-root?
                         (list (pam-entry
                                (control "sufficient")
                                (module "pam_rootok.so")))
                         '())
                     (list (if allow-empty-passwords?
                               (pam-entry
                                (control "required")
                                (module "pam_unix.so")
                                (arguments '("nullok")))
                               unix))))
       (password (list (pam-entry
                        (control "required")
                        (module "pam_unix.so")
                        ;; Store SHA-512 encrypted passwords in /etc/shadow.
                        (arguments '("sha512" "shadow")))))
       (session `(,@(if motd
                        (list (pam-entry
                               (control "optional")
                               (module "pam_motd.so")
                               (arguments
                                (list #~(string-append "motd=" #$motd)))))
                        '())
                  ,@(if login-uid?
                        (list (pam-entry       ;to fill in /proc/self/loginuid
                               (control "required")
                               (module "pam_loginuid.so")))
                        '())
                  ,env ,unix))))))

(define (rootok-pam-service command)
  "Return a PAM service for COMMAND such that 'root' does not need to
authenticate to run COMMAND."
  (let ((unix (pam-entry
               (control "required")
               (module "pam_unix.so"))))
    (pam-service
     (name command)
     (account (list unix))
     (auth (list (pam-entry
                  (control "sufficient")
                  (module "pam_rootok.so"))))
     (password (list unix))
     (session (list unix)))))

(define* (base-pam-services #:key allow-empty-passwords?)
  "Return the list of basic PAM services everyone would want."
  ;; TODO: Add other Shadow programs?
  (append (list %pam-other-services)

          ;; These programs are setuid-root.
          (map (cut unix-pam-service <>
                    #:allow-empty-passwords? allow-empty-passwords?)
               '("passwd" "sudo"))
          ;; This is setuid-root, as well.  Allow root to run "su" without
          ;; authenticating.
          (list (unix-pam-service "su"
                                  #:allow-empty-passwords? allow-empty-passwords?
                                  #:allow-root? #t))

          ;; These programs are not setuid-root, and we want root to be able
          ;; to run them without having to authenticate (notably because
          ;; 'useradd' and 'groupadd' are run during system activation.)
          (map rootok-pam-service
               '("useradd" "userdel" "usermod"
                 "groupadd" "groupdel" "groupmod"))))

;;;
;;; System-wide environment variables.
;;;

(define (environment-variables->environment-file vars)
  "Return a file for pam_env(8) that contains environment variables VARS."
  (apply mixed-text-file "environment"
         (append-map (match-lambda
                       ((key . value)
                        (list key "=" value "\n")))
                     vars)))

(define session-environment-service-type
  (service-type
   (name 'session-environment)
   (extensions
    (list (service-extension
           etc-service-type
           (lambda (vars)
             (list `("environment"
                     ,(environment-variables->environment-file vars)))))))
   (compose concatenate)
   (extend append)
   (description
    "Populate @file{/etc/environment}, which is honored by @code{pam_env},
with the specified environment variables.  The value of this service is a list
of name/value pairs for environments variables, such as:

@example
'((\"TZ\" . \"Canada/Pacific\"))
@end example\n")))

(define (session-environment-service vars)
  "Return a service that builds the @file{/etc/environment}, which can be read
by PAM-aware applications to set environment variables for sessions.

VARS should be an association list in which both the keys and the values are
strings or string-valued gexps."
  (service session-environment-service-type vars))

;;;
;;; PAM root service.
;;;

;; Overall PAM configuration: a list of services, plus a procedure that takes
;; one <pam-service> and returns a <pam-service>.  The procedure is used to
;; implement cross-cutting concerns such as the use of the 'elogind.so'
;; session module that keeps track of logged-in users.
(define-record-type* <pam-configuration>
  pam-configuration make-pam-configuration? pam-configuration?
  (services  pam-configuration-services)          ;list of <pam-service>
  (transform pam-configuration-transform))        ;procedure

(define (/etc-entry config)
  "Return the /etc/pam.d entry corresponding to CONFIG."
  (match config
    (($ <pam-configuration> services transform)
     (let ((services (map transform services)))
       `(("pam.d" ,(pam-services->directory services)))))))

(define (extend-configuration initial extensions)
  "Extend INITIAL with NEW."
  (let-values (((services procs)
                (partition pam-service? extensions)))
    (pam-configuration
     (services (append (pam-configuration-services initial)
                       services))
     (transform (apply compose
                       (pam-configuration-transform initial)
                       procs)))))

(define pam-root-service-type
  (service-type (name 'pam)
                (extensions (list (service-extension etc-service-type
                                                     /etc-entry)))

                ;; Arguments include <pam-service> as well as procedures.
                (compose concatenate)
                (extend extend-configuration)
                (description
                 "Configure the Pluggable Authentication Modules (PAM) for all
the specified @dfn{PAM services}.  Each PAM service corresponds to a program,
such as @command{login} or @command{sshd}, and specifies for instance how the
program may authenticate users or what it should do when opening a new
session.")))

(define* (pam-root-service base #:key (transform identity))
  "The \"root\" PAM service, which collects <pam-service> instance and turns
them into a /etc/pam.d directory, including the <pam-service> listed in BASE.
TRANSFORM is a procedure that takes a <pam-service> and returns a
<pam-service>.  It can be used to implement cross-cutting concerns that affect
all the PAM services."
  (service pam-root-service-type
           (pam-configuration (services base)
                              (transform transform))))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system shadow)
  #:use-module ((guix diagnostics) #:select (formatted-message))
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:use-module (guix sets)
  #:use-module (guix ui)
  #:use-module (gnu system accounts)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module ((gnu system file-systems)
                #:select (%tty-gid))
  #:use-module ((gnu packages admin)
                #:select (shadow))
  #:use-module (gnu packages bash)
  #: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)

  ;; Re-export these bindings for backward compatibility.
  #:re-export (user-account
               user-account?
               user-account-name
               user-account-password
               user-account-uid
               user-account-group
               user-account-supplementary-groups
               user-account-comment
               user-account-home-directory
               user-account-create-home-directory?
               user-account-shell
               user-account-system?

               user-group
               user-group?
               user-group-name
               user-group-password
               user-group-id
               user-group-system?)

  #:export (default-skeletons
            skeleton-directory
            %base-groups
            %base-user-accounts

            account-service-type
            account-service))

;;; Commentary:
;;;
;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
;;;
;;; Code:

;; Change the default shell used by new <user-account> records.
(default-shell (file-append bash "/bin/bash"))

(define %base-groups
  ;; Default set of groups.
  (let-syntax ((system-group (syntax-rules ()
                               ((_ args ...)
                                (user-group (system? #t) args ...)))))
    (list (system-group (name "root") (id 0))
          (system-group (name "wheel"))           ; root-like users
          (system-group (name "users"))           ; normal users
          (system-group (name "nogroup"))         ; for daemons etc.

          ;; The following groups are conventionally used by things like udev to
          ;; control access to hardware devices.
          (system-group (name "tty") (id %tty-gid))
          (system-group (name "dialout"))
          (system-group (name "kmem"))
          (system-group (name "input"))           ; input devices, from udev
          (system-group (name "video"))
          (system-group (name "audio"))
          (system-group (name "netdev"))          ; used in avahi-dbus.conf
          (system-group (name "lp"))
          (system-group (name "disk"))
          (system-group (name "floppy"))
          (system-group (name "cdrom"))
          (system-group (name "tape"))
          (system-group (name "kvm")))))          ; for /dev/kvm

(define %base-user-accounts
  ;; List of standard user accounts.  Note that "root" is a special case, so
  ;; it's not listed here.
  (list (user-account
         (name "nobody")
         (uid 65534)
         (group "nogroup")
         (shell (file-append shadow "/sbin/nologin"))
         (home-directory "/nonexistent")
         (create-home-directory? #f)
         (system? #t))))

(define (default-skeletons)
  "Return the default skeleton files for /etc/skel.  These files are copied by
'useradd' in the home directory of newly created user accounts."

  (let ((profile (plain-file "bash_profile" "\
# Honor per-interactive-shell startup file
if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
        (bashrc  (plain-file "bashrc" "\
# Bash initialization for interactive non-login shells and
# for remote shells (info \"(bash) Bash Startup Files\").

# Export 'SHELL' to child processes.  Programs such as 'screen'
# honor it and otherwise use /bin/sh.
export SHELL

if [[ $- != *i* ]]
then
    # We are being invoked from a non-interactive shell.  If this
    # is an SSH session (as in \"ssh host command\"), source
    # /etc/profile so we get PATH and other essential variables.
    [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile

    # Don't do anything else.
    return
fi

# Source the system-wide file.
source /etc/bashrc

# Adjust the prompt depending on whether we're in 'guix environment'.
if [ -n \"$GUIX_ENVIRONMENT\" ]
then
    PS1='\\u@\\h \\w [env]\\$ '
else
    PS1='\\u@\\h \\w\\$ '
fi
alias ls='ls -p --color=auto'
alias ll='ls -l'
alias grep='grep --color=auto'\n"))
        (zprofile    (plain-file "zprofile" "\
# Honor system-wide environment variables
source /etc/profile\n"))
        (xdefaults (plain-file "Xdefaults" "\
XTerm*utf8: always
XTerm*metaSendsEscape: true\n"))
        (gdbinit   (plain-file "gdbinit" "\
# Tell GDB where to look for separate debugging files.
set debug-file-directory ~/.guix-profile/lib/debug

# Authorize extensions found in the store, such as the
# pretty-printers of libstdc++.
set auto-load safe-path /gnu/store/*/lib\n")))
    `((".bash_profile" ,profile)
      (".bashrc" ,bashrc)
      ;; Zsh sources ~/.zprofile before ~/.zshrc, and it sources ~/.zlogin
      ;; after ~/.zshrc.  To avoid interfering with any customizations a user
      ;; may have made in their ~/.zshrc, put this in .zprofile, not .zlogin.
      (".zprofile" ,zprofile)
      (".nanorc" ,(plain-file "nanorc" "\
# Include all the syntax highlighting modules.
include /run/current-system/profile/share/nano/*.nanorc\n"))
      (".Xdefaults" ,xdefaults)
      (".guile" ,(plain-file "dot-guile"
                             "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
       =>
       (lambda (module)
         ;; Enable completion and input history at the REPL.
         ((module-ref module 'activate-readline))))
      (else
       (display \"Consider installing the 'guile-readline' package for
convenient interactive line editing and input history.\\n\\n\")))

      (unless (getenv \"INSIDE_EMACS\")
        (cond ((false-if-exception (resolve-interface '(ice-9 colorized)))
               =>
               (lambda (module)
                 ;; Enable completion and input history at the REPL.
                 ((module-ref module 'activate-colorized))))
              (else
               (display \"Consider installing the 'guile-colorized' package
for a colorful Guile experience.\\n\\n\"))))\n"))
      (".gdbinit" ,gdbinit))))

(define (skeleton-directory skeletons)
  "Return a directory containing SKELETONS, a list of name/derivation tuples."
  (computed-file "skel"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (ice-9 match)
                                    (guix build utils))

                       (mkdir #$output)
                       (chdir #$output)

                       ;; Note: copy the skeletons instead of symlinking
                       ;; them like 'file-union' does, because 'useradd'
                       ;; would just copy the symlinks as is.
                       (for-each (match-lambda
                                   ((target source)
                                    (copy-recursively source target)))
                                 '#$skeletons)
                       ;; Make nanorc respect XDG_CONFIG_HOME.
                       (when (file-exists? ".nanorc")
                         (mkdir-p ".config/nano")
                         (rename-file ".nanorc" ".config/nano/nanorc"))
                       #t))))

(define (find-duplicates list)
  "Find duplicate entries in @var{list}.
Two entries are considered duplicates, if they are @code{equal?} to each other.
This implementation is made asymptotically faster than @code{delete-duplicates}
through the internal use of hash tables."
  (let loop ((list list)
             ;; We actually modify table in-place, but still allocate it here
             ;; so that we only need one level of indentation.
             (table (make-hash-table)))
    (match list
      (()
       (hash-fold (lambda (key value seed)
                    (if (> value 1)
                        (cons key seed)
                        seed))
                  '()
                  table))
      ((first . rest)
       (hash-set! table first
                  (1+ (hash-ref table first 0)))
       (loop rest table)))))

(define (assert-unique-account-names users)
  (match (find-duplicates (map user-account-name users))
    (() *unspecified*)
    (duplicates
     (warning
      (G_ "the following accounts appear more than once:~{ ~a~}~%")
      duplicates))))

(define (assert-unique-group-names groups)
  (match (find-duplicates (map user-group-name groups))
    (() *unspecified*)
    (duplicates
     (warning
      (G_ "the following groups appear more than once:~{ ~a~}~%")
      duplicates))))

(define (assert-valid-users/groups users groups)
  "Raise an error if USERS refer to groups not listed in GROUPS."
  (let ((groups (list->set (map user-group-name groups))))
    (define (validate-supplementary-group user group)
      (unless (set-contains? groups group)
        (raise (condition
                (&message
                 (message
                  (format #f (G_ "supplementary group '~a' \
of user '~a' is undeclared")
                          group
                          (user-account-name user))))))))

    (for-each (lambda (user)
                (unless (set-contains? groups (user-account-group user))
                  (raise (condition
                          (&message
                           (message
                            (format #f (G_ "primary group '~a' \
of user '~a' is undeclared")
                                    (user-account-group user)
                                    (user-account-name user)))))))

                (for-each (cut validate-supplementary-group user <>)
                          (user-account-supplementary-groups user)))
              users)))

;;;
;;; Service.
;;;

(define (user-group->gexp group)
  "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
'active-groups'."
  #~(list #$(user-group-name group)
          #$(user-group-password group)
          #$(user-group-id group)
          #$(user-group-system? group)))

(define (user-account->gexp account)
  "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
'activate-users'."
  #~`(#$(user-account-name account)
      #$(user-account-uid account)
      #$(user-account-group account)
      #$(user-account-supplementary-groups account)
      #$(user-account-comment account)
      #$(user-account-home-directory account)
      #$(user-account-create-home-directory? account)
      ,#$(user-account-shell account)             ; this one is a gexp
      #$(user-account-password account)
      #$(user-account-system? account)))

(define (account-activation accounts+groups)
  "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
<user-group> objects.  Raise an error if a user account refers to a undefined
group."
  (define accounts
    (delete-duplicates (filter user-account? accounts+groups) eq?))

  (define user-specs
    (map user-account->gexp accounts))

  (define groups
    (delete-duplicates (filter user-group? accounts+groups) eq?))

  (define group-specs
    (map user-group->gexp groups))

  (assert-unique-account-names accounts)
  (assert-unique-group-names groups)
  (assert-valid-users/groups accounts groups)

  ;; Add users and user groups.
  (with-imported-modules (source-module-closure '((gnu system accounts)))
    #~(begin
        (use-modules (gnu system accounts))

        (activate-users+groups (map sexp->user-account (list #$@user-specs))
                               (map sexp->user-group (list #$@group-specs))))))

(define (account-shepherd-service accounts+groups)
  "Return a Shepherd service that creates the home directories for the user
accounts among ACCOUNTS+GROUPS."
  (define accounts
    (filter user-account? accounts+groups))

  ;; Create home directories only once 'file-systems' is up.  This makes sure
  ;; they are created in the right place if /home lives on a separate
  ;; partition.
  ;;
  ;; XXX: We arrange for this service to stop right after it's done its job so
  ;; that 'guix system reconfigure' knows that it can reload it fearlessly
  ;; (and thus create new home directories).
  (list (shepherd-service
         (requirement '(file-systems))
         (provision '(user-homes))
         (one-shot? #t)
         (modules '((gnu build activation)
                    (gnu system accounts)))
         (start (with-imported-modules (source-module-closure
                                        '((gnu build activation)
                                          (gnu system accounts)))
                  #~(lambda ()
                      (activate-user-home
                       (map sexp->user-account
                            (list #$@(map user-account->gexp accounts))))
                      #t)))                       ;success
         (documentation "Create user home directories."))))

(define (shells-file shells)
  "Return a file-like object that builds a shell list for use as /etc/shells
based on SHELLS.  /etc/shells is used by xterm, polkit, and other programs."
  (computed-file "shells"
                 #~(begin
                     (use-modules (srfi srfi-1))

                     (define shells
                       (delete-duplicates (list #$@shells)))

                     (call-with-output-file #$output
                       (lambda (port)
                         (display "\
/bin/sh
/run/current-system/profile/bin/sh
/run/current-system/profile/bin/bash\n" port)
                         (for-each (lambda (shell)
                                     (display shell port)
                                     (newline port))
                                   shells))))))
(define (etc-files arguments)
  "Filter out among ARGUMENTS things corresponding to skeletons, and return
the /etc/skel directory for those."
  (let ((skels (filter pair? arguments))
        (users (filter user-account? arguments)))
    `(("skel" ,(skeleton-directory skels))
      ("shells" ,(shells-file (map user-account-shell users))))))

(define account-service-type
  (service-type (name 'account)

                ;; Concatenate <user-account>, <user-group>, and skeleton
                ;; lists.
                (compose concatenate)
                (extend append)

                (extensions
                 (list (service-extension activation-service-type
                                          account-activation)
                       (service-extension shepherd-root-service-type
                                          account-shepherd-service)
                       ;; Have 'user-processes' depend on 'user-homes' so that
                       ;; daemons start after their home directory has been
                       ;; created.
                       (service-extension user-processes-service-type
                                          (const '(user-homes)))
                       (service-extension etc-service-type
                                          etc-files)))
                (description
                 "Ensure the specified user accounts and groups exist, as well
as each account home directory.")))

(define (account-service accounts+groups skeletons)
  "Return a <service> that takes care of user accounts and user groups, with
ACCOUNTS+GROUPS as its initial list of accounts and groups."
  (service account-service-type
           (append skeletons accounts+groups)))

;;; shadow.scm ends here