gnu/system/nss.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu system nss)
  20   #:use-module (rnrs enums)
  21   #:use-module (guix records)
  22   #:use-module (srfi srfi-9)
  23   #:use-module (ice-9 match)
  24   #:export (name-service-switch?
  25             name-service-switch
  26             name-service?
  27             name-service
  28
  29             lookup-specification
  30
  31             %default-nss
  32             %mdns-host-lookup-nss
  33
  34             %files
  35             %compat
  36             %dns
  37
  38             name-service-switch->string))
  39
  40 ;;; Commentary:
  41 ;;;
  42 ;;; Bindings for libc's name service switch (NSS) configuration.
  43 ;;;
  44 ;;; Code:
  45
  46 (define-record-type* <name-service> name-service
  47   make-name-service
  48   name-service?
  49   (name     name-service-name)
  50   (reaction name-service-reaction
  51             (default (lookup-specification))))
  52
  53 ;; Lookup specification (info "(libc) Actions in the NSS Configuration").
  54
  55 (define-enumeration lookup-action
  56   (return continue)
  57   make-lookup-action)
  58
  59 (define-enumeration lookup-status
  60   (success
  61    not-found
  62    unavailable
  63    try-again)
  64   make-lookup-status)
  65
  66 (define-record-type <lookup-status-negation>
  67   (lookup-status-negation status)
  68   lookup-status-negation?
  69   (status lookup-status-negation-status))
  70
  71 (define-record-type <lookup-reaction>
  72   (make-lookup-reaction status action)
  73   lookup-reaction?
  74   (status  lookup-reaction-status)
  75   (action  lookup-reaction-action))
  76
  77 (define-syntax lookup-reaction
  78   (syntax-rules (not =>)
  79     ((_ ((not status) => action))
  80      (make-lookup-reaction (lookup-status-negation (lookup-status status))
  81                            (lookup-action action)))
  82     ((_ (status => action))
  83      (make-lookup-reaction (lookup-status status)
  84                            (lookup-action action)))))
  85
  86 (define-syntax-rule (lookup-specification reaction ...)
  87   "Return an NSS lookup specification."
  88   (list (lookup-reaction reaction) ...))
  89
  90 \f
  91 ;;;
  92 ;;; Common name services and default NSS configuration.
  93 ;;;
  94
  95 (define %compat
  96   (name-service
  97     (name "compat")
  98     (reaction (lookup-specification (not-found => return)))))
  99
 100 (define %files
 101   (name-service (name "files")))
 102
 103 (define %dns
 104   ;; DNS is supposed to be authoritative, so unless it's unavailable, return
 105   ;; what it finds.
 106   (name-service
 107     (name "dns")
 108     (reaction (lookup-specification ((not unavailable) => return)))))
 109
 110 ;; The NSS.  We list all the databases here because that allows us to
 111 ;; statically ensure that the user's configuration refers to existing
 112 ;; databases.  See libc/nss/databases.def for the list of databases.  Default
 113 ;; values obtained by looking for "DEFAULT_CONFIG" in libc/nss/*.c.
 114 ;;
 115 ;; Although libc places 'dns' before 'files' in the default configurations of
 116 ;; the 'hosts' and 'networks' databases, we choose to put 'files' before 'dns'
 117 ;; by default, so that users can override host/address mappings in /etc/hosts
 118 ;; and bypass DNS to improve their privacy and escape NSA's MORECOWBELL.
 119 (define-record-type* <name-service-switch> name-service-switch
 120   make-name-service-switch
 121   name-service-switch?
 122   (aliases    name-service-switch-aliases
 123               (default '()))
 124   (ethers     name-service-switch-ethers
 125               (default '()))
 126   (group      name-service-switch-group
 127               (default (list %compat %files)))
 128   (gshadow    name-service-switch-gshadow
 129               (default '()))
 130   (hosts      name-service-switch-hosts
 131               (default (list %files %dns)))
 132   (initgroups name-service-switch-initgroups
 133               (default '()))
 134   (netgroup   name-service-switch-netgroup
 135               (default '()))
 136   (networks   name-service-switch-networks
 137               (default (list %files %dns)))
 138   (password   name-service-switch-password
 139               (default (list %compat %files)))
 140   (public-key name-service-switch-public-key
 141               (default '()))
 142   (rpc        name-service-switch-rpc
 143               (default '()))
 144   (services   name-service-switch-services
 145               (default '()))
 146   (shadow     name-service-switch-shadow
 147               (default (list %compat %files))))
 148
 149 (define %default-nss
 150   ;; Default NSS configuration.
 151   (name-service-switch))
 152
 153 (define %mdns-host-lookup-nss
 154   (name-service-switch
 155     (hosts (list %files                           ;first, check /etc/hosts
 156
 157                  ;; If the above did not succeed, try with 'mdns_minimal'.
 158                  (name-service
 159                    (name "mdns_minimal")
 160
 161                    ;; 'mdns_minimal' is authoritative for '.local'.  When it
 162                    ;; returns "not found", no need to try the next methods.
 163                    (reaction (lookup-specification
 164                               (not-found => return))))
 165
 166                  ;; Then fall back to DNS.
 167                  (name-service
 168                    (name "dns"))
 169
 170                  ;; Finally, try with the "full" 'mdns'.
 171                  (name-service
 172                    (name "mdns"))))))
 173
 174 \f
 175 ;;;
 176 ;;; Serialization.
 177 ;;;
 178
 179 (define (lookup-status->string status)
 180   (match status
 181     ('success     "SUCCESS")
 182     ('not-found   "NOTFOUND")
 183     ('unavailable "UNAVAIL")
 184     ('try-again   "TRYAGAIN")
 185     (($ <lookup-status-negation> status)
 186      (string-append "!" (lookup-status->string status)))))
 187
 188 (define lookup-reaction->string
 189   (match-lambda
 190    (($ <lookup-reaction> status action)
 191     (string-append (lookup-status->string status) "="
 192                    (symbol->string action)))))
 193
 194 (define name-service->string
 195   (match-lambda
 196    (($ <name-service> name ())
 197     name)
 198    (($ <name-service> name reactions)
 199     (string-append name " ["
 200                    (string-join (map lookup-reaction->string reactions))
 201                    "]"))))
 202
 203 (define (name-service-switch->string nss)
 204   "Return the 'nsswitch.conf' contents for NSS as a string.  See \"NSS
 205 Configuration File\" in the libc manual."
 206   (let-syntax ((->string
 207                 (syntax-rules ()
 208                   ((_ name field)
 209                    (match (field nss)
 210                      (()                          ;keep the default config
 211                       "")
 212                      ((services (... ...))
 213                       (string-append name ":\t"
 214                                      (string-join
 215                                       (map name-service->string services))
 216                                      "\n")))))))
 217     (string-append (->string "aliases"    name-service-switch-aliases)
 218                    (->string "ethers"     name-service-switch-ethers)
 219                    (->string "group"      name-service-switch-group)
 220                    (->string "gshadow"    name-service-switch-gshadow)
 221                    (->string "hosts"      name-service-switch-hosts)
 222                    (->string "initgroups" name-service-switch-initgroups)
 223                    (->string "netgroup"   name-service-switch-netgroup)
 224                    (->string "networks"   name-service-switch-networks)
 225                    (->string "passwd"     name-service-switch-password)
 226                    (->string "publickey"  name-service-switch-public-key)
 227                    (->string "rpc"        name-service-switch-rpc)
 228                    (->string "services"   name-service-switch-services)
 229                    (->string "shadow"     name-service-switch-shadow))))
 230
 231 ;;; Local Variables:
 232 ;;; eval: (put 'name-service 'scheme-indent-function 0)
 233 ;;; eval: (put 'name-service-switch 'scheme-indent-function 0)
 234 ;;; End:
 235
 236 ;;; nss.scm ends here