~ruther/guix-local

996ed73948e92eb2005a2a282856753d707f452c — Ludovic Courtès 11 years ago ffd74de
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.
5 files changed, 338 insertions(+), 5 deletions(-)

M doc/guix.texi
M gnu-system.am
M gnu.scm
M gnu/system.scm
A gnu/system/nss.scm
M doc/guix.texi => doc/guix.texi +116 -0
@@ 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}.

@item @code{name-service-switch} (default: @var{%default-nss})
Configuration of libc's name service switch (NSS)---a
@code{<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.

@node Name Service Switch
@subsection Name Service Switch

@cindex name service switch
@cindex 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
@code{name-service-switch} field of @code{operating-system} declarations
(@pxref{operating-system Reference, @code{name-service-switch}}).

@c See <http://0pointer.de/lennart/projects/nss-mdns/>.
As an example, the declaration below configures the NSS to use the
@code{nss-mdns} back-end for host name lookups:

@example
(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")))))
@end 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}.

@defvr {Scheme Variable} %default-nss
This is the default name service switch configuration, a
@code{name-service-switch} object.
@end defvr

@deftp {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.

@table @code
@item aliases
@itemx ethers
@itemx group
@itemx gshadow
@itemx hosts
@itemx initgroups
@itemx netgroup
@itemx networks
@itemx password
@itemx public-key
@itemx rpc
@itemx services
@itemx shadow
The system databases handled by the NSS.  Each of these fields must be a
list of @code{<name-service>} objects (see below.)
@end table
@end deftp

@deftp {Data Type} name-service

This is the data type representing an actual name service and the
associated lookup action.

@table @code
@item name
A string denoting the name service (@pxref{Services in the NSS
configuration,,, libc, The GNU C Library Reference Manual}).

@item 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:

@example
(lookup-specification (unavailable => continue)
                      (success => return))
@end example
@end table
@end deftp

@node Initial RAM Disk
@subsection Initial RAM Disk

M gnu-system.am => gnu-system.am +1 -0
@@ 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				\
						\

M gnu.scm => gnu.scm +2 -1
@@ 1,5 1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Joshua S. Grant <jgrant@parenthetical.io>
;;;
;;; 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)

M gnu/system.scm => gnu/system.scm +6 -4
@@ 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)

A gnu/system/nss.scm => gnu/system/nss.scm +213 -0
@@ 0,0 1,213 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 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
            %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