nss.scm 8.0 KB

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