Merge branch 'master' into core-updates

3 files changed, 204 insertions, 60 deletions

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 712222bdde..95edba6e7c 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -33,8 +33,10 @@
                 #:select (mount-flags->bit-mask))
   #:use-module (guix gexp)
   #:use-module (guix monads)
+  #:use-module (guix records)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
   #:use-module (ice-9 format)
   #:export (root-file-system-service
             file-system-service
@@ -46,6 +48,16 @@
             console-font-service
             udev-service
             mingetty-service
+
+            %nscd-default-caches
+            %nscd-default-configuration
+
+            nscd-configuration
+            nscd-configuration?
+
+            nscd-cache
+            nscd-cache?
+
             nscd-service
             syslog-service
             guix-service
@@ -374,9 +386,110 @@ the ``message of the day''."
                                #:allow-empty-passwords? allow-empty-passwords?
                                #:motd motd)))))))
 
-(define* (nscd-service #:key (glibc (canonical-package glibc)))
-  "Return a service that runs libc's name service cache daemon (nscd)."
-  (with-monad %store-monad
+(define-record-type* <nscd-configuration> nscd-configuration
+  make-nscd-configuration
+  nscd-configuration?
+  (log-file    nscd-configuration-log-file        ;string
+               (default "/var/log/nscd.log"))
+  (debug-level nscd-debug-level                   ;integer
+               (default 0))
+  ;; TODO: See nscd.conf in glibc for other options to add.
+  (caches     nscd-configuration-caches           ;list of <nscd-cache>
+              (default %nscd-default-caches)))
+
+(define-record-type* <nscd-cache> nscd-cache make-nscd-cache
+  nscd-cache?
+  (database              nscd-cache-database)              ;symbol
+  (positive-time-to-live nscd-cache-positive-time-to-live) ;integer
+  (negative-time-to-live nscd-cache-negative-time-to-live
+                         (default 20))             ;integer
+  (suggested-size        nscd-cache-suggested-size ;integer ("default module
+                                                   ;of hash table")
+                         (default 211))
+  (check-files?          nscd-cache-check-files?  ;Boolean
+                         (default #t))
+  (persistent?           nscd-cache-persistent?   ;Boolean
+                         (default #t))
+  (shared?               nscd-cache-shared?       ;Boolean
+                         (default #t))
+  (max-database-size     nscd-cache-max-database-size ;integer
+                         (default (* 32 (expt 2 20))))
+  (auto-propagate?       nscd-cache-auto-propagate? ;Boolean
+                         (default #t)))
+
+(define %nscd-default-caches
+  ;; Caches that we want to enable by default.  Note that when providing an
+  ;; empty nscd.conf, all caches are disabled.
+  (list (nscd-cache (database 'hosts)
+
+                    ;; Aggressively cache the host name cache to improve
+                    ;; privacy and resilience.
+                    (positive-time-to-live (* 3600 12))
+                    (negative-time-to-live 20)
+                    (persistent? #t))
+
+        (nscd-cache (database 'services)
+
+                    ;; Services are unlikely to change, so we can be even more
+                    ;; aggressive.
+                    (positive-time-to-live (* 3600 24))
+                    (negative-time-to-live 3600)
+                    (check-files? #t)             ;check /etc/services changes
+                    (persistent? #t))))
+
+(define %nscd-default-configuration
+  ;; Default nscd configuration.
+  (nscd-configuration))
+
+(define (nscd.conf-file config)
+  "Return the @file{nscd.conf} configuration file for @var{config}, an
+@code{<nscd-configuration>} object."
+  (define cache->config
+    (match-lambda
+     (($ <nscd-cache> (= symbol->string database)
+                      positive-ttl negative-ttl size check-files?
+                      persistent? shared? max-size propagate?)
+      (string-append "\nenable-cache\t" database "\tyes\n"
+
+                     "positive-time-to-live\t" database "\t"
+                     (number->string positive-ttl) "\n"
+                     "negative-time-to-live\t" database "\t"
+                     (number->string negative-ttl) "\n"
+                     "suggested-size\t" database "\t"
+                     (number->string size) "\n"
+                     "check-files\t" database "\t"
+                     (if check-files? "yes\n" "no\n")
+                     "persistent\t" database "\t"
+                     (if persistent? "yes\n" "no\n")
+                     "shared\t" database "\t"
+                     (if shared? "yes\n" "no\n")
+                     "max-db-size\t" database "\t"
+                     (number->string max-size) "\n"
+                     "auto-propagate\t" database "\t"
+                     (if propagate? "yes\n" "no\n")))))
+
+  (match config
+    (($ <nscd-configuration> log-file debug-level caches)
+     (text-file "nscd.conf"
+                (string-append "\
+# Configuration of libc's name service cache daemon (nscd).\n\n"
+                               (if log-file
+                                   (string-append "logfile\t" log-file)
+                                   "")
+                               "\n"
+                               (if debug-level
+                                   (string-append "debug-level\t"
+                                                  (number->string debug-level))
+                                   "")
+                               "\n"
+                               (string-concatenate
+                                (map cache->config caches)))))))
+
+(define* (nscd-service #:optional (config %nscd-default-configuration)
+                       #:key (glibc (canonical-package glibc)))
+  "Return a service that runs libc's name service cache daemon (nscd) with the
+given @var{config}---an @code{<nscd-configuration>} object."
+  (mlet %store-monad ((nscd.conf (nscd.conf-file config)))
     (return (service
              (documentation "Run libc's name service cache daemon (nscd).")
              (provision '(nscd))
@@ -388,7 +501,7 @@ the ``message of the day''."
 
              (start #~(make-forkexec-constructor
                        (list (string-append #$glibc "/sbin/nscd")
-                             "-f" "/dev/null" "--foreground")))
+                             "-f" #$nscd.conf "--foreground")))
              (stop #~(make-kill-destructor))
 
              (respawn? #f)))))
diff --git a/gnu/services/networking.scm b/gnu/services/networking.scm
index 1cb501bb7a..db9be8cfbd 100644
--- a/gnu/services/networking.scm
+++ b/gnu/services/networking.scm
@@ -80,60 +80,62 @@ fe80::1%lo0 apps.facebook.com\n")
                                     gateway
                                     (provision '(networking))
                                     (name-servers '())
-                                    (inetutils inetutils)
                                     (net-tools net-tools))
   "Return a service that starts @var{interface} with address @var{ip}.  If
 @var{gateway} is true, it must be a string specifying the default network
 gateway."
+  (define loopback?
+    (memq 'loopback provision))
 
-  ;; TODO: Eventually we should do this using Guile's networking procedures,
-  ;; like 'configure-qemu-networking' does, but the patch that does this is
-  ;; not yet in stock Guile.
+  ;; TODO: Eventually replace 'route' with bindings for the appropriate
+  ;; ioctls.
   (with-monad %store-monad
     (return
      (service
 
       ;; Unless we're providing the loopback interface, wait for udev to be up
       ;; and running so that INTERFACE is actually usable.
-      (requirement (if (memq 'loopback provision)
-                       '()
-                       '(udev)))
+      (requirement (if loopback? '() '(udev)))
 
       (documentation
        "Bring up the networking interface using a static IP address.")
       (provision provision)
       (start #~(lambda _
                  ;; Return #t if successfully started.
-                 (and (zero? (system* (string-append #$inetutils
-                                                     "/bin/ifconfig")
-                                      "-i" #$interface "-A" #$ip
-                                      "-i" #$interface "--up"))
-                      #$(if gateway
-                            #~(zero? (system* (string-append #$net-tools
-                                                             "/sbin/route")
-                                              "add" "-net" "default"
-                                              "gw" #$gateway))
-                            #t)
-                      #$(if (pair? name-servers)
-                            #~(call-with-output-file "/etc/resolv.conf"
-                                (lambda (port)
-                                  (display
-                                   "# Generated by 'static-networking-service'.\n"
-                                   port)
-                                  (for-each (lambda (server)
-                                              (format port "nameserver ~a~%"
-                                                      server))
-                                            '#$name-servers)))
-                            #t))))
+                 (let* ((addr     (inet-pton AF_INET #$ip))
+                        (sockaddr (make-socket-address AF_INET addr 0)))
+                   (configure-network-interface #$interface sockaddr
+                                                (logior IFF_UP
+                                                        #$(if loopback?
+                                                              #~IFF_LOOPBACK
+                                                              0))))
+                 #$(if gateway
+                       #~(zero? (system* (string-append #$net-tools
+                                                        "/sbin/route")
+                                         "add" "-net" "default"
+                                         "gw" #$gateway))
+                       #t)
+                 #$(if (pair? name-servers)
+                       #~(call-with-output-file "/etc/resolv.conf"
+                           (lambda (port)
+                             (display
+                              "# Generated by 'static-networking-service'.\n"
+                              port)
+                             (for-each (lambda (server)
+                                         (format port "nameserver ~a~%"
+                                                 server))
+                                       '#$name-servers)))
+                       #t)))
       (stop #~(lambda _
                 ;; Return #f is successfully stopped.
-                (not (and (system* (string-append #$inetutils "/bin/ifconfig")
-                                   #$interface "down")
-                          #$(if gateway
-                                #~(system* (string-append #$net-tools
-                                                          "/sbin/route")
-                                           "del" "-net" "default")
-                                #t)))))
+                (let ((sock (socket AF_INET SOCK_STREAM 0)))
+                  (set-network-interface-flags sock #$interface 0)
+                  (close-port sock))
+                (not #$(if gateway
+                           #~(system* (string-append #$net-tools
+                                                     "/sbin/route")
+                                      "del" "-net" "default")
+                           #t))))
       (respawn? #f)))))
 
 (define* (dhcp-client-service #:key (dhcp isc-dhcp))
diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm
index fbf96c799b..27a72e8019 100644
--- a/gnu/services/xorg.scm
+++ b/gnu/services/xorg.scm
@@ -36,7 +36,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (xorg-start-command
-
+            %default-xsessions
             %default-slim-theme
             %default-slim-theme-name
             slim-service))
@@ -136,9 +136,10 @@ EndSection
 
 (define* (xinitrc #:key
                   (guile (canonical-package guile-2.0))
-                  (ratpoison ratpoison)
-                  (windowmaker windowmaker))
-  "Return a system-wide xinitrc script that starts the specified X session."
+                  fallback-session)
+  "Return a system-wide xinitrc script that starts the specified X session,
+which should be passed to this script as the first argument.  If not, the
+@var{fallback-session} will be used."
   (define builder
     #~(begin
         (use-modules (ice-9 match))
@@ -155,20 +156,14 @@ EndSection
               (execl shell shell "--login" "-c"
                      (string-join (cons command args))))))
 
-        ;; First, try to run ~/.xsession.
-        (let* ((home     (getenv "HOME"))
-               (xsession (string-append home "/.xsession")))
-          (exec-from-login-shell xsession))
-
-        ;; Then try a pre-configured session type.
-        (let ((ratpoison (string-append #$ratpoison "/bin/ratpoison"))
-              (wmaker    (string-append #$windowmaker "/bin/wmaker")))
-          (match (command-line)
-            ((_ "ratpoison")
-             (exec-from-login-shell ratpoison))
-            (_
-             (exec-from-login-shell wmaker))))))
-
+        (let ((home (getenv "HOME"))
+              (session (match (command-line)
+                         ((_ x) x)
+                         (_     #$fallback-session))))
+          ;; First, try to run ~/.xsession.
+          (exec-from-login-shell (string-append home "/.xsession"))
+          ;; Then try to start the specified session.
+          (exec-from-login-shell session))))
   (gexp->script "xinitrc" builder))
 
 
@@ -176,6 +171,35 @@ EndSection
 ;;; SLiM log-in manager.
 ;;;
 
+(define %default-xsessions
+  ;; Default xsessions available for log-in manager, representing as a list of
+  ;; monadic desktop entries.
+  (list (text-file* "wmaker.desktop" "
+[Desktop Entry]
+Name=Window Maker
+Exec=" windowmaker "/bin/wmaker
+Type=Application
+")
+        (text-file* "ratpoison.desktop" "
+[Desktop Entry]
+Name=Ratpoison
+Exec=" ratpoison "/bin/ratpoison
+Type=Application
+")))
+
+(define (xsessions-directory sessions)
+  "Return a directory containing SESSIONS, which should be a list of monadic
+desktop entries."
+  (mlet %store-monad ((sessions (sequence %store-monad sessions)))
+    (define builder
+      #~(begin
+          (mkdir #$output)
+          (for-each (lambda (session)
+                      (symlink session (string-append #$output "/"
+                                                      (basename session))))
+                    '#$sessions)))
+    (gexp->derivation "xsessions-dir" builder)))
+
 (define %default-slim-theme
   ;; Theme based on work by Felipe López.
   #~(string-append #$%artwork-repository "/slim"))
@@ -191,6 +215,9 @@ EndSection
                        (theme %default-slim-theme)
                        (theme-name %default-slim-theme-name)
                        (xauth xauth) (dmd dmd) (bash bash)
+                       (sessions %default-xsessions)
+                       (auto-login-session #~(string-append #$windowmaker
+                                                            "/bin/wmaker"))
                        startx)
   "Return a service that spawns the SLiM graphical login manager, which in
 turn starts the X display server with @var{startx}, a command as returned by
@@ -198,7 +225,7 @@ turn starts the X display server with @var{startx}, a command as returned by
 
 When @var{allow-empty-passwords?} is true, allow logins with an empty
 password.  When @var{auto-login?} is true, log in automatically as
-@var{default-user}.
+@var{default-user} with @var{auto-login-session}.
 
 If @var{theme} is @code{#f}, the use the default log-in theme; otherwise
 @var{theme} must be a gexp denoting the name of a directory containing the
@@ -207,7 +234,9 @@ theme."
 
   (define (slim.cfg)
     (mlet %store-monad ((startx  (or startx (xorg-start-command)))
-                        (xinitrc (xinitrc)))
+                        (xinitrc (xinitrc #:fallback-session
+                                          auto-login-session))
+                        (sessiondir (xsessions-directory sessions)))
       (text-file* "slim.cfg"  "
 default_path /run/current-system/profile/bin
 default_xserver " startx "
@@ -218,7 +247,7 @@ authfile /var/run/slim.auth
 # The login command.  '%session' is replaced by the chosen session name, one
 # of the names specified in the 'sessions' setting: 'wmaker', 'xfce', etc.
 login_cmd  exec " xinitrc " %session
-sessions   wmaker,ratpoison
+sessiondir " sessiondir "
 
 halt_cmd " dmd "/sbin/halt
 reboot_cmd " dmd "/sbin/reboot