From: Mathieu Othacehe <othacehe@gnu.org>
To: 45101@debbugs.gnu.org
Cc: Mathieu Othacehe <othacehe@gnu.org>
Subject: [bug#45101] [PATCH] scripts: discover: Remove file locks.
Date: Mon, 7 Dec 2020 14:17:06 +0100 [thread overview]
Message-ID: <20201207131706.96073-1-othacehe@gnu.org> (raw)
* 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))))))
'()))
\f
@@ -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
next reply other threads:[~2020-12-07 13:30 UTC|newest]
Thread overview: 3+ messages / expand[flat|nested] mbox.gz Atom feed top
2020-12-07 13:17 Mathieu Othacehe [this message]
2020-12-12 19:52 ` [bug#45101] [PATCH] scripts: discover: Remove file locks Ludovic Courtès
2020-12-13 12:25 ` bug#45101: " Mathieu Othacehe
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20201207131706.96073-1-othacehe@gnu.org \
--to=othacehe@gnu.org \
--cc=45101@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).