>From 5d86226f318a111cc1bdf5a6f044c6f540f51b45 Mon Sep 17 00:00:00 2001
From: Julien Lepiller <address@hidden>
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.
---
 guix/build/syscalls.scm  | 33 ++++++++++++++++++--
 guix/scripts/package.scm | 65 +++++++++++++++++++++++-----------------
 2 files changed, 69 insertions(+), 29 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index bbf2531c79..d843194cce 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,38 @@ exception if it's already taken."
         (when port
           (unlock-file port))))))
 
+(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))
+                      #f
+                      (apply throw 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'.
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 1a58d43e5c..4776d61077 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,45 @@ 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 guix 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?)))))
 
 
 ;;;
-- 
2.22.0