04/06: system: Add bindings to configure libc's NSS.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 996ed73948e92eb2005a2a282856753d707f452c
Author: Ludovic Courtès <address@hidden>
Date:   Wed Feb 4 21:58:15 2015 +0100

    system: Add bindings to configure libc's NSS.
    
    * gnu/system/nss.scm: New file.
    * gnu-system.am (GNU_SYSTEM_MODULES): Add it.
    * gnu.scm (%public-modules): Add it.
    * gnu/system.scm (<operating-system>)[name-service-switch]: New field.
      (etc-directory): Add #:nss parameter and honor it.
      (operating-system-etc-directory): Adjust call accordingly.
    * doc/guix.texi (operating-system Reference): Document
      'name-service-switch'.
      (Name Service Switch): New section.
---
 doc/guix.texi      |  116 ++++++++++++++++++++++++++++
 gnu-system.am      |    1 +
 gnu.scm            |    3 +-
 gnu/system.scm     |   10 ++-
 gnu/system/nss.scm |  213 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 338 insertions(+), 5 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index fa3aa6d..e489d41 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -142,6 +142,7 @@ System Configuration
 * Locales::                     Language and cultural convention settings.
 * Services::                    Specifying system services.
 * Setuid Programs::             Programs running with root privileges.
+* Name Service Switch::         Configuring libc's name service switch.
 * Initial RAM Disk::            Linux-Libre bootstrapping.
 * GRUB Configuration::          Configuring the boot loader.
 * Invoking guix system::        Instantiating a system configuration.
@@ -3642,6 +3643,7 @@ instance to support new system services.
 * Locales::                     Language and cultural convention settings.
 * Services::                    Specifying system services.
 * Setuid Programs::             Programs running with root privileges.
+* Name Service Switch::         Configuring libc's name service switch.
 * Initial RAM Disk::            Linux-Libre bootstrapping.
 * GRUB Configuration::          Configuring the boot loader.
 * Invoking guix system::        Instantiating a system configuration.
@@ -3827,6 +3829,11 @@ Library Reference Manual}).  @xref{Locales}, for more 
information.
 The list of locale definitions to be compiled and that may be used at
 run time.  @xref{Locales}.
 
address@hidden @code{name-service-switch} (default: @var{%default-nss})
+Configuration of libc's name service switch (NSS)---a
address@hidden<name-service-switch>} object.  @xref{Name Service Switch}, for
+details.
+
 @item @code{services} (default: @var{%base-services})
 A list of monadic values denoting system services.  @xref{Services}.
 
@@ -4648,6 +4655,115 @@ Under the hood, the actual setuid programs are created 
in the
 files in this directory refer to the ``real'' binaries, which are in the
 store.
 
address@hidden Name Service Switch
address@hidden Name Service Switch
+
address@hidden name service switch
address@hidden NSS
+The @code{(gnu system nss)} module provides bindings to the
+configuration file of libc's @dfn{name service switch} or @dfn{NSS}
+(@pxref{NSS Configuration File,,, libc, The GNU C Library Reference
+Manual}).  In a nutshell, the NSS is a mechanism that allows libc to be
+extended with new ``name'' lookup methods for system databases, which
+includes host names, service names, user accounts, and more (@pxref{Name
+Service Switch, System Databases and Name Service Switch,, libc, The GNU
+C Library Reference Manual}).
+
+The NSS configuration specifies, for each system database, which lookup
+method is to be used, and how the various methods are chained
+together---for instance, under which circumstances NSS should try the
+next method in the list.  The NSS configuration is given in the
address@hidden field of @code{operating-system} declarations
+(@pxref{operating-system Reference, @code{name-service-switch}}).
+
address@hidden See <http://0pointer.de/lennart/projects/nss-mdns/>.
+As an example, the declaration below configures the NSS to use the
address@hidden back-end for host name lookups:
+
address@hidden
+(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")))))
address@hidden example
+
+The reference for name service switch configuration is given below.  It
+is a direct mapping of the C library's configuration file format, so
+please refer to the C library manual for more information (@pxref{NSS
+Configuration File,,, libc, The GNU C Library Reference Manual}).
+Compared to libc's NSS configuration file format, it has the advantage
+not only of adding this warm parenthetic feel that we like, but also
+static checks: you'll know about syntax errors and typos as soon as you
+run @command{guix system}.
+
address@hidden {Scheme Variable} %default-nss
+This is the default name service switch configuration, a
address@hidden object.
address@hidden defvr
+
address@hidden {Data Type} name-service-switch
+
+This is the data type representation the configuration of libc's name
+service switch (NSS).  Each field below represents one of the supported
+system databases.
+
address@hidden @code
address@hidden aliases
address@hidden ethers
address@hidden group
address@hidden gshadow
address@hidden hosts
address@hidden initgroups
address@hidden netgroup
address@hidden networks
address@hidden password
address@hidden public-key
address@hidden rpc
address@hidden services
address@hidden shadow
+The system databases handled by the NSS.  Each of these fields must be a
+list of @code{<name-service>} objects (see below.)
address@hidden table
address@hidden deftp
+
address@hidden {Data Type} name-service
+
+This is the data type representing an actual name service and the
+associated lookup action.
+
address@hidden @code
address@hidden name
+A string denoting the name service (@pxref{Services in the NSS
+configuration,,, libc, The GNU C Library Reference Manual}).
+
address@hidden reaction
+An action specified using the @code{lookup-specification} macro
+(@pxref{Actions in the NSS configuration,,, libc, The GNU C Library
+Reference Manual}).  For example:
+
address@hidden
+(lookup-specification (unavailable => continue)
+                      (success => return))
address@hidden example
address@hidden table
address@hidden deftp
 
 @node Initial RAM Disk
 @subsection Initial RAM Disk
diff --git a/gnu-system.am b/gnu-system.am
index f9abc97..ae47993 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -316,6 +316,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/system/linux.scm                         \
   gnu/system/linux-initrd.scm                  \
   gnu/system/locale.scm                                \
+  gnu/system/nss.scm                           \
   gnu/system/shadow.scm                                \
   gnu/system/vm.scm                            \
                                                \
diff --git a/gnu.scm b/gnu.scm
index d9b9117..e3147b3 100644
--- a/gnu.scm
+++ b/gnu.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Joshua S. Grant <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -37,6 +37,7 @@
         (gnu system linux)                        ; 'base-pam-services'
         (gnu system shadow)                       ; 'user-account'
         (gnu system linux-initrd)
+        (gnu system nss)
         (gnu services)
         (gnu services base)
         (gnu packages)
diff --git a/gnu/system.scm b/gnu/system.scm
index b3c5cd8..3fe7833 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -47,6 +47,7 @@
   #:use-module (gnu services base)
   #:use-module (gnu system grub)
   #:use-module (gnu system shadow)
+  #:use-module (gnu system nss)
   #:use-module (gnu system locale)
   #:use-module (gnu system linux)
   #:use-module (gnu system linux-initrd)
@@ -137,6 +138,8 @@
             (default "en_US.utf8"))
   (locale-definitions operating-system-locale-definitions ; list of 
<locale-definition>
                       (default %default-locale-definitions))
+  (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))
@@ -408,7 +411,7 @@ settings for 'guix.el' to work out-of-the-box."
                         (skeletons '())
                         (pam-services '())
                         (profile "/run/current-system/profile")
-                        hosts-file
+                        hosts-file nss
                         (sudoers ""))
   "Return a derivation that builds the static part of the /etc directory."
   (mlet* %store-monad
@@ -422,10 +425,8 @@ settings for 'guix.el' to work out-of-the-box."
 /run/current-system/profile/bin/bash\n"))
        (emacs      (emacs-site-directory))
        (issue      (text-file "issue" issue))
-
-       ;; For now, generate a basic config so that /etc/hosts is honored.
        (nsswitch   (text-file "nsswitch.conf"
-                              "hosts: files dns\n"))
+                              (name-service-switch->string nss)))
 
        ;; Startup file for POSIX-compliant login shells, which set system-wide
        ;; environment variables.
@@ -518,6 +519,7 @@ export ASPELL_CONF=\"dict-dir 
$HOME/.guix-profile/lib/aspell\"
                   #:skeletons skeletons
                   #:issue (operating-system-issue os)
                   #:locale (operating-system-locale os)
+                  #:nss (operating-system-name-service-switch os)
                   #:timezone (operating-system-timezone os)
                   #:hosts-file /etc/hosts
                   #:sudoers (operating-system-sudoers os)
diff --git a/gnu/system/nss.scm b/gnu/system/nss.scm
new file mode 100644
index 0000000..ec2d251
--- /dev/null
+++ b/gnu/system/nss.scm
@@ -0,0 +1,213 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 Ludovic Courtès <address@hidden>
+;;;
+;;; 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
+            %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
+  (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 %compat %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 %compat %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 %compat %files))))
+
+(define %default-nss
+  ;; Default NSS configuration.
+  (name-service-switch))
+
+
+;;;
+;;; 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