system: Add support for setuid binaries.

* gnu/system.scm (<operating-system>)[pam-services, setuid-programs]:
  New fields.
  (etc-directory)[bashrc]: Prepend /run/setuid-programs to $PATH.
  (operating-system-etc-directory): Honor
  'operating-system-pam-services'.
  (%setuid-programs): New variable.
  (operating-system-boot-script): Add (guix build utils) to the set of
  imported modules.  Call 'activate-setuid-programs' in boot script.
* gnu/system/linux.scm (base-pam-services): New procedure.
* guix/build/activation.scm (%setuid-directory): New variable.
  (activate-setuid-programs): New procedure.
* build-aux/hydra/demo-os.scm: Add 'pam-services' field.

4 files changed, 76 insertions, 8 deletions

diff --git a/build-aux/hydra/demo-os.scm b/build-aux/hydra/demo-os.scm
index c2ff012a1b..3987c4048d 100644
--- a/build-aux/hydra/demo-os.scm
+++ b/build-aux/hydra/demo-os.scm
@@ -34,6 +34,7 @@
              (gnu packages package-management)
 
              (gnu system shadow)                  ; 'user-account'
+             (gnu system linux)                   ; 'base-pam-services'
              (gnu services base)
              (gnu services networking)
              (gnu services xorg))
@@ -56,6 +57,9 @@
                                              #:gateway "10.0.2.2")
 
                   %base-services))
+ (pam-services
+  ;; Explicitly allow for empty passwords.
+  (base-pam-services #:allow-empty-passwords? #t))
  (packages (list bash coreutils findutils grep sed
                  procps psmisc less
                  guile-2.0 dmd guix util-linux inetutils
diff --git a/gnu/system.scm b/gnu/system.scm
index 4a85857582..ba105e2df1 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -106,7 +106,12 @@
   (locale   operating-system-locale)              ; string
 
   (services operating-system-services             ; list of monadic services
-            (default %base-services)))
+            (default %base-services))
+
+  (pam-services operating-system-pam-services     ; list of PAM services
+                (default (base-pam-services)))
+  (setuid-programs operating-system-setuid-programs
+                   (default %setuid-programs)))   ; list of string-valued gexps
 
 
 
@@ -191,6 +196,7 @@ export TZ=\"" timezone "\"
 export TZDIR=\"" tzdata "/share/zoneinfo\"
 
 export PATH=$HOME/.guix-profile/bin:" profile "/bin:" profile "/sbin
+export PATH=/run/setuid-programs:$PATH
 export CPATH=$HOME/.guix-profile/include:" profile "/include
 export LIBRARY_PATH=$HOME/.guix-profile/lib:" profile "/lib
 alias ls='ls -p --color'
@@ -238,8 +244,8 @@ alias ll='ls -l'
        (pam-services ->
                      ;; Services known to PAM.
                      (delete-duplicates
-                      (cons %pam-other-services
-                            (append-map service-pam-services services))))
+                      (append (operating-system-pam-services os)
+                              (append-map service-pam-services services))))
        (accounts    (operating-system-accounts os))
        (profile-drv (operating-system-profile os))
        (groups   -> (append (operating-system-groups os)
@@ -250,15 +256,29 @@ alias ll='ls -l'
                   #:timezone (operating-system-timezone os)
                   #:profile profile-drv)))
 
+(define %setuid-programs
+  ;; Default set of setuid-root programs.
+  (let ((shadow (@ (gnu packages admin) shadow)))
+    (list #~(string-append #$shadow "/bin/passwd")
+          #~(string-append #$shadow "/bin/su")
+          #~(string-append #$inetutils "/bin/ping"))))
+
 (define (operating-system-boot-script os)
   "Return the boot script for OS---i.e., the code started by the initrd once
 we're running in the final root."
+  (define %modules
+    '((guix build activation)
+      (guix build utils)))
+
   (mlet* %store-monad
       ((services (sequence %store-monad (operating-system-services os)))
        (etc      (operating-system-etc-directory os))
-       (modules  (imported-modules '((guix build activation))))
-       (compiled (compiled-modules '((guix build activation))))
+       (modules  (imported-modules %modules))
+       (compiled (compiled-modules %modules))
        (dmd-conf (dmd-configuration-file services)))
+    (define setuid-progs
+      (operating-system-setuid-programs os))
+
     (gexp->file "boot"
                 #~(begin
                     (eval-when (expand load eval)
@@ -272,6 +292,9 @@ we're running in the final root."
                     ;; Populate /etc.
                     (activate-etc #$etc)
 
+                    ;; Activate setuid programs.
+                    (activate-setuid-programs (list #$@setuid-progs))
+
                     ;; Start dmd.
                     (execl (string-append #$dmd "/bin/dmd")
                            "dmd" "--config" #$dmd-conf)))))
diff --git a/gnu/system/linux.scm b/gnu/system/linux.scm
index efe27c55c3..4030d8860e 100644
--- a/gnu/system/linux.scm
+++ b/gnu/system/linux.scm
@@ -29,8 +29,8 @@
   #:export (pam-service
             pam-entry
             pam-services->directory
-            %pam-other-services
-            unix-pam-service))
+            unix-pam-service
+            base-pam-services))
 
 ;;; Commentary:
 ;;;
@@ -152,4 +152,11 @@ should be the name of a file used as the message-of-the-day."
                               (list #~(string-append "motd=" #$motd)))))
                       (list unix))))))))
 
+(define* (base-pam-services #:key allow-empty-passwords?)
+  "Return the list of basic PAM services everyone would want."
+  (list %pam-other-services
+        (unix-pam-service "su" #:allow-empty-passwords? allow-empty-passwords?)
+        (unix-pam-service "passwd"
+                          #:allow-empty-passwords? allow-empty-passwords?)))
+
 ;;; linux.scm ends here
diff --git a/guix/build/activation.scm b/guix/build/activation.scm
index c8491677d3..6930a8c585 100644
--- a/guix/build/activation.scm
+++ b/guix/build/activation.scm
@@ -17,8 +17,10 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build activation)
+  #:use-module (guix build utils)
   #:use-module (ice-9 ftw)
-  #:export (activate-etc))
+  #:export (activate-etc
+            activate-setuid-programs))
 
 ;;; Commentary:
 ;;;
@@ -60,4 +62,36 @@
     (rm-f "/var/guix/gcroots/etc-directory")
     (symlink etc "/var/guix/gcroots/etc-directory")))
 
+(define %setuid-directory
+  ;; Place where setuid programs are stored.
+  "/run/setuid-programs")
+
+(define (activate-setuid-programs programs)
+  "Turn PROGRAMS, a list of file names, into setuid programs stored under
+%SETUID-DIRECTORY."
+  (define (make-setuid-program prog)
+    (let ((target (string-append %setuid-directory
+                                 "/" (basename prog))))
+      (catch 'system-error
+        (lambda ()
+          (link prog target))
+        (lambda args
+          ;; Perhaps PROG and TARGET live in a different file system, so copy
+          ;; PROG.
+          (copy-file prog target)))
+      (chown target 0 0)
+      (chmod target #o6555)))
+
+  (format #t "setting up setuid programs in '~a'...~%"
+          %setuid-directory)
+  (if (file-exists? %setuid-directory)
+      (for-each delete-file
+                (scandir %setuid-directory
+                         (lambda (file)
+                           (not (member file '("." ".."))))
+                         string<?))
+      (mkdir-p %setuid-directory))
+
+  (for-each make-setuid-program programs))
+
 ;;; activation.scm ends here