ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

utils: Move 'fcntl-flock' to (guix build syscalls).

Browse source 
* guix/utils.scm (%struct-flock, F_SETLKW, F_SETLK, F_xxLCK)
(fcntl-flock): Move to...
* guix/build/syscalls.scm: ... here.  New variables.
* guix/nar.scm: Adjust imports accordingly.
* tests/utils.scm ("fcntl-flock wait", "fcntl-flock non-blocking"): Move
to...
* tests/syscalls.scm: ... here.  New tests.
(temp-file): New variable.
This commit is contained in:
Ludovic Courtès 2016-05-06 13:12:45 +02:00
parent ba2613bb4e
commit 4e0ea3eb28
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 160 additions and 158 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

69
guix/build/syscalls.scm
View file

@ -65,6 +65,7 @@ (define-module (guix build syscalls)
processes
mkdtemp!
pivot-root
fcntl-flock
CLONE_CHILD_CLEARTID
CLONE_CHILD_SETTID
@ -637,6 +638,74 @@ (define pivot-root
(list new-root put-old (strerror err))
(list err)))))))
;;;
;;; Advisory file locking.
;;;
(define %struct-flock
;; 'struct flock' from <fcntl.h>.
(list short ; l_type
short ; l_whence
size_t ; l_start
size_t ; l_len
int)) ; l_pid
(define F_SETLKW
;; On Linux-based systems, this is usually 7, but not always
;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
(cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
((string-contains %host-type "linux") 7) ; *-linux-gnu
(else 9))) ; *-gnu*
(define F_SETLK
;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
(cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
((string-contains %host-type "linux") 6) ; *-linux-gnu
(else 8))) ; *-gnu*
(define F_xxLCK
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
(cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
(else #(1 2 3)))) ; *-gnu*
(define fcntl-flock
(let ((proc (syscall->procedure int "fcntl" `(,int ,int *))))
(lambda* (fd-or-port operation #:key (wait? #t))
"Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION
must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is
true, block until the lock is acquired; otherwise, thrown an 'flock-error'
exception if it's already taken."
(define (operation->int op)
(case op
((read-lock) (vector-ref F_xxLCK 0))
((write-lock) (vector-ref F_xxLCK 1))
((unlock) (vector-ref F_xxLCK 2))
(else (error "invalid fcntl-flock operation" op))))
(define fd
(if (port? fd-or-port)
(fileno fd-or-port)
fd-or-port))
;; XXX: 'fcntl' is a vararg function, but here we happily use the
;; standard ABI; crossing fingers.
(let ((err (proc fd
(if wait?
F_SETLKW ; lock & wait
F_SETLK) ; non-blocking attempt
(make-c-struct %struct-flock
(list (operation->int operation)
SEEK_SET
0 0 ; whole file
0)))))
(or (zero? err)
;; Presumably we got EAGAIN or so.
(throw 'flock-error (errno)))))))
;;;
;;; Network interfaces.

4
guix/nar.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@ -18,8 +18,8 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix nar)
#:use-module (guix utils)
#:use-module (guix serialization)
#:use-module (guix build syscalls)
#:use-module ((guix build utils)
#:select (delete-file-recursively with-directory-excursion))
#:use-module (guix store)

75
guix/utils.scm
View file

@ -34,7 +34,7 @@ (define-module (guix utils)
#:use-module ((rnrs bytevectors) #:select (bytevector-u8-set!))
#:use-module (guix combinators)
#:use-module ((guix build utils) #:select (dump-port))
#:use-module ((guix build syscalls) #:select (errno mkdtemp!))
#:use-module ((guix build syscalls) #:select (mkdtemp!))
#:use-module (ice-9 vlist)
#:use-module (ice-9 format)
#:autoload (ice-9 popen) (open-pipe*)
@ -47,7 +47,6 @@ (define-module (guix utils)
#:export (bytevector->base16-string
base16-string->bytevector
fcntl-flock
strip-keyword-arguments
default-keyword-arguments
substitute-keyword-arguments
@ -338,78 +337,6 @@ (define* (edit-expression source-properties proc #:key (encoding "UTF-8"))
(put-bytevector out post-bv))
#t))))))
;;;
;;; Advisory file locking.
;;;
(define %struct-flock
;; 'struct flock' from <fcntl.h>.
(list short ; l_type
short ; l_whence
size_t ; l_start
size_t ; l_len
int)) ; l_pid
(define F_SETLKW
;; On Linux-based systems, this is usually 7, but not always
;; (exceptions include SPARC.) On GNU/Hurd, it's 9.
(compile-time-value
(cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
((string-contains %host-type "linux") 7) ; *-linux-gnu
(else 9)))) ; *-gnu*
(define F_SETLK
;; Likewise: GNU/Hurd and SPARC use 8, while the others typically use 6.
(compile-time-value
(cond ((string-contains %host-type "sparc") 8) ; sparc-*-linux-gnu
((string-contains %host-type "linux") 6) ; *-linux-gnu
(else 8)))) ; *-gnu*
(define F_xxLCK
;; The F_RDLCK, F_WRLCK, and F_UNLCK constants.
(compile-time-value
(cond ((string-contains %host-type "sparc") #(1 2 3)) ; sparc-*-linux-gnu
((string-contains %host-type "hppa") #(1 2 3)) ; hppa-*-linux-gnu
((string-contains %host-type "linux") #(0 1 2)) ; *-linux-gnu
(else #(1 2 3))))) ; *-gnu*
(define fcntl-flock
(let* ((ptr (dynamic-func "fcntl" (dynamic-link)))
(proc (pointer->procedure int ptr `(,int ,int *))))
(lambda* (fd-or-port operation #:key (wait? #t))
"Perform locking OPERATION on the file beneath FD-OR-PORT. OPERATION
must be a symbol, one of 'read-lock, 'write-lock, or 'unlock. When WAIT? is
true, block until the lock is acquired; otherwise, thrown an 'flock-error'
exception if it's already taken."
(define (operation->int op)
(case op
((read-lock) (vector-ref F_xxLCK 0))
((write-lock) (vector-ref F_xxLCK 1))
((unlock) (vector-ref F_xxLCK 2))
(else (error "invalid fcntl-flock operation" op))))
(define fd
(if (port? fd-or-port)
(fileno fd-or-port)
fd-or-port))
;; XXX: 'fcntl' is a vararg function, but here we happily use the
;; standard ABI; crossing fingers.
(let ((err (proc fd
(if wait?
F_SETLKW ; lock & wait
F_SETLK) ; non-blocking attempt
(make-c-struct %struct-flock
(list (operation->int operation)
SEEK_SET
0 0 ; whole file
0)))))
(or (zero? err)
;; Presumably we got EAGAIN or so.
(throw 'flock-error (errno)))))))
;;;
;;; Keyword arguments.

88
tests/syscalls.scm
View file

@ -29,6 +29,10 @@ (define-module (test-syscalls)
;; Test the (guix build syscalls) module, although there's not much that can
;; actually be tested without being root.
(define temp-file
(string-append "t-utils-" (number->string (getpid))))
(test-begin "syscalls")
(test-equal "mount, ENOENT"
@ -172,6 +176,88 @@ (define perform-container-tests?
(status:exit-val status))))
(eq? #t result))))))))
(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
42 ; the child's exit status
(let ((file (open-file temp-file "w0b")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-lock)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
;; Reopen FILE read-only so we can have a read lock.
(let ((file (open-file temp-file "r0b")))
;; Wait until we can acquire the lock.
(fcntl-flock file 'read-lock)
(primitive-exit (read file)))
(primitive-exit 1))
(lambda ()
(primitive-exit 2))))
(pid
;; Write garbage and wait.
(display "hello, world!" file)
(force-output file)
(sleep 1)
;; Write the real answer.
(seek file 0 SEEK_SET)
(truncate-file file 0)
(write 42 file)
(force-output file)
;; Unlock, which should let the child continue.
(fcntl-flock file 'unlock)
(match (waitpid pid)
((_ . status)
(let ((result (status:exit-val status)))
(close-port file)
result)))))))
(test-equal "fcntl-flock non-blocking"
EAGAIN ; the child's exit status
(match (pipe)
((input . output)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(close-port output)
;; Wait for the green light.
(read-char input)
;; Open FILE read-only so we can have a read lock.
(let ((file (open-file temp-file "w0")))
(catch 'flock-error
(lambda ()
;; This attempt should throw EAGAIN.
(fcntl-flock file 'write-lock #:wait? #f))
(lambda (key errno)
(primitive-exit (pk 'errno errno)))))
(primitive-exit -1))
(lambda ()
(primitive-exit -2))))
(pid
(close-port input)
(let ((file (open-file temp-file "w0")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-lock)
;; Tell the child to continue.
(write 'green-light output)
(force-output output)
(match (waitpid pid)
((_ . status)
(let ((result (status:exit-val status)))
(fcntl-flock file 'unlock)
(close-port file)
result)))))))))
(test-assert "all-network-interface-names"
(match (all-network-interface-names)
(((? string? names) ..1)
@ -303,3 +389,5 @@ (define perform-container-tests?
0))
(test-end)
(false-if-exception (delete-file temp-file))

82
tests/utils.scm
View file

@ -168,88 +168,6 @@ (define temp-file
(call-with-decompressed-port 'xz (open-file temp-file "r0b")
get-bytevector-all))))
(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
42 ; the child's exit status
(let ((file (open-file temp-file "w0b")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-lock)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
;; Reopen FILE read-only so we can have a read lock.
(let ((file (open-file temp-file "r0b")))
;; Wait until we can acquire the lock.
(fcntl-flock file 'read-lock)
(primitive-exit (read file)))
(primitive-exit 1))
(lambda ()
(primitive-exit 2))))
(pid
;; Write garbage and wait.
(display "hello, world!" file)
(force-output file)
(sleep 1)
;; Write the real answer.
(seek file 0 SEEK_SET)
(truncate-file file 0)
(write 42 file)
(force-output file)
;; Unlock, which should let the child continue.
(fcntl-flock file 'unlock)
(match (waitpid pid)
((_ . status)
(let ((result (status:exit-val status)))
(close-port file)
result)))))))
(test-equal "fcntl-flock non-blocking"
EAGAIN ; the child's exit status
(match (pipe)
((input . output)
(match (primitive-fork)
(0
(dynamic-wind
(const #t)
(lambda ()
(close-port output)
;; Wait for the green light.
(read-char input)
;; Open FILE read-only so we can have a read lock.
(let ((file (open-file temp-file "w0")))
(catch 'flock-error
(lambda ()
;; This attempt should throw EAGAIN.
(fcntl-flock file 'write-lock #:wait? #f))
(lambda (key errno)
(primitive-exit (pk 'errno errno)))))
(primitive-exit -1))
(lambda ()
(primitive-exit -2))))
(pid
(close-port input)
(let ((file (open-file temp-file "w0")))
;; Acquire an exclusive lock.
(fcntl-flock file 'write-lock)
;; Tell the child to continue.
(write 'green-light output)
(force-output output)
(match (waitpid pid)
((_ . status)
(let ((result (status:exit-val status)))
(fcntl-flock file 'unlock)
(close-port file)
result)))))))))
;; This is actually in (guix store).
(test-equal "store-path-package-name"
"bash-4.2-p24"