projects/guix·blob python-team · refs

250 lines · 8.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015, 2018 Ludovic Courtès <[email protected]>
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;;; Commentary:
20;;;
21;;; Bindings for libc's name service switch (NSS) configuration.
22;;;
23;;; Code:
24
25(define-module (gnu system nss)
26 #:use-module (rnrs enums)
27 #:use-module (guix records)
28 #:use-module (srfi srfi-9)
29 #:use-module (ice-9 match)
30 #:export (name-service-switch?
31 name-service-switch
32 name-service?
33 name-service
34
35 lookup-specification
36 mdns-host-lookup-nss
37
38 %default-nss
39 %mdns-host-lookup-nss
40
41 %files
42 %compat
43 %dns
44
45 name-service-switch->string))
46
47(define-record-type* <name-service> name-service
48 make-name-service
49 name-service?
50 (name name-service-name)
51 (reaction name-service-reaction
52 (default (lookup-specification))))
53
54;; Lookup specification (info "(libc) Actions in the NSS Configuration").
55
56(define-enumeration lookup-action
57 (return continue merge)
58 make-lookup-action)
59
60(define-enumeration lookup-status
61 (success
62 not-found
63 unavailable
64 try-again)
65 make-lookup-status)
66
67(define-record-type <lookup-status-negation>
68 (lookup-status-negation status)
69 lookup-status-negation?
70 (status lookup-status-negation-status))
71
72(define-record-type <lookup-reaction>
73 (make-lookup-reaction status action)
74 lookup-reaction?
75 (status lookup-reaction-status)
76 (action lookup-reaction-action))
77
78(define-syntax lookup-reaction
79 (syntax-rules (not =>)
80 ((_ ((not status) => action))
81 (make-lookup-reaction (lookup-status-negation (lookup-status status))
82 (lookup-action action)))
83 ((_ (status => action))
84 (make-lookup-reaction (lookup-status status)
85 (lookup-action action)))))
86
87(define-syntax-rule (lookup-specification reaction ...)
88 "Return an NSS lookup specification."
89 (list (lookup-reaction reaction) ...))
90
91
92;;;
93;;; Common name services and default NSS configuration.
94;;;
95
96(define %compat
97 ;; Note: Starting from version 2.26, libc no longer provides libnss_compat
98 ;; so this specification has become useless.
99 (name-service
100 (name "compat")
101 (reaction (lookup-specification (not-found => return)))))
102
103(define %files
104 (name-service (name "files")))
105
106(define %dns
107 ;; DNS is supposed to be authoritative, so unless it's unavailable, return
108 ;; what it finds.
109 (name-service
110 (name "dns")
111 (reaction (lookup-specification ((not unavailable) => return)))))
112
113;; The NSS. We list all the databases here because that allows us to
114;; statically ensure that the user's configuration refers to existing
115;; databases. See libc/nss/databases.def for the list of databases. Default
116;; values obtained by looking for "DEFAULT_CONFIG" in libc/nss/*.c.
117;;
118;; Although libc places 'dns' before 'files' in the default configurations of
119;; the 'hosts' and 'networks' databases, we choose to put 'files' before 'dns'
120;; by default, so that users can override host/address mappings in /etc/hosts
121;; and bypass DNS to improve their privacy and escape NSA's MORECOWBELL.
122(define-record-type* <name-service-switch> name-service-switch
123 make-name-service-switch
124 name-service-switch?
125 (aliases name-service-switch-aliases
126 (default '()))
127 (ethers name-service-switch-ethers
128 (default '()))
129 (group name-service-switch-group
130 (default (list %files)))
131 (gshadow name-service-switch-gshadow
132 (default '()))
133 (hosts name-service-switch-hosts
134 (default (list %files %dns)))
135 (initgroups name-service-switch-initgroups
136 (default '()))
137 (netgroup name-service-switch-netgroup
138 (default '()))
139 (networks name-service-switch-networks
140 (default (list %files %dns)))
141 (password name-service-switch-password
142 (default (list %files)))
143 (protocols name-service-switch-protocols
144 (default '()))
145 (public-key name-service-switch-public-key
146 (default '()))
147 (rpc name-service-switch-rpc
148 (default '()))
149 (services name-service-switch-services
150 (default '()))
151 (shadow name-service-switch-shadow
152 (default (list %files))))
153
154(define %default-nss
155 ;; Default NSS configuration.
156 (name-service-switch))
157
158(define* (mdns-host-lookup-nss #:key (ipv6? #t) (ipv4? #t))
159 (let ((flavour (cond
160 ((and ipv6? ipv4?) "mdns")
161 (ipv6? "mdns6")
162 (ipv4? "mdns4")
163 (#t (error "No protocols enabled for mDNS lookups.")))))
164 (name-service-switch
165 (hosts (list %files ;first, check /etc/hosts
166
167 ;; If the above did not succeed, try with 'mdns_minimal'.
168 (name-service
169 (name (string-append flavour "_minimal"))
170
171 ;; 'mdns_minimal' is authoritative for '.local'. When it
172 ;; returns "not found", no need to try the next methods.
173 (reaction (lookup-specification
174 (not-found => return))))
175
176 ;; Then fall back to DNS.
177 (name-service
178 (name "dns"))
179
180 ;; Finally, try with the "full" 'mdns'.
181 (name-service
182 (name flavour)))))))
183
184
185(define %mdns-host-lookup-nss (mdns-host-lookup-nss))
186
187
188;;;
189;;; Serialization.
190;;;
191
192(define (lookup-status->string status)
193 (match status
194 ('success "SUCCESS")
195 ('not-found "NOTFOUND")
196 ('unavailable "UNAVAIL")
197 ('try-again "TRYAGAIN")
198 (($ <lookup-status-negation> status)
199 (string-append "!" (lookup-status->string status)))))
200
201(define lookup-reaction->string
202 (match-lambda
203 (($ <lookup-reaction> status action)
204 (string-append (lookup-status->string status) "="
205 (symbol->string action)))))
206
207(define name-service->string
208 (match-lambda
209 (($ <name-service> name ())
210 name)
211 (($ <name-service> name reactions)
212 (string-append name " ["
213 (string-join (map lookup-reaction->string reactions))
214 "]"))))
215
216(define (name-service-switch->string nss)
217 "Return the 'nsswitch.conf' contents for NSS as a string. See \"NSS
218Configuration File\" in the libc manual."
219 (let-syntax ((->string
220 (syntax-rules ()
221 ((_ name field)
222 (match (field nss)
223 (() ;keep the default config
224 "")
225 ((services (... ...))
226 (string-append name ":\t"
227 (string-join
228 (map name-service->string services))
229 "\n")))))))
230 (string-append (->string "aliases" name-service-switch-aliases)
231 (->string "ethers" name-service-switch-ethers)
232 (->string "group" name-service-switch-group)
233 (->string "gshadow" name-service-switch-gshadow)
234 (->string "hosts" name-service-switch-hosts)
235 (->string "initgroups" name-service-switch-initgroups)
236 (->string "netgroup" name-service-switch-netgroup)
237 (->string "networks" name-service-switch-networks)
238 (->string "passwd" name-service-switch-password)
239 (->string "protocols" name-service-switch-protocols)
240 (->string "publickey" name-service-switch-public-key)
241 (->string "rpc" name-service-switch-rpc)
242 (->string "services" name-service-switch-services)
243 (->string "shadow" name-service-switch-shadow))))
244
245;;; Local Variables:
246;;; eval: (put 'name-service 'scheme-indent-function 0)
247;;; eval: (put 'name-service-switch 'scheme-indent-function 0)
248;;; End:
249
250;;; nss.scm ends here