gnu: setuid: add setuid-program-base-perms field to <setuid-program>

* gnu/system/setuid.scm (setuid-program-base-perms): new field of
  <setuid-program>.  Export it.
* gnu/services.scm (setuid-program->activation-gexp): include base-perms in
  gexp.
* gnu/build/activation.scm (activate-setuid-programs): honor
  setuid-program-base-perms.
---
 gnu/build/activation.scm | 10 ++++++----
 gnu/services.scm         |  6 ++++--
 gnu/system/setuid.scm    |  7 ++++++-
 3 files changed, 16 insertions(+), 7 deletions(-)

diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index eea2233563..a76e8af700 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -284,10 +284,10 @@ (define %setuid-directory
 (define (activate-setuid-programs programs)
   "Turn PROGRAMS, a list of file setuid-programs record, into setuid programs
 stored under %SETUID-DIRECTORY."
-  (define (make-setuid-program program setuid? setgid? uid gid)
+  (define (make-setuid-program program setuid? setgid? uid gid base-perms)
     (let ((target (string-append %setuid-directory
                                  "/" (basename program)))
-          (mode (+ #o0555                   ; base permissions
+          (mode (+ (logand #o777 base-perms)
                    (if setuid? #o4000 0)    ; setuid bit
                    (if setgid? #o2000 0)))) ; setgid bit
       (copy-file program target)
@@ -318,8 +318,10 @@ (define (make-setuid-program program setuid? setgid? uid gid)
                                 ((? integer?) user)))
                          (gid (match group
                                 ((? string?) (group:gid (getgrnam group)))
-                                ((? integer?) group))))
-                    (make-setuid-program program-name setuid? setgid? uid gid)))
+                                ((? integer?) group)))
+                         (base-perms (setuid-program-base-perms program)))
+                    (make-setuid-program program-name setuid? setgid? uid gid
+                                         base-perms)))
                 (lambda args
                   ;; If we fail to create a setuid program, better keep going
                   ;; so that we don't leave %SETUID-DIRECTORY empty or
diff --git a/gnu/services.scm b/gnu/services.scm
index 2abef557d4..c5a4173d1c 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -818,13 +818,15 @@ (define (setuid-program->activation-gexp programs)
                                (setuid?      (setuid-program-setuid? program))
                                (setgid?      (setuid-program-setgid? program))
                                (user         (setuid-program-user program))
-                               (group        (setuid-program-group program)) )
+                               (group        (setuid-program-group program))
+                               (base-perms   (setuid-program-base-perms program)))
                            #~(setuid-program
                               (setuid? #$setuid?)
                               (setgid? #$setgid?)
                               (user    #$user)
                               (group   #$group)
-                              (program #$program-name))))
+                              (program #$program-name)
+                              (base-perms #$base-perms))))
                        programs)))
     (with-imported-modules (source-module-closure
                             '((gnu system setuid)))
diff --git a/gnu/system/setuid.scm b/gnu/system/setuid.scm
index 83111d932c..2cc0d22b65 100644
--- a/gnu/system/setuid.scm
+++ b/gnu/system/setuid.scm
@@ -25,6 +25,7 @@ (define-module (gnu system setuid)
             setuid-program-setgid?
             setuid-program-user
             setuid-program-group
+            setuid-program-base-perms
 
             file-like->setuid-program))
 
@@ -51,7 +52,11 @@ (define-record-type* <setuid-program>
                  (default 0))
   ;; Group we want to set this to (defaults to root)
   (group         setuid-program-group   ;integer or string
-                 (default 0)))
+                 (default 0))
+  ;; Base permissions (as passed to chmod) for the program.  Bits above #o777
+  ;; will be ignored.
+  (base-perms    setuid-program-base-perms  ;integer
+                 (default #o555)))
 
 (define (file-like->setuid-program program)
   (setuid-program (program program)))
-- 
2.38.1