Merge branch 'master' into core-updates

1 files changed, 178 insertions, 86 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 2780d124c7..805ba7d12c 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -4,6 +4,8 @@
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
 ;;; Copyright © 2016 Leo Famulari <leo@famulari.name>
+;;; Copyright © 2016 David Craven <david@craven.ch>
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,11 +33,11 @@
   #:use-module (gnu system mapped-devices)
   #:use-module (gnu packages admin)
   #:use-module ((gnu packages linux)
-                #:select (eudev kbd e2fsprogs lvm2 fuse alsa-utils crda gpm))
+                #:select (alsa-utils crda eudev e2fsprogs fuse gpm kbd lvm2 rng-tools))
   #:use-module ((gnu packages base)
                 #:select (canonical-package glibc))
   #:use-module (gnu packages package-management)
-  #:use-module (gnu packages lsh)
+  #:use-module (gnu packages ssh)
   #:use-module (gnu packages lsof)
   #:use-module ((gnu build file-systems)
                 #:select (mount-flags->bit-mask))
@@ -81,6 +83,7 @@
             nscd-service-type
             nscd-service
             syslog-service
+            syslog-service-type
             %default-syslog.conf
 
             guix-configuration
@@ -94,7 +97,12 @@
             gpm-service-type
             gpm-service
 
+            urandom-seed-service-type
             urandom-seed-service
+            rngd-service-type
+            rngd-service
+            pam-limits-service-type
+            pam-limits-service
 
             %base-services))
 
@@ -224,59 +232,58 @@ FILE-SYSTEM."
         (create? (file-system-create-mount-point? file-system))
         (dependencies (file-system-dependencies file-system)))
     (if (file-system-mount? file-system)
-        (list
-         (shepherd-service
-          (provision (list (file-system->shepherd-service-name file-system)))
-          (requirement `(root-file-system
-                         ,@(map dependency->shepherd-service-name dependencies)))
-          (documentation "Check, mount, and unmount the given file system.")
-          (start #~(lambda args
-                     ;; FIXME: Use or factorize with 'mount-file-system'.
-                     (let ((device (canonicalize-device-spec #$device '#$title))
-                           (flags  #$(mount-flags->bit-mask
-                                      (file-system-flags file-system))))
-                       #$(if create?
-                             #~(mkdir-p #$target)
-                             #~#t)
-                       #$(if check?
-                             #~(begin
-                                 ;; Make sure fsck.ext2 & co. can be found.
-                                 (setenv "PATH"
-                                         (string-append
-                                          #$e2fsprogs "/sbin:"
-                                          "/run/current-system/profile/sbin:"
-                                          (getenv "PATH")))
-                                 (check-file-system device #$type))
-                             #~#t)
-
-                       (mount device #$target #$type flags
-                              #$(file-system-options file-system))
-
-                       ;; For read-only bind mounts, an extra remount is
-                       ;; needed, as per <http://lwn.net/Articles/281157/>,
-                       ;; which still applies to Linux 4.0.
-                       (when (and (= MS_BIND (logand flags MS_BIND))
-                                  (= MS_RDONLY (logand flags MS_RDONLY)))
-                         (mount device #$target #$type
-                                (logior MS_BIND MS_REMOUNT MS_RDONLY))))
-                     #t))
-          (stop #~(lambda args
-                    ;; Normally there are no processes left at this point, so
-                    ;; TARGET can be safely unmounted.
-
-                    ;; Make sure PID 1 doesn't keep TARGET busy.
-                    (chdir "/")
-
-                    (umount #$target)
-                    #f))
-
-          ;; We need an additional module.
-          (modules `(((gnu build file-systems)
-                      #:select (check-file-system canonicalize-device-spec))
-                     ,@%default-modules))
-          (imported-modules `((gnu build file-systems)
-                              (guix build bournish)
-                              ,@%default-imported-modules))))
+        (with-imported-modules '((gnu build file-systems)
+                                 (guix build bournish))
+          (list
+           (shepherd-service
+            (provision (list (file-system->shepherd-service-name file-system)))
+            (requirement `(root-file-system
+                           ,@(map dependency->shepherd-service-name dependencies)))
+            (documentation "Check, mount, and unmount the given file system.")
+            (start #~(lambda args
+                       ;; FIXME: Use or factorize with 'mount-file-system'.
+                       (let ((device (canonicalize-device-spec #$device '#$title))
+                             (flags  #$(mount-flags->bit-mask
+                                        (file-system-flags file-system))))
+                         #$(if create?
+                               #~(mkdir-p #$target)
+                               #~#t)
+                         #$(if check?
+                               #~(begin
+                                   ;; Make sure fsck.ext2 & co. can be found.
+                                   (setenv "PATH"
+                                           (string-append
+                                            #$e2fsprogs "/sbin:"
+                                            "/run/current-system/profile/sbin:"
+                                            (getenv "PATH")))
+                                   (check-file-system device #$type))
+                               #~#t)
+
+                         (mount device #$target #$type flags
+                                #$(file-system-options file-system))
+
+                         ;; For read-only bind mounts, an extra remount is
+                         ;; needed, as per <http://lwn.net/Articles/281157/>,
+                         ;; which still applies to Linux 4.0.
+                         (when (and (= MS_BIND (logand flags MS_BIND))
+                                    (= MS_RDONLY (logand flags MS_RDONLY)))
+                           (mount device #$target #$type
+                                  (logior MS_BIND MS_REMOUNT MS_RDONLY))))
+                       #t))
+            (stop #~(lambda args
+                      ;; Normally there are no processes left at this point, so
+                      ;; TARGET can be safely unmounted.
+
+                      ;; Make sure PID 1 doesn't keep TARGET busy.
+                      (chdir "/")
+
+                      (umount #$target)
+                      #f))
+
+            ;; We need an additional module.
+            (modules `(((gnu build file-systems)
+                        #:select (check-file-system canonicalize-device-spec))
+                       ,@%default-modules)))))
         '())))
 
 (define file-system-service-type
@@ -484,7 +491,47 @@ stopped before 'kill' is called."
 (define (urandom-seed-service)
   (service urandom-seed-service-type #f))
 
-
+
+;;;
+;;; Add hardware random number generator to entropy pool.
+;;;
+
+(define-record-type* <rngd-configuration>
+  rngd-configuration make-rngd-configuration
+  rngd-configuration?
+  (rng-tools rngd-configuration-rng-tools)        ;package
+  (device    rngd-configuration-device))          ;string
+
+(define rngd-service-type
+  (shepherd-service-type
+    'rngd
+    (lambda (config)
+      (define rng-tools (rngd-configuration-rng-tools config))
+      (define device (rngd-configuration-device config))
+
+      (define rngd-command
+        (list #~(string-append #$rng-tools "/sbin/rngd")
+              "-f" "-r" device))
+
+      (shepherd-service
+        (documentation "Add TRNG to entropy pool.")
+        (requirement '(udev))
+        (provision '(trng))
+        (start #~(make-forkexec-constructor #$@rngd-command))
+        (stop #~(make-kill-destructor))))))
+
+(define* (rngd-service #:key
+                       (rng-tools rng-tools)
+                       (device "/dev/hwrng"))
+  "Return a service that runs the @command{rngd} program from @var{rng-tools}
+to add @var{device} to the kernel's entropy pool.  The service will fail if
+@var{device} does not exist."
+  (service rngd-service-type
+           (rngd-configuration
+            (rng-tools rng-tools)
+            (device device))))
+
+
 ;;;
 ;;; System-wide environment variables.
 ;;;
@@ -790,6 +837,11 @@ the tty to run, among other things."
                                           "/sbin/nscd")
                            "-f" #$nscd.conf "--foreground")
 
+                     ;; Wait for the PID file.  However, the PID file is
+                     ;; written before nscd is actually listening on its
+                     ;; socket (XXX).
+                     #:pid-file "/var/run/nscd/nscd.pid"
+
                      #:environment-variables
                      (list (string-append "LD_LIBRARY_PATH="
                                           (string-join
@@ -875,6 +927,46 @@ settings.
 information on the configuration file syntax."
   (service syslog-service-type config-file))
 
+(define pam-limits-service-type
+  (let ((security-limits
+         ;; Create /etc/security containing the provided "limits.conf" file.
+         (lambda (limits-file)
+           `(("security"
+              ,(computed-file
+                "security"
+                #~(begin
+                    (mkdir #$output)
+                    (stat #$limits-file)
+                    (symlink #$limits-file
+                             (string-append #$output "/limits.conf"))))))))
+        (pam-extension
+         (lambda (pam)
+           (let ((pam-limits (pam-entry
+                              (control "required")
+                              (module "pam_limits.so")
+                              (arguments '("conf=/etc/security/limits.conf")))))
+             (if (member (pam-service-name pam)
+                         '("login" "su" "slim"))
+                 (pam-service
+                  (inherit pam)
+                  (session (cons pam-limits
+                                 (pam-service-session pam))))
+                 pam)))))
+    (service-type
+     (name 'limits)
+     (extensions
+      (list (service-extension etc-service-type security-limits)
+            (service-extension pam-root-service-type
+                               (lambda _ (list pam-extension))))))))
+
+(define* (pam-limits-service #:optional (limits '()))
+  "Return a service that makes selected programs respect the list of
+pam-limits-entry specified in LIMITS via pam_limits.so."
+  (service pam-limits-service-type
+           (plain-file "limits.conf"
+                       (string-join (map pam-limits-entry->string limits)
+                                    "\n"))))
+
 
 ;;;
 ;;; Guix services.
@@ -1088,44 +1180,44 @@ archive}).  If that is not the case, the service will fail to start."
   "Return the union of the @code{lib/udev/rules.d} directories found in each
 item of @var{packages}."
   (define build
-    #~(begin
-        (use-modules (guix build union)
-                     (guix build utils)
-                     (srfi srfi-1)
-                     (srfi srfi-26))
+    (with-imported-modules '((guix build union)
+                             (guix build utils))
+      #~(begin
+          (use-modules (guix build union)
+                       (guix build utils)
+                       (srfi srfi-1)
+                       (srfi srfi-26))
 
-        (define %standard-locations
-          '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
+          (define %standard-locations
+            '("/lib/udev/rules.d" "/libexec/udev/rules.d"))
 
-        (define (rules-sub-directory directory)
-          ;; Return the sub-directory of DIRECTORY containing udev rules, or
-          ;; #f if none was found.
-          (find directory-exists?
-                (map (cut string-append directory <>) %standard-locations)))
+          (define (rules-sub-directory directory)
+            ;; Return the sub-directory of DIRECTORY containing udev rules, or
+            ;; #f if none was found.
+            (find directory-exists?
+                  (map (cut string-append directory <>) %standard-locations)))
 
-        (mkdir-p (string-append #$output "/lib/udev"))
-        (union-build (string-append #$output "/lib/udev/rules.d")
-                     (filter-map rules-sub-directory '#$packages))))
+          (mkdir-p (string-append #$output "/lib/udev"))
+          (union-build (string-append #$output "/lib/udev/rules.d")
+                       (filter-map rules-sub-directory '#$packages)))))
 
-  (computed-file "udev-rules" build
-                 #:modules '((guix build union)
-                             (guix build utils))))
+  (computed-file "udev-rules" build))
 
 (define (udev-rule file-name contents)
   "Return a directory with a udev rule file FILE-NAME containing CONTENTS."
   (computed-file file-name
-                 #~(begin
-                     (use-modules (guix build utils))
-
-                     (define rules.d
-                       (string-append #$output "/lib/udev/rules.d"))
-
-                     (mkdir-p rules.d)
-                     (call-with-output-file
-                         (string-append rules.d "/" #$file-name)
-                       (lambda (port)
-                         (display #$contents port))))
-                 #:modules '((guix build utils))))
+                 (with-imported-modules '((guix build utils))
+                   #~(begin
+                       (use-modules (guix build utils))
+
+                       (define rules.d
+                         (string-append #$output "/lib/udev/rules.d"))
+
+                       (mkdir-p rules.d)
+                       (call-with-output-file
+                           (string-append rules.d "/" #$file-name)
+                         (lambda (port)
+                           (display #$contents port)))))))
 
 (define kvm-udev-rule
   ;; Return a directory with a udev rule that changes the group of /dev/kvm to