services: nfs: Add nfs-service-type.

* gnu/services/nfs.scm (<nfs-configuration>): New record.
(nfs-configuration, nfs-configuration?, nfs-configuration-nfs-utils,
nfs-configuration-nfs-version, nfs-configuration-exports,
nfs-configuration-rpcmountd-port, nfs-configuration-rpcstatd-port,
nfs-configuration-rpcbind, nfs-configuration-idmap-domain,
nfs-configuration-nfsd-port, nfs-configuration-nfsd-threads,
nfs-configuration-pipefs-directory, nfs-configuration-debug,
nfs-shepherd-services): New procedures.
(nfs-service-type): New variable.
* doc/guix.texi (Network File System): Document it.
* gnu/tests/nfs.scm (%test-nfs-server): New variable.
(%base-os): Use default value of rpcbind-service-type.

2 files changed, 334 insertions, 4 deletions

diff --git a/gnu/services/nfs.scm b/gnu/services/nfs.scm
index cd7e8fab01..ddc9e2c47e 100644
--- a/gnu/services/nfs.scm
+++ b/gnu/services/nfs.scm
@@ -22,6 +22,7 @@
   #:use-module (gnu services shepherd)
   #:use-module (gnu packages onc-rpc)
   #:use-module (gnu packages linux)
+  #:use-module (gnu packages nfs)
   #:use-module (guix)
   #:use-module (guix records)
   #:use-module (srfi srfi-1)
@@ -41,7 +42,11 @@
 
             gss-service-type
             gss-configuration
-            gss-configuration?))
+            gss-configuration?
+
+            nfs-service-type
+            nfs-configuration
+            nfs-configuration?))
 
 
 (define default-pipefs-directory "/var/lib/nfs/rpc_pipefs")
@@ -234,3 +239,177 @@
      (compose identity)
      (extend (lambda (config values) (first values)))
      (default-value (idmap-configuration)))))
+
+(define-record-type* <nfs-configuration>
+  nfs-configuration make-nfs-configuration
+  nfs-configuration?
+  (nfs-utils           nfs-configuration-nfs-utils
+                       (default nfs-utils))
+  (nfs-version         nfs-configuration-nfs-version
+                       (default #f)) ; string
+  (exports             nfs-configuration-exports
+                       (default '()))
+  (rpcmountd-port      nfs-configuration-rpcmountd-port
+                       (default #f))
+  (rpcstatd-port       nfs-configuration-rpcstatd-port
+                       (default #f))
+  (rpcbind             nfs-configuration-rpcbind
+                       (default rpcbind))
+  (idmap-domain        nfs-configuration-idmap-domain
+                       (default "localdomain"))
+  (nfsd-port           nfs-configuration-nfsd-port
+                       (default 2049))
+  (nfsd-threads        nfs-configuration-nfsd-threads
+                       (default 8))
+  (pipefs-directory    nfs-configuration-pipefs-directory
+                       (default default-pipefs-directory))
+  ;; List of modules to debug; any of nfsd, nfs, rpc, idmap, statd, or mountd.
+  (debug               nfs-configuration-debug
+                       (default '())))
+
+(define (nfs-shepherd-services config)
+  "Return a list of <shepherd-service> for the NFS daemons with CONFIG."
+  (match-record config <nfs-configuration>
+    (nfs-utils nfs-version exports
+               rpcmountd-port rpcstatd-port nfsd-port nfsd-threads
+               pipefs-directory debug)
+    (list (shepherd-service
+           (documentation "Run the NFS statd daemon.")
+           (provision '(rpc.statd))
+           (requirement '(rpcbind-daemon))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append nfs-utils "/sbin/rpc.statd")
+                     ;; TODO: notification support may require a little more
+                     ;; configuration work.
+                     "--no-notify"
+                     #$@(if (member 'statd debug)
+                            '("--no-syslog") ; verbose logging to stderr
+                            '())
+                     "--foreground"
+                     #$@(if rpcstatd-port
+                            '("--port" (number->string rpcstatd-port))
+                            '()))
+               #:pid-file "/var/run/rpc.statd.pid"))
+           (stop #~(make-kill-destructor)))
+          (shepherd-service
+           (documentation "Run the NFS mountd daemon.")
+           (provision '(rpc.mountd))
+           (requirement '(rpc.statd))
+           (start
+            #~(make-forkexec-constructor
+               (list #$(file-append nfs-utils "/sbin/rpc.mountd")
+                     #$@(if (member 'mountd debug)
+                            '("--debug" "all")
+                            '())
+                     #$@(if rpcmountd-port
+                            '("--port" (number->string rpcmountd-port))
+                            '()))))
+           (stop #~(make-kill-destructor)))
+          (shepherd-service
+           (documentation "Run the NFS daemon.")
+           (provision '(rpc.nfsd))
+           (requirement '(rpc.statd networking))
+           (start
+            #~(lambda _
+                (zero? (system* #$(file-append nfs-utils "/sbin/rpc.nfsd")
+                                #$@(if (member 'nfsd debug)
+                                       '("--debug")
+                                       '())
+                                "--port" #$(number->string nfsd-port)
+                                #$@(if nfs-version
+                                       '("--nfs-version" nfs-version)
+                                       '())
+                                #$(number->string nfsd-threads)))))
+           (stop
+            #~(lambda _
+                (zero?
+                 (system* #$(file-append nfs-utils "/sbin/rpc.nfsd") "0")))))
+          (shepherd-service
+           (documentation "Run the NFS mountd daemon and refresh exports.")
+           (provision '(nfs))
+           (requirement '(rpc.nfsd rpc.mountd rpc.statd rpcbind-daemon))
+           (start
+            #~(lambda _
+                (let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
+                  (cond
+                   ((member 'nfsd '#$debug)
+                    (system* rpcdebug "-m" "nfsd" "-s" "all"))
+                   ((member 'nfs '#$debug)
+                    (system* rpcdebug "-m" "nfs" "-s" "all"))
+                   ((member 'rpc '#$debug)
+                    (system* rpcdebug "-m" "rpc" "-s" "all"))))
+                (zero? (system*
+                        #$(file-append nfs-utils "/sbin/exportfs")
+                        "-r"            ; re-export
+                        "-a"            ; everthing
+                        "-v"            ; be verbose
+                        "-d" "all"      ; debug
+                        ))))
+           (stop
+            #~(lambda _
+                (let ((rpcdebug #$(file-append nfs-utils "/sbin/rpcdebug")))
+                  (cond
+                   ((member 'nfsd '#$debug)
+                    (system* rpcdebug "-m" "nfsd" "-c" "all"))
+                   ((member 'nfs '#$debug)
+                    (system* rpcdebug "-m" "nfs" "-c" "all"))
+                   ((member 'rpc '#$debug)
+                    (system* rpcdebug "-m" "rpc" "-c" "all"))))
+                #t))
+           (respawn? #f)))))
+
+(define nfs-service-type
+  (service-type
+   (name 'nfs)
+   (extensions
+    (list
+     (service-extension shepherd-root-service-type nfs-shepherd-services)
+     (service-extension activation-service-type
+                        (const #~(begin
+                                   (use-modules (guix build utils))
+                                   (system* "mount" "-t" "nfsd"
+                                            "nfsd" "/proc/fs/nfsd")
+
+                                   (mkdir-p "/var/lib/nfs")
+                                   ;; directory containing monitor list
+                                   (mkdir-p "/var/lib/nfs/sm")
+                                   ;; Needed for client recovery tracking
+                                   (mkdir-p "/var/lib/nfs/v4recovery")
+                                   (let ((user (getpw "nobody")))
+                                     (chown "/var/lib/nfs"
+                                            (passwd:uid user)
+                                            (passwd:gid user))
+                                     (chown "/var/lib/nfs/v4recovery"
+                                            (passwd:uid user)
+                                            (passwd:gid user)))
+                                   #t)))
+     (service-extension etc-service-type
+                        (lambda (config)
+                          `(("exports"
+                             ,(plain-file "exports"
+                                          (string-join
+                                           (map string-join
+                                                (nfs-configuration-exports config))
+                                           "\n"))))))
+     ;; The NFS service depends on these other services.  They are extended so
+     ;; that users don't need to configure them manually.
+     (service-extension idmap-service-type
+                        (lambda (config)
+                          (idmap-configuration
+                           (domain (nfs-configuration-idmap-domain config))
+                           (verbosity
+                            (if (member 'idmap (nfs-configuration-debug config))
+                                10 0))
+                           (pipefs-directory (nfs-configuration-pipefs-directory config))
+                           (nfs-utils (nfs-configuration-nfs-utils config)))))
+     (service-extension pipefs-service-type
+                        (lambda (config)
+                          (pipefs-configuration
+                           (mount-point (nfs-configuration-pipefs-directory config)))))
+     (service-extension rpcbind-service-type
+                        (lambda (config)
+                          (rpcbind-configuration
+                           (rpcbind (nfs-configuration-rpcbind config)))))))
+   (description
+    "Run all NFS daemons and refresh the list of exported file systems.")))
diff --git a/gnu/tests/nfs.scm b/gnu/tests/nfs.scm
index 7ef9f1f7bf..014d049ab5 100644
--- a/gnu/tests/nfs.scm
+++ b/gnu/tests/nfs.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;; Copyright © 2018 Clément Lassieur <clement@lassieur.org>
+;;; Copyright © 2019, 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,10 +34,12 @@
   #:use-module (gnu services nfs)
   #:use-module (gnu services networking)
   #:use-module (gnu packages onc-rpc)
+  #:use-module (gnu packages nfs)
   #:use-module (guix gexp)
   #:use-module (guix store)
   #:use-module (guix monads)
-  #:export (%test-nfs))
+  #:export (%test-nfs
+            %test-nfs-server))
 
 (define %base-os
   (operating-system
@@ -53,8 +56,7 @@
                rpcbind
                %base-packages))
     (services (cons*
-               (service rpcbind-service-type
-                        (rpcbind-configuration))
+               (service rpcbind-service-type)
                (service dhcp-client-service-type)
                %base-services))))
 
@@ -133,3 +135,152 @@
    (name "nfs")
    (description "Test some things related to NFS.")
    (value (run-nfs-test name "/var/run/rpcbind.sock"))))
+
+
+(define %nfs-os
+  (let ((os (simple-operating-system
+             (simple-service 'create-target-directory activation-service-type
+                             #~(begin
+                                 (mkdir "/remote")
+                                 (chmod "/remote" #o777)
+                                 #t))
+             (service dhcp-client-service-type)
+             (service nfs-service-type
+                      (nfs-configuration
+                       (debug '(nfs nfsd mountd))
+                       (exports '(("/export"
+                                   ;; crossmnt = This is the pseudo root.
+                                   ;; fsid=0 = root file system of the export
+                                   "*(ro,insecure,no_subtree_check,crossmnt,fsid=0)"))))))))
+    (operating-system
+      (inherit os)
+      (host-name "nfs-server")
+      ;; We need to use a tmpfs here, because the test system's root file
+      ;; system cannot be re-exported via NFS.
+      (file-systems (cons
+                     (file-system
+                       (device "none")
+                       (mount-point "/export")
+                       (type "tmpfs")
+                       (create-mount-point? #t))
+                     %base-file-systems))
+      (services
+       ;; Enable debugging output.
+       (modify-services (operating-system-user-services os)
+         (syslog-service-type config
+                              =>
+                              (syslog-configuration
+                               (inherit config)
+                               (config-file
+                                (plain-file
+                                 "syslog.conf"
+                                 "*.* /dev/console\n")))))))))
+
+(define (run-nfs-server-test)
+  "Run a test of an OS running a service of NFS-SERVICE-TYPE."
+  (define os
+    (marionette-operating-system
+     %nfs-os
+     #:requirements '(nscd)
+     #:imported-modules '((gnu services herd)
+                          (guix combinators))))
+  (define test
+    (with-imported-modules '((gnu build marionette))
+      #~(begin
+          (use-modules (gnu build marionette)
+                       (srfi srfi-64))
+
+          (define marionette
+            (make-marionette (list #$(virtual-machine os))))
+          (define (wait-for-file file)
+            ;; Wait until FILE  exists in the guest
+            (marionette-eval
+             `(let loop ((i 10))
+                (cond ((file-exists? ,file)
+                       #t)
+                      ((> i 0)
+                       (sleep 1)
+                       (loop (- i 1)))
+                      (else
+                       (error "File didn't show up: " ,file))))
+             marionette))
+
+          (mkdir #$output)
+          (chdir #$output)
+
+          (test-begin "nfs-daemon")
+          (marionette-eval
+           '(begin
+              (current-output-port
+               (open-file "/dev/console" "w0"))
+              (chmod "/export" #o777)
+              (with-output-to-file "/export/hello"
+                (lambda () (display "hello world")))
+              (chmod "/export/hello" #o777))
+           marionette)
+
+          (test-assert "nscd PID file is created"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'nscd))
+             marionette))
+
+          (test-assert "nscd is listening on its socket"
+            (marionette-eval
+             ;; XXX: Work around a race condition in nscd: nscd creates its
+             ;; PID file before it is listening on its socket.
+             '(let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+                (let try ()
+                  (catch 'system-error
+                    (lambda ()
+                      (connect sock AF_UNIX "/var/run/nscd/socket")
+                      (close-port sock)
+                      (format #t "nscd is ready~%")
+                      #t)
+                    (lambda args
+                      (format #t "waiting for nscd...~%")
+                      (usleep 500000)
+                      (try)))))
+             marionette))
+
+          (test-assert "network is up"
+            (marionette-eval
+             '(begin
+                (use-modules (gnu services herd))
+                (start-service 'networking))
+             marionette))
+
+          ;; Wait for the NFS services to be up and running.
+          (test-assert "nfs services are running"
+            (and (marionette-eval
+                  '(begin
+                     (use-modules (gnu services herd))
+                     (start-service 'nfs))
+                  marionette)
+                 (wait-for-file "/var/run/rpc.statd.pid")))
+
+          (test-assert "nfs share is advertised"
+            (marionette-eval
+             '(zero? (system* (string-append #$nfs-utils "/sbin/showmount")
+                              "-e" "nfs-server"))
+             marionette))
+
+          (test-assert "nfs share mounted"
+            (marionette-eval
+             '(begin
+                (and (zero? (system* (string-append #$nfs-utils "/sbin/mount.nfs4")
+                                     "nfs-server:/" "/remote" "-v"))
+                     (file-exists? "/remote/hello")))
+             marionette))
+          (test-end)
+          (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
+
+  (gexp->derivation "nfs-server-test" test))
+
+(define %test-nfs-server
+  (system-test
+   (name "nfs-server")
+   (description "Test that an NFS server can be started and exported
+directories can be mounted.")
+   (value (run-nfs-server-test))))