01/01: services: Add dhcpd-service-type and <dhcpd-configuration>.

[Chris Marusich]

marusich pushed a commit to branch master
in repository guix.

commit f1104d900978900addad731dfec4e0e6e5765fbe
Author: Chris Marusich <address@hidden>
Date:   Sat Dec 16 00:52:42 2017 -0800

    services: Add dhcpd-service-type and <dhcpd-configuration>.
    
    * doc/guix.texi (Networking Services): Document it.
    * gnu/services/networking.scm (dhcpd-service-type): Add it.
    (dhcpd-configuration, dhcpd-configuration?): Add it.
    (dhcpd-configuration-package): Add it.
    (dhcpd-configuration-config-file): Add it.
    (dhcpd-configuration-version): Add it.
    (dhcpd-configuration-run-directory): Add it.
    (dhcpd-configuration-lease-file): Add it.
    (dhcpd-configuration-pid-file): Add it.
    (dhcpd-configuration-interfaces): Add it.
    * gnu/tests/networking.scm (minimal-dhcpd-v4-config-file)
    (dhcpd-v4-configuration, %dhcpd-os, run-dhcpd-test, %test-dhcpd): New
    variables.
---
 doc/guix.texi               | 45 +++++++++++++++++++++
 gnu/services/networking.scm | 78 ++++++++++++++++++++++++++++++++++++
 gnu/tests/networking.scm    | 97 ++++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 219 insertions(+), 1 deletion(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 1bf9685..75886e9 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10694,6 +10694,51 @@ Return a service that runs @var{dhcp}, a Dynamic Host 
Configuration
 Protocol (DHCP) client, on all the non-loopback network interfaces.
 @end deffn
 
address@hidden {Scheme Procedure} dhcpd-service-type
+This type defines a service that runs a DHCP daemon.  To create a
+service of this type, you must supply a @code{<dhcpd-configuration>}.
+For example:
+
address@hidden
+(service dhcpd-service-type
+         (dhcpd-configuration
+          (config-file (local-file "my-dhcpd.conf"))
+          (interfaces '("enp0s25"))))
address@hidden example
address@hidden deffn
+
address@hidden {Data Type} dhcpd-configuration
address@hidden @asis
address@hidden @code{package} (default: @code{isc-dhcp})
+The package that provides the DHCP daemon.  This package is expected to
+provide the daemon at @file{sbin/dhcpd} relative to its output
+directory.  The default package is the
address@hidden://www.isc.org/products/DHCP, ISC's DHCP server}.
address@hidden @code{config-file} (default: @code{#f})
+The configuration file to use.  This is required.  It will be passed to
address@hidden via its @code{-cf} option.  This may be any ``file-like''
+object (@pxref{G-Expressions, file-like objects}).  See @code{man
+dhcpd.conf} for details on the configuration file syntax.
address@hidden @code{version} (default: @code{"4"})
+The DHCP version to use.  The ISC DHCP server supports the values ``4'',
+``6'', and ``4o6''.  These correspond to the @code{dhcpd} program
+options @code{-4}, @code{-6}, and @code{-4o6}.  See @code{man dhcpd} for
+details.
address@hidden @code{run-directory} (default: @code{"/run/dhcpd"})
+The run directory to use.  At service activation time, this directory
+will be created if it does not exist.
address@hidden @code{pid-file} (default: @code{"/run/dhcpd/dhcpd.pid"})
+The PID file to use.  This corresponds to the @code{-pf} option of
address@hidden  See @code{man dhcpd} for details.
address@hidden @code{interfaces} (default: @code{'()})
+The names of the network interfaces on which dhcpd should listen for
+broadcasts.  If this list is not empty, then its elements (which must be
+strings) will be appended to the @code{dhcpd} invocation when starting
+the daemon.  It may not be necessary to explicitly specify any
+interfaces here; see @code{man dhcpd} for details.
address@hidden table
address@hidden deftp
+
 @defvr {Scheme Variable} static-networking-service-type
 This is the type for statically-configured network interfaces.
 @c TODO Document <static-networking> data structures.
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 6ac440f..be34f32 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -57,6 +57,18 @@
             static-networking-service
             static-networking-service-type
             dhcp-client-service
+
+            dhcpd-service-type
+            dhcpd-configuration
+            dhcpd-configuration?
+            dhcpd-configuration-package
+            dhcpd-configuration-config-file
+            dhcpd-configuration-version
+            dhcpd-configuration-run-directory
+            dhcpd-configuration-lease-file
+            dhcpd-configuration-pid-file
+            dhcpd-configuration-interfaces
+
             %ntp-servers
 
             ntp-configuration
@@ -341,6 +353,72 @@ to handle."
 Protocol (DHCP) client, on all the non-loopback network interfaces."
   (service dhcp-client-service-type dhcp))
 
+(define-record-type* <dhcpd-configuration>
+  dhcpd-configuration make-dhcpd-configuration
+  dhcpd-configuration?
+  (package   dhcpd-configuration-package ;<package>
+             (default isc-dhcp))
+  (config-file   dhcpd-configuration-config-file ;file-like
+                 (default #f))
+  (version dhcpd-configuration-version ;"4", "6", or "4o6"
+              (default "6"))
+  (run-directory dhcpd-configuration-run-directory
+                 (default "/run/dhcpd"))
+  (lease-file dhcpd-configuration-lease-file
+              (default "/var/db/dhcpd.leases"))
+  (pid-file dhcpd-configuration-pid-file
+            (default "/run/dhcpd/dhcpd.pid"))
+  ;; list of strings, e.g. (list "enp0s25")
+  (interfaces dhcpd-configuration-interfaces
+              (default '())))
+
+(define dhcpd-shepherd-service
+  (match-lambda
+    (($ <dhcpd-configuration> package config-file version run-directory
+                              lease-file pid-file interfaces)
+     (unless config-file
+       (error "Must supply a config-file"))
+     (list (shepherd-service
+            ;; Allow users to easily run multiple versions simultaneously.
+            (provision (list (string->symbol
+                              (string-append "dhcpv" version "-daemon"))))
+            (documentation (string-append "Run the DHCPv" version " daemon"))
+            (requirement '(networking))
+            (start #~(make-forkexec-constructor
+                      '(#$(file-append package "/sbin/dhcpd")
+                        #$(string-append "-" version)
+                        "-lf" #$lease-file
+                        "-pf" #$pid-file
+                        "-cf" #$config-file
+                        address@hidden)
+                      #:pid-file #$pid-file))
+            (stop #~(make-kill-destructor)))))))
+
+(define dhcpd-activation
+  (match-lambda
+    (($ <dhcpd-configuration> package config-file version run-directory
+                              lease-file pid-file interfaces)
+     (with-imported-modules '((guix build utils))
+       #~(begin
+           (unless (file-exists? #$run-directory)
+             (mkdir #$run-directory))
+           ;; According to the DHCP manual (man dhcpd.leases), the lease
+           ;; database must be present for dhcpd to start successfully.
+           (unless (file-exists? #$lease-file)
+             (with-output-to-file #$lease-file
+               (lambda _ (display ""))))
+           ;; Validate the config.
+           (invoke
+            #$(file-append package "/sbin/dhcpd") "-t" "-cf"
+            #$config-file))))))
+
+(define dhcpd-service-type
+  (service-type
+   (name 'dhcpd)
+   (extensions
+    (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 <address@hidden> is the administrative contact
diff --git a/gnu/tests/networking.scm b/gnu/tests/networking.scm
index d7d9166..171c636 100644
--- a/gnu/tests/networking.scm
+++ b/gnu/tests/networking.scm
@@ -29,7 +29,7 @@
   #:use-module (gnu packages bash)
   #:use-module (gnu packages networking)
   #:use-module (gnu services shepherd)
-  #:export (%test-inetd %test-openvswitch))
+  #:export (%test-inetd %test-openvswitch %test-dhcpd))
 
 (define %inetd-os
   ;; Operating system with 2 inetd services.
@@ -243,3 +243,98 @@ port 7, and a dict service on port 2628."
    (name "openvswitch")
    (description "Test a running OpenvSwitch configuration.")
    (value (run-openvswitch-test))))
+
+
+;;;
+;;; DHCP Daemon
+;;;
+
+(define minimal-dhcpd-v4-config-file
+  (plain-file "dhcpd.conf"
+              "\
+default-lease-time 600;
+max-lease-time 7200;
+
+subnet 192.168.1.0 netmask 255.255.255.0 {
+ range 192.168.1.100 192.168.1.200;
+ option routers 192.168.1.1;
+ option domain-name-servers 192.168.1.2, 192.168.1.3;
+ option domain-name \"dummy.domain.name.abc123xyz\";
+}
+"))
+
+(define dhcpd-v4-configuration
+  (dhcpd-configuration
+   (config-file minimal-dhcpd-v4-config-file)
+   (version "4")
+   (interfaces '("eth0"))))
+
+(define %dhcpd-os
+  (simple-operating-system
+   (static-networking-service "eth0" "192.168.1.4"
+                              #:netmask "255.255.255.0"
+                              #:gateway "192.168.1.1"
+                              #:name-servers '("192.168.1.2" "192.168.1.3"))
+   (service dhcpd-service-type dhcpd-v4-configuration)))
+
+(define (run-dhcpd-test)
+  (define os
+    (marionette-operating-system %dhcpd-os
+                                 #:imported-modules '((gnu services herd))))
+
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (ice-9 popen)
+                       (ice-9 rdelim)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "dhcpd")
+
+          (test-assert "pid file exists"
+            (marionette-eval
+             '(file-exists?
+               #$(dhcpd-configuration-pid-file dhcpd-v4-configuration))
+             marionette))
+
+          (test-assert "lease file exists"
+            (marionette-eval
+             '(file-exists?
+               #$(dhcpd-configuration-lease-file dhcpd-v4-configuration))
+             marionette))
+
+          (test-assert "run directory exists"
+            (marionette-eval
+             '(file-exists?
+               #$(dhcpd-configuration-run-directory dhcpd-v4-configuration))
+             marionette))
+
+          (test-assert "dhcpd is alive"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd)
+                             (srfi srfi-1))
+                (live-service-running
+                 (find (lambda (live)
+                         (memq 'dhcpv4-daemon
+                               (live-service-provision live)))
+                       (current-services))))
+             marionette))
+
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "dhcpd-test" test))
+
+(define %test-dhcpd
+  (system-test
+   (name "dhcpd")
+   (description "Test a running DHCP daemon configuration.")
+   (value (run-dhcpd-test))))