services: dns: Add unbound service.

This allows using Unbound as a local DNSSEC-enabled resolver. This
commit also allows configuration of the Unbound DNS resolver via a
Scheme API. The API currently provides very common options and
includes an escape hatch to enable less common configurations.

* gnu/service/dns.scm (unbound-serialize-field): New procedure.
(unbound-serialize-alist, unbound-serialize-section)
(unbound-serialize-string, unbound-serialize-boolean)
(unbound-serialize-list-of-strings): New procedures.
(unbound-zone): New record type.
(unbound-serialize-unbound-zone)
(unbound-serialize-list-of-unbound-zone): New procedures.
(unbound-remote): New record type.
(unbound-serialize-unbound-remote): New procedure.
(unbound-server): New record type.
(unbound-serialize-unbound-server): New procedure.
(unbound-configuration): New record type.
(unbound-config-file, unbound-shepherd-service): New procedures.
(unbound-account-service): New variable.
(unbound-service-type): New services.
* gnu/tests/dns.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* doc/guix.texi (DNS Services): Document it.

Signed-off-by: Ludovic Courtès <[email protected]>
Change-Id: I4c9646c9e17d4882e596d33ff8f738e1877fa1ae

3 files changed, 302 insertions, 1 deletions

diff --git a/gnu/local.mk b/gnu/local.mk
index 1d15be886d..9201230f35 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -838,6 +838,7 @@ GNU_SYSTEM_MODULES =				\
   %D%/tests/cups.scm				\
   %D%/tests/databases.scm			\
   %D%/tests/desktop.scm				\
+  %D%/tests/dns.scm				\
   %D%/tests/dict.scm				\
   %D%/tests/docker.scm				\
   %D%/tests/emacs.scm				\
diff --git a/gnu/services/dns.scm b/gnu/services/dns.scm
index 532e20e38a..c74001fac2 100644
--- a/gnu/services/dns.scm
+++ b/gnu/services/dns.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2020 Pierre Langlois <[email protected]>
 ;;; Copyright © 2021 Maxime Devos <[email protected]>
 ;;; Copyright © 2022 Remco van 't Veer <[email protected]>
+;;; Copyright © 2024 Sören Tempel <[email protected]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -52,7 +53,21 @@
             knot-resolver-configuration
 
             dnsmasq-service-type
-            dnsmasq-configuration))
+            dnsmasq-configuration
+
+            unbound-service-type
+            unbound-zone
+            unbound-server
+            unbound-configuration
+            unbound-configuration?
+            unbound-configuration-server
+            unbound-configuration-remote-control
+            unbound-configuration-forward-zone
+            unbound-configuration-stub-zone
+            unbound-configuration-auth-zone
+            unbound-configuration-view
+            unbound-configuration-python
+            unbound-configuration-dynlib))
 
 ;;;
 ;;; Knot DNS.
@@ -902,3 +917,178 @@ cache.size = 100 * MB
                              dnsmasq-activation)))
    (default-value (dnsmasq-configuration))
    (description "Run the dnsmasq DNS server.")))
+
+
+;;;
+;;; Unbound.
+;;;
+
+(define (unbound-serialize-field field-name value)
+  (let ((field (object->string field-name))
+        (value (cond
+                 ((boolean? value) (if value "yes" "no"))
+                 ((string? value) value)
+                 (else (object->string value)))))
+    (if (string=? field "extra-content")
+      #~(string-append #$value "\n")
+      #~(format #f "	~a: ~s~%" #$field #$value))))
+
+(define (unbound-serialize-alist field-name value)
+  #~(string-append #$@(generic-serialize-alist list
+                                               unbound-serialize-field
+                                               value)))
+
+(define (unbound-serialize-section section-name value fields)
+  #~(format #f "~a:~%~a"
+            #$(object->string section-name)
+            #$(serialize-configuration value fields)))
+
+(define unbound-serialize-string unbound-serialize-field)
+(define unbound-serialize-boolean unbound-serialize-field)
+
+(define-maybe string (prefix unbound-))
+(define-maybe list-of-strings (prefix unbound-))
+(define-maybe boolean (prefix unbound-))
+
+(define (unbound-serialize-list-of-strings field-name value)
+  #~(string-append #$@(map (cut unbound-serialize-string field-name <>) value)))
+
+(define-configuration unbound-zone
+  (name
+    string
+    "Zone name.")
+
+  (forward-addr
+    maybe-list-of-strings
+    "IP address of server to forward to.")
+
+  (forward-tls-upstream
+    maybe-boolean
+    "Whether the queries to this forwarder use TLS for transport.")
+
+  (extra-options
+   (alist '())
+   "An association list of options to append.")
+
+  (prefix unbound-))
+
+(define (unbound-serialize-unbound-zone field-name value)
+  (unbound-serialize-section field-name value unbound-zone-fields))
+
+(define (unbound-serialize-list-of-unbound-zone field-name value)
+  #~(string-append #$@(map (cut unbound-serialize-unbound-zone field-name <>)
+                           value)))
+
+(define list-of-unbound-zone? (list-of unbound-zone?))
+
+(define-configuration unbound-remote
+  (control-enable
+    maybe-boolean
+    "Enable remote control.")
+
+  (control-interface
+    maybe-string
+    "IP address or local socket path to listen on for remote control.")
+
+  (extra-options
+   (alist '())
+   "An association list of options to append.")
+
+  (prefix unbound-))
+
+(define (unbound-serialize-unbound-remote field-name value)
+  (unbound-serialize-section field-name value unbound-remote-fields))
+
+(define-configuration unbound-server
+  (interface
+    maybe-list-of-strings
+    "Interfaces listened on for queries from clients.")
+
+  (hide-version
+    maybe-boolean
+    "Refuse the version.server and version.bind queries.")
+
+  (hide-identity
+    maybe-boolean
+    "Refuse the id.server and hostname.bind queries.")
+
+  (tls-cert-bundle
+    maybe-string
+    "Certificate bundle file, used for DNS over TLS.")
+
+  (extra-options
+   (alist '())
+   "An association list of options to append.")
+
+  (prefix unbound-))
+
+(define (unbound-serialize-unbound-server field-name value)
+  (unbound-serialize-section field-name value unbound-server-fields))
+
+(define-configuration unbound-configuration
+  (server
+    (unbound-server
+      (unbound-server
+        (interface '("127.0.0.1" "::1"))
+
+        (hide-version #t)
+        (hide-identity #t)
+
+        (tls-cert-bundle "/etc/ssl/certs/ca-certificates.crt")))
+    "General options for the Unbound server.")
+
+  (remote-control
+    (unbound-remote
+      (unbound-remote
+        (control-enable #t)
+        (control-interface "/run/unbound.sock")))
+    "Remote control options for the daemon.")
+
+  (forward-zone
+    (list-of-unbound-zone '())
+    "A zone for which queries should be forwarded to another resolver.")
+
+  (extra-content
+    maybe-string
+    "Raw content to add to the configuration file.")
+
+  (prefix unbound-))
+
+(define (unbound-config-file config)
+  (mixed-text-file "unbound.conf"
+    (serialize-configuration
+      config
+      unbound-configuration-fields)))
+
+(define (unbound-shepherd-service config)
+  (let ((config-file (unbound-config-file config)))
+    (list (shepherd-service
+            (documentation "Unbound daemon.")
+            (provision '(unbound dns))
+            (requirement '(networking))
+            (actions (list (shepherd-configuration-action config-file)))
+            (start #~(make-forkexec-constructor
+                       (list (string-append #$unbound "/sbin/unbound")
+                             "-d" "-p" "-c" #$config-file)))
+            (stop #~(make-kill-destructor))))))
+
+(define unbound-account-service
+  (list (user-group (name "unbound") (system? #t))
+        (user-account
+         (name "unbound")
+         (group "unbound")
+         (system? #t)
+         (comment "Unbound daemon user")
+         (home-directory "/var/empty")
+         (shell "/run/current-system/profile/sbin/nologin"))))
+
+(define unbound-service-type
+  (service-type (name 'unbound)
+                (description "Run the unbound DNS resolver.")
+                (extensions
+                  (list (service-extension account-service-type
+                                           (const unbound-account-service))
+                        (service-extension shepherd-root-service-type
+                                           unbound-shepherd-service)))
+                (compose concatenate)
+                (default-value (unbound-configuration))))
diff --git a/gnu/tests/dns.scm b/gnu/tests/dns.scm
new file mode 100644
index 0000000000..ff42456760
--- /dev/null
+++ b/gnu/tests/dns.scm
@@ -0,0 +1,110 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2025 Sören Tempel <[email protected]>
+;;;
+;;; 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 tests dns)
+  #:use-module (gnu tests)
+  #:use-module (gnu system)
+  #:use-module (gnu system vm)
+  #:use-module (gnu services)
+  #:use-module (gnu services dns)
+  #:use-module (gnu services networking)
+  #:use-module (gnu packages dns)
+  #:use-module (guix gexp)
+  #:export (%test-unbound))
+
+(define %unbound-os
+  ;; TODO: Unbound config
+  (let ((base-os
+          (simple-operating-system
+            (service dhcp-client-service-type)
+            (service unbound-service-type
+                     (unbound-configuration
+                       (server
+                         (unbound-server
+                           (interface '("127.0.0.1" "::1"))
+                           (extra-options
+                             '((local-data . "example.local A 192.0.2.1"))))))))))
+    (operating-system
+      (inherit base-os)
+      (packages
+        (append (list
+                  `(,isc-bind "utils")
+                  unbound)
+                (operating-system-packages base-os))))))
+
+(define (run-unbound-test)
+  "Run tests in %unbound-os with a running unbound daemon on localhost."
+  (define os
+    (marionette-operating-system
+     %unbound-os
+     #:imported-modules '((gnu services herd))))
+
+  (define vm
+    (virtual-machine os))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (srfi srfi-64)
+                       (gnu build marionette))
+          (define marionette
+            (make-marionette (list #$vm)))
+
+          (test-runner-current (system-test-runner #$output))
+          (test-begin "unbound")
+
+          (test-assert "service is running"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+
+                ;; Make sure the 'unbound-control' and 'host' command is found.
+                (setenv "PATH" "/run/current-system/profile/bin:/run/current-system/profile/sbin")
+
+                (start-service 'unbound))
+             marionette))
+
+          (test-equal "unbound remote control works"
+            0
+            (marionette-eval
+              '(status:exit-val
+                 (system* "unbound-control" "-s" "/run/unbound.sock" "status"))
+              marionette))
+
+          ;; We use a custom local-data A record here to avoid depending
+          ;; on network access and being able to contact the root servers.
+          (test-equal "resolves local-data domain"
+            "192.0.2.1"
+            (marionette-eval
+              '(begin
+                 (use-modules (ice-9 popen) (rnrs io ports))
+
+                 (let* ((port (open-input-pipe "dig @127.0.0.1 example.local +short"))
+                        (out  (get-string-all port)))
+                   (close-port port)
+                   (string-drop-right out 1))) ;; drop newline
+              marionette))
+
+          (test-end))))
+  (gexp->derivation "unbound-test" test))
+
+(define %test-unbound
+  (system-test
+   (name "unbound")
+   (description "Test that the unbound can respond to queries.")
+   (value (run-unbound-test))))