Subject: bug#36375: [PATCH] Re: ‘guix package’ should lock the profile

From: Julien Lepiller <[email-masked]>
Date: Thu, 7 Nov 2019 22:19:36 +0100

Le Wed, 06 Nov 2019 14:24:54 +0100,
Ludovic Courtès <[email-masked]> a écrit :

> Hello!
> 
> Julien Lepiller <[email-masked]> skribis:
> 
> >>From 5d86226f318a111cc1bdf5a6f044c6f540f51b45 Mon Sep 17 00:00:00
> >>2001  
> > From: Julien Lepiller <[email-masked]>
> > Date: Fri, 25 Oct 2019 21:39:21 +0200
> > Subject: [PATCH] guix: package: lock profiles when processing them.
> >
> > * guix/scripts/package.scm (process-actions): Get a per-profile
> > lock to prevent concurrent actions on profiles.
> > * guix/build/syscalls.scm (with-file-lock/no-wait): New procedure.
> > (lock-file): Take a #:wait? key.  
> 
> Nice!  Could you make the syscalls.scm changes a separate patch?
> 
> > +(define (call-with-file-lock/no-wait file thunk handler)
> > +  (let ((port (catch 'system-error
> > +                (lambda ()
> > +		  (catch 'flock-error
> > +                    (lambda ()
> > +		      (lock-file file #:wait? #f))
> > +		    handler))
> > +                (lambda args
> > +                  ;; When using the statically-linked Guile in the
> > initrd,
> > +                  ;; 'fcntl-flock' returns ENOSYS
> > unconditionally.  Ignore
> > +                  ;; that error since we're typically the only
> > process running
> > +                  ;; at this point.
> > +                  (if (or (= ENOSYS (system-error-errno args)) (=
> > 'flock-error args))  
> 
> Please remove tabs.  :-)
> 
> This is wrong because (1) ‘args’ is always a list, and (2) ‘=’ is
> defined for numbers, not for symbols and lists.
> 
> I think you actually want to catch two exceptions here: ‘system-error’
> and ‘flock-error’.  For that, you have to do:
> 
>   (catch #t
>     (lambda ()
>       (lock-file …))
>     (lambda (key . args)
>       (match key
>         ('flock-error …)
>         ('system-error
>          (if (= ENOSYS (system-error-errno (cons key args)))
>              …))
>         (_
>          (apply throw key args)))))
>         
> Does that make sense?
> 
> > +  ;; First, acquire a lock on the profile, to ensure only one guix
> > process
> > +  ;; is modifying it at a time.
> > +  (with-file-lock/no-wait
> > +    (string-append profile ".lock")  
> 
> Nitpick: I’d move the lock file name on the same line as
> ‘with-file-lock/no-wait’.
> 
> > +    (lambda (key . args)
> > +      (leave (G_ "profile ~a is locked by another guix process.~%")
> > +                 profile))  
> 
> s/guix// and remove the trailing period.
> 
> Could you add a test for that in tests/guix-package.sh?
> 
> One way to do it may be to do something like:
> 
>   echo '(sleep 60) > /…/manifest.scm
>   guix package -m /…/manifest.scm -p whatever &
>   pid=$!
>   if guix install emacs -p whatever; then false; else true; fi
>   kill $pid
> 
> Could you send updated patches?
> 
> Thanks!
> 
> Ludo’.

Attached are updated patches! I also made sure the new test passes.
>From 71a85b5a8aac6c0bd5a1a4e3b52e409b2112df7a Mon Sep 17 00:00:00 2001
From: Julien Lepiller <[email-masked]>
Date: Thu, 7 Nov 2019 21:50:54 +0100
Subject: [PATCH 1/2] guix: Add file-locking with no wait.

* guix/build/syscalls.scm (with-file-lock/no-wait): New procedure.
(lock-file): Take a #:wait? key.
---
 guix/build/syscalls.scm | 35 +++++++++++++++++++++++++++++++++--
 1 file changed, 33 insertions(+), 2 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index bbf2531c79..a5a9c92a42 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -80,6 +80,7 @@
             lock-file
             unlock-file
             with-file-lock
+            with-file-lock/no-wait
 
             set-thread-name
             thread-name
@@ -1087,10 +1088,10 @@ exception if it's already taken."
           ;; Presumably we got EAGAIN or so.
           (throw 'flock-error err))))))
 
-(define (lock-file file)
+(define* (lock-file file #:key (wait? #t))
   "Wait and acquire an exclusive lock on FILE.  Return an open port."
   (let ((port (open-file file "w0")))
-    (fcntl-flock port 'write-lock)
+    (fcntl-flock port 'write-lock #:wait? wait?)
     port))
 
 (define (unlock-file port)
@@ -1119,10 +1120,40 @@ exception if it's already taken."
         (when port
           (unlock-file port))))))
 
+(define (call-with-file-lock/no-wait file thunk handler)
+  (let ((port (catch #t
+                (lambda ()
+                  (lock-file file #:wait? #f))
+                (lambda (key . args)
+                  (match key
+                    ('flock-error
+                     (handler args))
+                    ('system-error
+                      ;; When using the statically-linked Guile in the initrd,
+                      ;; 'fcntl-flock' returns ENOSYS unconditionally.  Ignore
+                      ;; that error since we're typically the only process running
+                      ;; at this point.
+                      (if (= ENOSYS (system-error-errno (cons key args)))
+                          #f
+                          (apply throw args)))
+                    (_ (apply throw key args)))))))
+    (dynamic-wind
+      (lambda ()
+        #t)
+      thunk
+      (lambda ()
+        (when port
+          (unlock-file port))))))
+
 (define-syntax-rule (with-file-lock file exp ...)
   "Wait to acquire a lock on FILE and evaluate EXP in that context."
   (call-with-file-lock file (lambda () exp ...)))
 
+(define-syntax-rule (with-file-lock/no-wait file handler exp ...)
+  "Try to acquire a lock on FILE and evaluate EXP in that context.  Execute
+handler if the lock is already held by another process."
+  (call-with-file-lock/no-wait file (lambda () exp ...) handler))
+
 
 ;;;
 ;;; Miscellaneous, aka. 'prctl'.
-- 
2.22.0

>From 50c792e155d1207127f10ff0c0360442b7736a64 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <[email-masked]>
Date: Fri, 25 Oct 2019 21:39:21 +0200
Subject: [PATCH 2/2] guix: package: lock profiles when processing them.

* guix/scripts/package.scm (process-actions): Get a per-profile lock to
prevent concurrent actions on profiles.
* tests/guix-package.sh: Add test.
---
 guix/scripts/package.scm | 64 +++++++++++++++++++++++-----------------
 tests/guix-package.sh    | 10 ++++++-
 2 files changed, 46 insertions(+), 28 deletions(-)

diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1a58d43e5c..bcd03a1df9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -42,6 +42,8 @@
   #:autoload   (guix store roots) (gc-roots)
   #:use-module ((guix build utils)
                 #:select (directory-exists? mkdir-p))
+  #:use-module ((guix build syscalls)
+                #:select (with-file-lock/no-wait))
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
@@ -876,36 +878,44 @@ processed, #f otherwise."
                      (package-version item)
                      (manifest-entry-version entry))))))
 
-  ;; First, process roll-backs, generation removals, etc.
-  (for-each (match-lambda
-              ((key . arg)
-               (and=> (assoc-ref %actions key)
-                      (lambda (proc)
-                        (proc store profile arg opts
-                              #:dry-run? dry-run?)))))
-            opts)
 
-  ;; Then, process normal package removal/installation/upgrade.
-  (let* ((manifest (profile-manifest profile))
-         (step1    (options->removable opts manifest
-                                       (manifest-transaction)))
-         (step2    (options->installable opts manifest step1))
-         (step3    (manifest-transaction
-                    (inherit step2)
-                    (install (map transform-entry
-                                  (manifest-transaction-install step2)))))
-         (new      (manifest-perform-transaction manifest step3)))
+  ;; First, acquire a lock on the profile, to ensure only one guix process
+  ;; is modifying it at a time.
+  (with-file-lock/no-wait (string-append profile ".lock")
+    (lambda (key . args)
+      (leave (G_ "profile ~a is locked by another process~%")
+                 profile))
 
-    (warn-about-old-distro)
+    ;; Then, process roll-backs, generation removals, etc.
+    (for-each (match-lambda
+                ((key . arg)
+                 (and=> (assoc-ref %actions key)
+                        (lambda (proc)
+                          (proc store profile arg opts
+                                #:dry-run? dry-run?)))))
+              opts)
 
-    (unless (manifest-transaction-null? step3)
-      (show-manifest-transaction store manifest step3
-                                 #:dry-run? dry-run?)
-      (build-and-use-profile store profile new
-                             #:allow-collisions? allow-collisions?
-                             #:bootstrap? bootstrap?
-                             #:use-substitutes? substitutes?
-                             #:dry-run? dry-run?))))
+    ;; Then, process normal package removal/installation/upgrade.
+    (let* ((manifest (profile-manifest profile))
+           (step1    (options->removable opts manifest
+                                         (manifest-transaction)))
+           (step2    (options->installable opts manifest step1))
+           (step3    (manifest-transaction
+                      (inherit step2)
+                      (install (map transform-entry
+                                    (manifest-transaction-install step2)))))
+           (new      (manifest-perform-transaction manifest step3)))
+
+      (warn-about-old-distro)
+
+      (unless (manifest-transaction-null? step3)
+        (show-manifest-transaction store manifest step3
+                                   #:dry-run? dry-run?)
+        (build-and-use-profile store profile new
+                               #:allow-collisions? allow-collisions?
+                               #:bootstrap? bootstrap?
+                               #:use-substitutes? substitutes?
+                               #:dry-run? dry-run?)))))
 
 
 ;;;
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index 0de30bf6c1..7ad0699380 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -33,7 +33,7 @@ profile="t-profile-$$"
 tmpfile="t-guix-package-file-$$"
 rm -f "$profile" "$tmpfile"
 
-trap 'rm -f "$profile" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home-'"$$" EXIT
+trap 'rm -f "$profile" "$profile.lock" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home-'"$$" EXIT
 
 # Use `-e' with a non-package expression.
 if guix package --bootstrap -e +;
@@ -452,3 +452,11 @@ rm -rf "$module_dir"
 # Make sure we can see user profiles.
 guix package --list-profiles | grep "$profile"
 guix package --list-profiles | grep '\.guix-profile'
+
+# Make sure we can properly lock a profile.
+mkdir "$module_dir"
+echo '(sleep 60)' > "$module_dir/manifest.scm"
+guix package -m "$module_dir/manifest.scm" -p "$module_dir/profile" &
+pid=$!
+if guix install emacs -p "$module_dir/profile"; then kill $pid; false; else true; fi
+kill $pid
-- 
2.22.0