services: ntp: Support different NTP server types and options.

* gnu/services/networking.scm (ntp-server-types): New enum.
(<ntp-server>): New record type.
(ntp-server->string): New procedure.
(%ntp-servers): Define in terms of <htp-server> records.  Use the first
entrypoint server as a pool instead of a list of static servers.  This is more
resilient since a new server of the pool can be interrogated on every
request.  Add the 'iburst' options.
(ntp-configuration-servers): Define a custom accessor that warns but honors
the now deprecated server format.
(<ntp-configuration>): Use it.
(%openntpd-servers): New variable,
(<openntpd-configuration>): Use it, as a pool ('servers' field) instead of a
regular server.
* tests/networking.scm: New file.
* Makefile.am (SCM_TESTS): Register it.
* doc/guix.texi: Update documentation.

4 files changed, 178 insertions, 23 deletions

diff --git a/Makefile.am b/Makefile.am
index 796e96f099..683b2242f0 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -402,6 +402,7 @@ SCM_TESTS =					\
   tests/modules.scm				\
   tests/monads.scm				\
   tests/nar.scm				\
+  tests/networking.scm				\
   tests/opam.scm				\
   tests/packages.scm				\
   tests/pack.scm				\
diff --git a/doc/guix.texi b/doc/guix.texi
index 84f2c1558a..9101aafda1 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -48,7 +48,7 @@ Copyright @copyright{} 2017 humanitiesNerd@*
 Copyright @copyright{} 2017 Christopher Allan Webber@*
 Copyright @copyright{} 2017, 2018 Marius Bakke@*
 Copyright @copyright{} 2017 Hartmut Goebel@*
-Copyright @copyright{} 2017 Maxim Cournoyer@*
+Copyright @copyright{} 2017, 2019 Maxim Cournoyer@*
 Copyright @copyright{} 2017, 2018, 2019 Tobias Geerinckx-Rice@*
 Copyright @copyright{} 2017 George Clemmer@*
 Copyright @copyright{} 2017 Andy Wingo@*
@@ -13048,8 +13048,9 @@ This is the data type for the NTP service configuration.
 
 @table @asis
 @item @code{servers} (default: @code{%ntp-servers})
-This is the list of servers (host names) with which @command{ntpd} will be
-synchronized.
+This is the list of servers (@code{<ntp-server>} records) with which
+@command{ntpd} will be synchronized.  See the @code{ntp-server} data type
+definition below.
 
 @item @code{allow-large-adjustment?} (default: @code{#t})
 This determines whether @command{ntpd} is allowed to make an initial
@@ -13065,6 +13066,32 @@ List of host names used as the default NTP servers.  These are servers of the
 @uref{https://www.ntppool.org/en/, NTP Pool Project}.
 @end defvr
 
+@deftp {Data Type} ntp-server
+The data type representing the configuration of a NTP server.
+
+@table @asis
+@item @code{type} (default: @code{'server})
+The type of the NTP server, given as a symbol. One of @code{'pool},
+@code{'server}, @code{'peer}, @code{'broadcast} or @code{'manycastclient}.
+
+@item @code{address}
+The address of the server, as a string.
+
+@item @code{options}
+NTPD options to use with that specific server, given as a list of option names
+and/or of option names and values tuples. The following example define a server
+to use with the options @option{iburst} and @option{prefer}, as well as
+@option{version} 3 and a @option{maxpoll} time of 16 seconds.
+
+@example
+(ntp-server
+ (type 'server)
+ (address "some.ntp.server.org")
+ (options `(iburst (version 3) (maxpoll 16) prefer))))
+@end example
+@end table
+@end deftp
+
 @cindex OpenNTPD
 @deffn {Scheme Procedure} openntpd-service-type
 Run the @command{ntpd}, the Network Time Protocol (NTP) daemon, as implemented
@@ -13084,6 +13111,11 @@ clock synchronized with that of the given servers.
 @end lisp
 @end deffn
 
+@defvr {Scheme Variable} %openntpd-servers
+This variable is a list of the server addresses defined in
+@var{%ntp-servers}.
+@end defvr
+
 @deftp {Data Type} openntpd-configuration
 @table @asis
 @item @code{openntpd} (default: @code{(file-append openntpd "/sbin/ntpd")})
@@ -13097,9 +13129,9 @@ Specify a list of timedelta sensor devices ntpd should use.  @code{ntpd}
 will listen to each sensor that actually exists and ignore non-existent ones.
 See @uref{https://man.openbsd.org/ntpd.conf, upstream documentation} for more
 information.
-@item @code{server} (default: @var{%ntp-servers})
+@item @code{server} (default: @code{'()})
 Specify a list of IP addresses or hostnames of NTP servers to synchronize to.
-@item @code{servers} (default: @code{'()})
+@item @code{servers} (default: @var{%openntp-servers})
 Specify a list of IP addresses or hostnames of NTP pools to synchronize to.
 @item @code{constraint-from} (default: @code{'()})
 @code{ntpd} can be configured to query the ‘Date’ from trusted HTTPS servers via TLS.
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 13a5c6c98d..c45bfcdad9 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -51,6 +51,7 @@
   #:use-module (guix records)
   #:use-module (guix modules)
   #:use-module (guix deprecation)
+  #:use-module (rnrs enums)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
@@ -72,13 +73,22 @@
             dhcpd-configuration-pid-file
             dhcpd-configuration-interfaces
 
-            %ntp-servers
-
             ntp-configuration
             ntp-configuration?
+            ntp-configuration-ntp
+            ntp-configuration-servers
+            ntp-allow-large-adjustment?
+
+            %ntp-servers
+            ntp-server
+            ntp-server-type
+            ntp-server-address
+            ntp-server-options
+
             ntp-service
             ntp-service-type
 
+            %openntpd-servers
             openntpd-configuration
             openntpd-configuration?
             openntpd-service-type
@@ -292,31 +302,87 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
     (list (service-extension shepherd-root-service-type dhcpd-shepherd-service)
           (service-extension activation-service-type dhcpd-activation)))))
 
-(define %ntp-servers
-  ;; Default set of NTP servers. These URLs are managed by the NTP Pool project.
-  ;; Within Guix, Leo Famulari <leo@famulari.name> is the administrative contact
-  ;; for this NTP pool "zone".
-  '("0.guix.pool.ntp.org"
-    "1.guix.pool.ntp.org"
-    "2.guix.pool.ntp.org"
-    "3.guix.pool.ntp.org"))
-
 
 ;;;
 ;;; NTP.
 ;;;
 
-;; TODO: Export.
+(define ntp-server-types (make-enumeration
+                          '(pool
+                            server
+                            peer
+                            broadcast
+                            manycastclient)))
+
+(define-record-type* <ntp-server>
+  ntp-server make-ntp-server
+  ntp-server?
+  ;; The type can be one of the symbols of the NTP-SERVER-TYPE? enumeration.
+  (type ntp-server-type
+        (default 'server))
+  (address ntp-server-address)    ; a string
+  ;; The list of options can contain single option names or tuples in the form
+  ;; '(name value).
+  (options ntp-server-options
+           (default '())))
+
+(define (ntp-server->string ntp-server)
+  ;; Serialize the NTP server object as a string, ready to use in the NTP
+  ;; configuration file.
+  (define (flatten lst)
+    (reverse
+     (let loop ((x lst)
+                (res '()))
+       (if (list? x)
+           (fold loop res x)
+           (cons (format #f "~s" x) res)))))
+
+  (match ntp-server
+    (($ <ntp-server> type address options)
+     ;; XXX: It'd be neater if fields were validated at the syntax level (for
+     ;; static ones at least).  Perhaps the Guix record type could support a
+     ;; predicate property on a field?
+     (unless (enum-set-member? type ntp-server-types)
+       (error "Invalid NTP server type" type))
+     (string-join (cons* (symbol->string type)
+                         address
+                         (flatten options))))))
+
+(define %ntp-servers
+  ;; Default set of NTP servers. These URLs are managed by the NTP Pool project.
+  ;; Within Guix, Leo Famulari <leo@famulari.name> is the administrative contact
+  ;; for this NTP pool "zone".
+  (list
+   (ntp-server
+    (type 'pool)
+    (address "0.guix.pool.ntp.org")
+    (options '("iburst")))))               ;as recommended in the ntpd manual
+
 (define-record-type* <ntp-configuration>
   ntp-configuration make-ntp-configuration
   ntp-configuration?
   (ntp      ntp-configuration-ntp
             (default ntp))
-  (servers  ntp-configuration-servers
+  (servers  %ntp-configuration-servers   ;list of <ntp-server> objects
             (default %ntp-servers))
   (allow-large-adjustment? ntp-allow-large-adjustment?
                            (default #t))) ;as recommended in the ntpd manual
 
+(define (ntp-configuration-servers ntp-configuration)
+  ;; A wrapper to support the deprecated form of this field.
+  (let ((ntp-servers (%ntp-configuration-servers ntp-configuration)))
+    (match ntp-servers
+      (((? string?) (? string?) ...)
+       (format (current-error-port) "warning: Defining NTP servers as strings is \
+deprecated.  Please use <ntp-server> records instead.\n")
+       (map (lambda (addr)
+              (ntp-server
+               (type 'server)
+               (address addr)
+               (options '()))) ntp-servers))
+      ((($ <ntp-server>) ($ <ntp-server>) ...)
+       ntp-servers))))
+
 (define ntp-shepherd-service
   (match-lambda
     (($ <ntp-configuration> ntp servers allow-large-adjustment?)
@@ -324,8 +390,7 @@ Protocol (DHCP) client, on all the non-loopback network interfaces."
        ;; TODO: Add authentication support.
        (define config
          (string-append "driftfile /var/run/ntpd/ntp.drift\n"
-                        (string-join (map (cut string-append "server " <>)
-                                          servers)
+                        (string-join (map ntp-server->string servers)
                                      "\n")
                         "
 # Disable status queries as a workaround for CVE-2013-5211:
@@ -335,7 +400,11 @@ restrict -6 default kod nomodify notrap nopeer noquery limited
 
 # Yet, allow use of the local 'ntpq'.
 restrict 127.0.0.1
-restrict -6 ::1\n"))
+restrict -6 ::1
+
+# This is required to use servers from a pool directive when using the 'nopeer'
+# option by default, as documented in the 'ntp.conf' manual.
+restrict source notrap nomodify noquery\n"))
 
        (define ntpd.conf
          (plain-file "ntpd.conf" config))
@@ -409,6 +478,9 @@ make an initial adjustment of more than 1,000 seconds."
 ;;; OpenNTPD.
 ;;;
 
+(define %openntpd-servers
+  (map ntp-server-address %ntp-servers))
+
 (define-record-type* <openntpd-configuration>
   openntpd-configuration make-openntpd-configuration
   openntpd-configuration?
@@ -422,9 +494,9 @@ make an initial adjustment of more than 1,000 seconds."
   (sensor                  openntpd-sensor
                            (default '()))
   (server                  openntpd-server
-                           (default %ntp-servers))
-  (servers                 openntpd-servers
                            (default '()))
+  (servers                 openntpd-servers
+                           (default %openntpd-servers))
   (constraint-from         openntpd-constraint-from
                            (default '()))
   (constraints-from        openntpd-constraints-from
diff --git a/tests/networking.scm b/tests/networking.scm
new file mode 100644
index 0000000000..001d7df74d
--- /dev/null
+++ b/tests/networking.scm
@@ -0,0 +1,50 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;;
+;;; 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 (tests networking)
+  #:use-module (gnu services networking)
+  #:use-module (srfi srfi-64))
+
+;;; Tests for the (gnu services networking) module.
+
+(define ntp-server->string (@@ (gnu services networking) ntp-server->string))
+
+(define %ntp-server-sample
+  (ntp-server
+   (type 'server)
+   (address "some.ntp.server.org")
+   (options `(iburst (version 3) (maxpoll 16) prefer))))
+
+(test-begin "networking")
+
+(test-equal "ntp-server->string"
+  (ntp-server->string %ntp-server-sample)
+  "server some.ntp.server.org iburst version 3 maxpoll 16 prefer")
+
+(test-equal "ntp configuration servers deprecated form"
+  (ntp-configuration-servers
+   (ntp-configuration
+    (servers (list (ntp-server
+                    (type 'server)
+                    (address "example.pool.ntp.org")
+                    (options '()))))))
+  (ntp-configuration-servers
+   (ntp-configuration
+    (servers (list "example.pool.ntp.org")))))
+
+(test-end "networking")