syscalls: Add 'with-file-lock' macro.
* guix/scripts/offload.scm (lock-file, unlock-file, with-file-lock): Move to... * guix/build/syscalls.scm: ... here.
This commit is contained in:
parent
c11ac62de9
commit
b7178c22bf
@ -34,6 +34,8 @@
|
|||||||
|
|
||||||
(eval . (put 'modify-services 'scheme-indent-function 1))
|
(eval . (put 'modify-services 'scheme-indent-function 1))
|
||||||
(eval . (put 'with-directory-excursion 'scheme-indent-function 1))
|
(eval . (put 'with-directory-excursion 'scheme-indent-function 1))
|
||||||
|
(eval . (put 'with-file-lock 'scheme-indent-function 1))
|
||||||
|
|
||||||
(eval . (put 'package 'scheme-indent-function 0))
|
(eval . (put 'package 'scheme-indent-function 0))
|
||||||
(eval . (put 'origin 'scheme-indent-function 0))
|
(eval . (put 'origin 'scheme-indent-function 0))
|
||||||
(eval . (put 'build-system 'scheme-indent-function 0))
|
(eval . (put 'build-system 'scheme-indent-function 0))
|
||||||
|
@ -81,7 +81,11 @@
|
|||||||
fdatasync
|
fdatasync
|
||||||
pivot-root
|
pivot-root
|
||||||
scandir*
|
scandir*
|
||||||
|
|
||||||
fcntl-flock
|
fcntl-flock
|
||||||
|
lock-file
|
||||||
|
unlock-file
|
||||||
|
with-file-lock
|
||||||
|
|
||||||
set-thread-name
|
set-thread-name
|
||||||
thread-name
|
thread-name
|
||||||
@ -1067,6 +1071,29 @@ exception if it's already taken."
|
|||||||
;; Presumably we got EAGAIN or so.
|
;; Presumably we got EAGAIN or so.
|
||||||
(throw 'flock-error err))))))
|
(throw 'flock-error err))))))
|
||||||
|
|
||||||
|
(define (lock-file file)
|
||||||
|
"Wait and acquire an exclusive lock on FILE. Return an open port."
|
||||||
|
(let ((port (open-file file "w0")))
|
||||||
|
(fcntl-flock port 'write-lock)
|
||||||
|
port))
|
||||||
|
|
||||||
|
(define (unlock-file port)
|
||||||
|
"Unlock PORT, a port returned by 'lock-file'."
|
||||||
|
(fcntl-flock port 'unlock)
|
||||||
|
(close-port port)
|
||||||
|
#t)
|
||||||
|
|
||||||
|
(define-syntax-rule (with-file-lock file exp ...)
|
||||||
|
"Wait to acquire a lock on FILE and evaluate EXP in that context."
|
||||||
|
(let ((port (lock-file file)))
|
||||||
|
(dynamic-wind
|
||||||
|
(lambda ()
|
||||||
|
#t)
|
||||||
|
(lambda ()
|
||||||
|
exp ...)
|
||||||
|
(lambda ()
|
||||||
|
(unlock-file port)))))
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
;;; Miscellaneous, aka. 'prctl'.
|
;;; Miscellaneous, aka. 'prctl'.
|
||||||
|
@ -236,30 +236,6 @@ instead of '~a' of type '~a'~%")
|
|||||||
;;; Synchronization.
|
;;; Synchronization.
|
||||||
;;;
|
;;;
|
||||||
|
|
||||||
(define (lock-file file)
|
|
||||||
"Wait and acquire an exclusive lock on FILE. Return an open port."
|
|
||||||
(mkdir-p (dirname file))
|
|
||||||
(let ((port (open-file file "w0")))
|
|
||||||
(fcntl-flock port 'write-lock)
|
|
||||||
port))
|
|
||||||
|
|
||||||
(define (unlock-file lock)
|
|
||||||
"Unlock LOCK."
|
|
||||||
(fcntl-flock lock 'unlock)
|
|
||||||
(close-port lock)
|
|
||||||
#t)
|
|
||||||
|
|
||||||
(define-syntax-rule (with-file-lock file exp ...)
|
|
||||||
"Wait to acquire a lock on FILE and evaluate EXP in that context."
|
|
||||||
(let ((port (lock-file file)))
|
|
||||||
(dynamic-wind
|
|
||||||
(lambda ()
|
|
||||||
#t)
|
|
||||||
(lambda ()
|
|
||||||
exp ...)
|
|
||||||
(lambda ()
|
|
||||||
(unlock-file port)))))
|
|
||||||
|
|
||||||
(define (machine-slot-file machine slot)
|
(define (machine-slot-file machine slot)
|
||||||
"Return the file name of MACHINE's file for SLOT."
|
"Return the file name of MACHINE's file for SLOT."
|
||||||
;; For each machine we have a bunch of files representing each build slot.
|
;; For each machine we have a bunch of files representing each build slot.
|
||||||
@ -829,7 +805,6 @@ This tool is meant to be used internally by 'guix-daemon'.\n"))
|
|||||||
(leave (G_ "invalid arguments: ~{~s ~}~%") x))))
|
(leave (G_ "invalid arguments: ~{~s ~}~%") x))))
|
||||||
|
|
||||||
;;; Local Variables:
|
;;; Local Variables:
|
||||||
;;; eval: (put 'with-file-lock 'scheme-indent-function 1)
|
|
||||||
;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
|
;;; eval: (put 'with-error-to-port 'scheme-indent-function 1)
|
||||||
;;; eval: (put 'with-timeout 'scheme-indent-function 2)
|
;;; eval: (put 'with-timeout 'scheme-indent-function 2)
|
||||||
;;; End:
|
;;; End:
|
||||||
|
Loading…
Reference in New Issue
Block a user