guix package: Make custom profiles actual indirect roots.
Before that, any profile generation built when '-p' is used would effectively become a permanent GC root because the symlink in /var/guix/gcroots/auto would point directly to /gnu/store/...-profile. * guix/scripts/package.scm (maybe-register-gc-root): Rename to... (register-gc-root): ... this. Remove conditional, and replace call to 'canonicalize-path' with (string-append (getcwd) "/" ...). (guix-package): Call 'register-gc-root' only if PROFILE is different from %CURRENT-PROFILE. * tests/guix-package.sh: Add test case.
This commit is contained in:
		
							parent
							
								
									3df5acf332
								
							
						
					
					
						commit
						c9323a4c69
					
				
					 2 changed files with 29 additions and 6 deletions
				
			
		| 
						 | 
					@ -661,10 +661,20 @@ removed from MANIFEST."
 | 
				
			||||||
               (_ #f))
 | 
					               (_ #f))
 | 
				
			||||||
              options))
 | 
					              options))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (maybe-register-gc-root store profile)
 | 
					(define (register-gc-root store profile)
 | 
				
			||||||
  "Register PROFILE as a GC root, unless it doesn't need it."
 | 
					  "Register PROFILE, a profile generation symlink, as a GC root, unless it
 | 
				
			||||||
  (unless (string=? profile %current-profile)
 | 
					doesn't need it."
 | 
				
			||||||
    (add-indirect-root store (canonicalize-path profile))))
 | 
					  (define absolute
 | 
				
			||||||
 | 
					    ;; We must pass the daemon an absolute file name for PROFILE.  However, we
 | 
				
			||||||
 | 
					    ;; cannot use (canonicalize-path profile) because that would return us the
 | 
				
			||||||
 | 
					    ;; target of PROFILE in the store; using a store item as an indirect root
 | 
				
			||||||
 | 
					    ;; would mean that said store item will always remain live, which is not
 | 
				
			||||||
 | 
					    ;; what we want here.
 | 
				
			||||||
 | 
					    (if (string-prefix? "/" profile)
 | 
				
			||||||
 | 
					        profile
 | 
				
			||||||
 | 
					        (string-append (getcwd) "/" profile)))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					  (add-indirect-root store absolute))
 | 
				
			||||||
 | 
					
 | 
				
			||||||
(define (readlink* file)
 | 
					(define (readlink* file)
 | 
				
			||||||
  "Call 'readlink' until the result is not a symlink."
 | 
					  "Call 'readlink' until the result is not a symlink."
 | 
				
			||||||
| 
						 | 
					@ -857,7 +867,8 @@ more information.~%"))
 | 
				
			||||||
                                 (count   (length entries)))
 | 
					                                 (count   (length entries)))
 | 
				
			||||||
                            (switch-symlinks name prof)
 | 
					                            (switch-symlinks name prof)
 | 
				
			||||||
                            (switch-symlinks profile name)
 | 
					                            (switch-symlinks profile name)
 | 
				
			||||||
                            (maybe-register-gc-root (%store) profile)
 | 
					                            (unless (string=? profile %current-profile)
 | 
				
			||||||
 | 
					                              (register-gc-root (%store) name))
 | 
				
			||||||
                            (format #t (N_ "~a package in profile~%"
 | 
					                            (format #t (N_ "~a package in profile~%"
 | 
				
			||||||
                                           "~a packages in profile~%"
 | 
					                                           "~a packages in profile~%"
 | 
				
			||||||
                                           count)
 | 
					                                           count)
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
| 
						 | 
					@ -32,7 +32,7 @@ module_dir="t-guix-package-$$"
 | 
				
			||||||
profile="t-profile-$$"
 | 
					profile="t-profile-$$"
 | 
				
			||||||
rm -f "$profile"
 | 
					rm -f "$profile"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
trap 'rm "$profile" "$profile-"[0-9]* ; rm -rf "$module_dir" t-home-'"$$" EXIT
 | 
					trap 'rm -f "$profile" "$profile-"[0-9]* ; rm -rf "$module_dir" t-home-'"$$" EXIT
 | 
				
			||||||
 | 
					
 | 
				
			||||||
# Use `-e' with a non-package expression.
 | 
					# Use `-e' with a non-package expression.
 | 
				
			||||||
if guix package --bootstrap -e +;
 | 
					if guix package --bootstrap -e +;
 | 
				
			||||||
| 
						 | 
					@ -203,6 +203,18 @@ if guix package -p "$profile" --delete-generations=12m;
 | 
				
			||||||
then false; else true; fi
 | 
					then false; else true; fi
 | 
				
			||||||
test "`readlink_base "$profile"`" = "$generation"
 | 
					test "`readlink_base "$profile"`" = "$generation"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					# Make sure $profile is a GC root at this point.
 | 
				
			||||||
 | 
					real_profile="`readlink -f "$profile"`"
 | 
				
			||||||
 | 
					if guix gc -d "$real_profile"
 | 
				
			||||||
 | 
					then false; else true; fi
 | 
				
			||||||
 | 
					test -d "$real_profile"
 | 
				
			||||||
 | 
					
 | 
				
			||||||
 | 
					# Now, let's remove all the symlinks to $real_profile, and make sure
 | 
				
			||||||
 | 
					# $real_profile is no longer a GC root.
 | 
				
			||||||
 | 
					rm "$profile" "$profile"-[0-9]-link
 | 
				
			||||||
 | 
					guix gc -d "$real_profile"
 | 
				
			||||||
 | 
					[ ! -d "$real_profile" ]
 | 
				
			||||||
 | 
					
 | 
				
			||||||
#
 | 
					#
 | 
				
			||||||
# Try with the default profile.
 | 
					# Try with the default profile.
 | 
				
			||||||
#
 | 
					#
 | 
				
			||||||
| 
						 | 
					
 | 
				
			||||||
		Reference in a new issue