123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237 |
- (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
- %mdns-host-lookup-nss
- %files
- %compat
- %dns
- name-service-switch->string))
- (define-record-type* <name-service> name-service
- make-name-service
- name-service?
- (name name-service-name)
- (reaction name-service-reaction
- (default (lookup-specification))))
- (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) ...))
- (define %compat
- (name-service
- (name "compat")
- (reaction (lookup-specification (not-found => return)))))
- (define %files
- (name-service (name "files")))
- (define %dns
-
-
- (name-service
- (name "dns")
- (reaction (lookup-specification ((not unavailable) => return)))))
- (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
-
- (name-service-switch))
- (define %mdns-host-lookup-nss
- (name-service-switch
- (hosts (list %files
-
- (name-service
- (name "mdns_minimal")
-
-
- (reaction (lookup-specification
- (not-found => return))))
-
- (name-service
- (name "dns"))
-
- (name-service
- (name "mdns"))))))
- (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)
- (()
- "")
- ((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))))
|