system: Handle 'setuid-programs' deprecation handling as a field sanitizer.
Previously, evaluating an OS configuration with a childhurd (for instance) would produce tens of lines like: guix system: warning: representing setuid programs with '#<file-append #<package shadow@4.8.1 gnu/packages/admin.scm:798 7ff97f6f7640> "/bin/passwd">' is deprecated; use 'setuid-program' instead Now, it prints this one line: gnu/system/hurd.scm:105:2: warning: representing setuid programs with file-like objects is deprecated; use 'setuid-program' instead This change also means that extensions of 'setuid-program-service-type' now have to provide a list of <setuid-program>, so it's stricter in this sense. * gnu/services.scm (setuid-program-file-like-deprecated): Remove. (setuid-program-service-type)[extend]: Remove 'setuid-program-file-like-deprecated' call. Assume CONFIG and EXTENSIONS are already lists of <setuid-program> records. * gnu/system.scm (<operating-system>)[setuid-programs]: Add 'sanitize' property. Change accessor name from '%operating-system-setuid-programs' to 'operating-system-setuid-programs'. (operating-system-default-essential-services) (hurd-default-essential-services): Adjust accordingly. (ensure-setuid-program-list): New macro. (%ensure-setuid-program-list): New procedure, based on 'setuid-program-file-like-deprecated'.
This commit is contained in:
		
							parent
							
								
									5291fd7a42
								
							
						
					
					
						commit
						e0bd47b4fd
					
				
					 2 changed files with 28 additions and 21 deletions
				
			
		| 
						 | 
					@ -1,5 +1,5 @@
 | 
				
			||||||
;;; GNU Guix --- Functional package management for GNU
 | 
					;;; GNU Guix --- Functional package management for GNU
 | 
				
			||||||
;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
 | 
					;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 | 
				
			||||||
;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 | 
					;;; Copyright © 2016 Chris Marusich <cmmarusich@gmail.com>
 | 
				
			||||||
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 | 
					;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 | 
				
			||||||
;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
 | 
					;;; Copyright © 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
 | 
				
			||||||
| 
						 | 
					@ -828,16 +828,6 @@ FILES must be a list of name/file-like object pairs."
 | 
				
			||||||
 | 
					
 | 
				
			||||||
          (activate-setuid-programs (list #$@programs))))))
 | 
					          (activate-setuid-programs (list #$@programs))))))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (setuid-program-file-like-deprecated file-like)
 | 
					 | 
				
			||||||
  (match file-like
 | 
					 | 
				
			||||||
    ((? file-like? program)
 | 
					 | 
				
			||||||
     (warning
 | 
					 | 
				
			||||||
      (G_ "representing setuid programs with '~a' is \
 | 
					 | 
				
			||||||
deprecated; use 'setuid-program' instead~%") program)
 | 
					 | 
				
			||||||
     (setuid-program (program program)))
 | 
					 | 
				
			||||||
    ((? setuid-program? program)
 | 
					 | 
				
			||||||
     program)))
 | 
					 | 
				
			||||||
 | 
					 | 
				
			||||||
(define setuid-program-service-type
 | 
					(define setuid-program-service-type
 | 
				
			||||||
  (service-type (name 'setuid-program)
 | 
					  (service-type (name 'setuid-program)
 | 
				
			||||||
                (extensions
 | 
					                (extensions
 | 
				
			||||||
| 
						 | 
					@ -845,8 +835,7 @@ deprecated; use 'setuid-program' instead~%") program)
 | 
				
			||||||
                                          setuid-program->activation-gexp)))
 | 
					                                          setuid-program->activation-gexp)))
 | 
				
			||||||
                (compose concatenate)
 | 
					                (compose concatenate)
 | 
				
			||||||
                (extend (lambda (config extensions)
 | 
					                (extend (lambda (config extensions)
 | 
				
			||||||
                          (map setuid-program-file-like-deprecated
 | 
					                          (append config extensions)))
 | 
				
			||||||
                               (append config extensions))))
 | 
					 | 
				
			||||||
                (description
 | 
					                (description
 | 
				
			||||||
                 "Populate @file{/run/setuid-programs} with the specified
 | 
					                 "Populate @file{/run/setuid-programs} with the specified
 | 
				
			||||||
executables, making them setuid-root.")))
 | 
					executables, making them setuid-root.")))
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -268,8 +268,9 @@
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (pam-services operating-system-pam-services     ; list of PAM services
 | 
					  (pam-services operating-system-pam-services     ; list of PAM services
 | 
				
			||||||
                (default (base-pam-services)))
 | 
					                (default (base-pam-services)))
 | 
				
			||||||
  (setuid-programs %operating-system-setuid-programs
 | 
					  (setuid-programs operating-system-setuid-programs
 | 
				
			||||||
                   (default %setuid-programs))    ; list of string-valued gexps
 | 
					                   (default %setuid-programs)     ; list of <setuid-program>
 | 
				
			||||||
 | 
					                   (sanitize ensure-setuid-program-list))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
  (sudoers-file operating-system-sudoers-file     ; file-like
 | 
					  (sudoers-file operating-system-sudoers-file     ; file-like
 | 
				
			||||||
                (default %sudoers-specification))
 | 
					                (default %sudoers-specification))
 | 
				
			||||||
| 
						 | 
					@ -672,7 +673,7 @@ bookkeeping."
 | 
				
			||||||
            (operating-system-environment-variables os))
 | 
					            (operating-system-environment-variables os))
 | 
				
			||||||
           host-name procs root-fs
 | 
					           host-name procs root-fs
 | 
				
			||||||
           (service setuid-program-service-type
 | 
					           (service setuid-program-service-type
 | 
				
			||||||
                    (%operating-system-setuid-programs os))
 | 
					                    (operating-system-setuid-programs os))
 | 
				
			||||||
           (service profile-service-type
 | 
					           (service profile-service-type
 | 
				
			||||||
                    (operating-system-packages os))
 | 
					                    (operating-system-packages os))
 | 
				
			||||||
           other-fs
 | 
					           other-fs
 | 
				
			||||||
| 
						 | 
					@ -702,7 +703,7 @@ bookkeeping."
 | 
				
			||||||
          (pam-root-service (operating-system-pam-services os))
 | 
					          (pam-root-service (operating-system-pam-services os))
 | 
				
			||||||
          (operating-system-etc-service os)
 | 
					          (operating-system-etc-service os)
 | 
				
			||||||
          (service setuid-program-service-type
 | 
					          (service setuid-program-service-type
 | 
				
			||||||
                   (%operating-system-setuid-programs os))
 | 
					                   (operating-system-setuid-programs os))
 | 
				
			||||||
          (service profile-service-type (operating-system-packages os)))))
 | 
					          (service profile-service-type (operating-system-packages os)))))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define* (operating-system-services os)
 | 
					(define* (operating-system-services os)
 | 
				
			||||||
| 
						 | 
					@ -1066,10 +1067,27 @@ use 'plain-file' instead~%")
 | 
				
			||||||
    ;; TODO: Remove when glibc@2.23 is long gone.
 | 
					    ;; TODO: Remove when glibc@2.23 is long gone.
 | 
				
			||||||
    ("GUIX_LOCPATH" . "/run/current-system/locale")))
 | 
					    ("GUIX_LOCPATH" . "/run/current-system/locale")))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (operating-system-setuid-programs os)
 | 
					(define-syntax-rule (ensure-setuid-program-list lst)
 | 
				
			||||||
  "Return the setuid programs for OS, as a list of setuid-program record."
 | 
					  "Ensure LST is a list of <setuid-program> records and warn otherwise."
 | 
				
			||||||
  (map file-like->setuid-program
 | 
					  (%ensure-setuid-program-list lst (current-source-location)))
 | 
				
			||||||
         (%operating-system-setuid-programs os)))
 | 
					
 | 
				
			||||||
 | 
					(define (%ensure-setuid-program-list lst location)
 | 
				
			||||||
 | 
					  (define warned? #f)
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  (define (warn-once)
 | 
				
			||||||
 | 
					    (unless warned?
 | 
				
			||||||
 | 
					      (warning (source-properties->location location)
 | 
				
			||||||
 | 
					               (G_ "representing setuid programs with file-like objects is \
 | 
				
			||||||
 | 
					deprecated; use 'setuid-program' instead~%"))
 | 
				
			||||||
 | 
					      (set! warned? #t)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  (map (match-lambda
 | 
				
			||||||
 | 
					         ((? file-like? program)
 | 
				
			||||||
 | 
					          (warn-once)
 | 
				
			||||||
 | 
					          (setuid-program (program program)))
 | 
				
			||||||
 | 
					         ((? setuid-program? program)
 | 
				
			||||||
 | 
					          program))
 | 
				
			||||||
 | 
					       lst))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define %setuid-programs
 | 
					(define %setuid-programs
 | 
				
			||||||
  ;; Default set of setuid-root programs.
 | 
					  ;; Default set of setuid-root programs.
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue