GNU bug report logs - #45101
[PATCH] scripts: discover: Remove file locks.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 45101 in the body.
You can then email your comments to 45101 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Mathieu Othacehe <othacehe <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Mathieu Othacehe <othacehe <at> gnu.org>
Subject: [PATCH] scripts: discover: Remove file locks.
Date: Mon,  7 Dec 2020 14:17:06 +0100

* guix/scripts/discover.scm (call-once, call-with-output-file/atomic): New
procedures copied from (system base compile).
(call-with-read-file-lock, with-read-file-lock): Remove them.
(write-publish-file): Use "call-with-output-file/atomic" instead of
"with-file-lock".
(read-substitute-urls): Remve file lock.
---
 guix/scripts/discover.scm | 86 +++++++++++++++++++++------------------
 1 file changed, 46 insertions(+), 40 deletions(-)

diff --git a/guix/scripts/discover.scm b/guix/scripts/discover.scm
index 007db0d49d..86834a7afb 100644
--- a/guix/scripts/discover.scm
+++ b/guix/scripts/discover.scm
@@ -75,50 +75,60 @@ CACHE-DIRECTORY."
 (define %publish-file
   (make-parameter (publish-file %state-directory)))
 
+;; XXX: Copied from (system base compile).
+(define (call-once thunk)
+  (let ((entered #f))
+    (dynamic-wind
+        (lambda ()
+          (when entered
+            (error "thunk may only be entered once: ~a" thunk))
+          (set! entered #t))
+        thunk
+        (lambda () #t))))
+
+(define* (call-with-output-file/atomic filename proc #:optional reference)
+  (let* ((template (string-append filename ".XXXXXX"))
+         (tmp (mkstemp! template "wb")))
+    (call-once
+     (lambda ()
+       (with-throw-handler #t
+         (lambda ()
+           (proc tmp)
+           ;; Chmodding by name instead of by port allows this chmod to
+           ;; work on systems without fchmod, like MinGW.
+           (let ((perms (or (false-if-exception (stat:perms (stat reference)))
+                            (lognot (umask)))))
+             (chmod template (logand #o0666 perms)))
+           (close-port tmp)
+           (rename-file template filename))
+         (lambda args
+           (close-port tmp)
+           (delete-file template)))))))
+
 (define* (write-publish-file #:key (file (%publish-file)))
   "Dump the content of %PUBLISH-SERVICES hash table into FILE.  Use a write
 lock on FILE to synchronize with any potential readers."
-  (with-file-lock file
-    (call-with-output-file file
-      (lambda (port)
-        (hash-for-each
-         (lambda (name service)
-           (format port "http://~a:~a~%"
-                   (avahi-service-address service)
-                   (avahi-service-port service)))
-         %publish-services)))
-        (chmod file #o644)))
-
-(define (call-with-read-file-lock file thunk)
-  "Call THUNK with a read lock on FILE."
-  (let ((port #f))
-    (dynamic-wind
-      (lambda ()
-        (set! port
-              (let ((port (open-file file "r0")))
-                (fcntl-flock port 'read-lock)
-                port)))
-      thunk
-      (lambda ()
-        (when port
-          (unlock-file port))))))
-
-(define-syntax-rule (with-read-file-lock file exp ...)
-  "Wait to acquire a read lock on FILE and evaluate EXP in that context."
-  (call-with-read-file-lock file (lambda () exp ...)))
+  (call-with-output-file/atomic file
+    (lambda (port)
+      (hash-for-each
+       (lambda (name service)
+         (format port "http://~a:~a~%"
+                 (avahi-service-address service)
+                 (avahi-service-port service)))
+       %publish-services)))
+  (chmod file #o644))
 
 (define* (read-substitute-urls #:key (file (%publish-file)))
   "Read substitute urls list from FILE and return it.  Use a read lock on FILE
 to synchronize with the writer."
   (if (file-exists? file)
-      (with-read-file-lock file
-        (call-with-input-file file
-          (lambda (port)
-            (let loop ((url (read-line port))
-                       (urls '()))
-              (if (eof-object? url)
-                  urls
-                  (loop (read-line port) (cons url urls)))))))
+      (call-with-input-file file
+        (lambda (port)
+          (let loop ((url (read-line port))
+                     (urls '()))
+            (if (eof-object? url)
+                urls
+                (loop (read-line port) (cons url urls))))))
       '()))
 
 
@@ -158,7 +168,3 @@ to synchronize with the writer."
         (mkdir-p (dirname publish-file))
         (avahi-browse-service-thread service-proc
                                      #:types %services)))))
-
-;;; Local Variables:
-;;; eval: (put 'with-read-file-lock 'scheme-indent-function 1)
-;;; End:
-- 
2.29.2

Message #8 received at 45101 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Mathieu Othacehe <othacehe <at> gnu.org>
Cc: 45101 <at> debbugs.gnu.org
Subject: Re: [bug#45101] [PATCH] scripts: discover: Remove file locks.
Date: Sat, 12 Dec 2020 20:52:01 +0100

Hi!

Mathieu Othacehe <othacehe <at> gnu.org> skribis:

> * guix/scripts/discover.scm (call-once, call-with-output-file/atomic): New
> procedures copied from (system base compile).
> (call-with-read-file-lock, with-read-file-lock): Remove them.
> (write-publish-file): Use "call-with-output-file/atomic" instead of
> "with-file-lock".
> (read-substitute-urls): Remve file lock.

I think you could use ‘with-atomic-file-output’ from (guix utils).
(Apologies if I gave you the wrong name before!)

Apart from that LGTM, thanks!  :-)

Ludo’.

Message #13 received at 45101-done <at> debbugs.gnu.org (full text, mbox):

From: Mathieu Othacehe <othacehe <at> gnu.org>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: 45101-done <at> debbugs.gnu.org
Subject: Re: [bug#45101] [PATCH] scripts: discover: Remove file locks.
Date: Sun, 13 Dec 2020 13:25:36 +0100

Hey,

> I think you could use ‘with-atomic-file-output’ from (guix utils).
> (Apologies if I gave you the wrong name before!)
>
> Apart from that LGTM, thanks!  :-)

Fixed and pushed!

Thanks,

Mathieu

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.