From e19eb93b8564a5c76ae71878e815ccfa75d62325 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Apr 2016 23:30:56 +0200 Subject: syscalls: statfs: Add missing 'mount-flags' field of 'struct statfs'. * guix/build/syscalls.scm ()[mount-flags]: New field. [spare2]: Remove. (%statfs): Likewise. --- guix/build/syscalls.scm | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 6cdf65304d..a85f865180 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -59,6 +59,7 @@ file-system-identifier file-system-maximum-name-length file-system-fragment-size + file-system-mount-flags statfs processes @@ -475,8 +476,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (define-record-type (file-system type block-size blocks blocks-free blocks-available files free-files identifier - name-length fragment-size - spare0 spare1 spare2) + name-length fragment-size mount-flags spare0 spare1) file-system? (type file-system-type) (block-size file-system-block-size) @@ -488,14 +488,14 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (identifier file-system-identifier) (name-length file-system-maximum-name-length) (fragment-size file-system-fragment-size) + (mount-flags file-system-mount-flags) (spare0 file-system--spare0) - (spare1 file-system--spare1) - (spare2 file-system--spare2)) + (spare1 file-system--spare1)) (define-syntax fsword ;fsword_t (identifier-syntax long)) -(define-c-struct %statfs +(define-c-struct %statfs ; sizeof-statfs ;slightly overestimated file-system read-statfs @@ -510,9 +510,9 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (identifier uint64) ;really "int[2]" (name-length fsword) (fragment-size fsword) + (mount-flags fsword) (spare0 int128) ;really "fsword[4]" - (spare1 int128) - (spare2 int64)) ;XXX: to match array alignment + (spare1 int128)) (define statfs (let ((proc (syscall->procedure int "statfs" '(* *)))) -- cgit v1.2.3 From 07857052db082224648064265fbaaaa5bf8fa609 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 30 Apr 2016 23:32:25 +0200 Subject: syscalls: 'statfs' explicitly binds 'statfs64'. * guix/build/syscalls.scm (statfs): Explicitly bind "statfs64". --- guix/build/syscalls.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a85f865180..ed7942c10a 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -515,7 +515,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (spare1 int128)) (define statfs - (let ((proc (syscall->procedure int "statfs" '(* *)))) + (let ((proc (syscall->procedure int "statfs64" '(* *)))) (lambda (file) "Return a data structure describing the file system mounted at FILE." @@ -523,7 +523,7 @@ mounted at FILE." (ret (proc (string->pointer file) (bytevector->pointer stat))) (err (errno))) (if (zero? ret) - (read-statfs stat 0) + (read-statfs stat) (throw 'system-error "statfs" "~A: ~A" (list file (strerror err)) (list err))))))) -- cgit v1.2.3 From ba369abe588d8420631f3540a51db98f6cc30d93 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 May 2016 21:38:53 +0200 Subject: syscalls: Implement arrays in 'define-c-struct' and use it. * guix/build/syscalls.scm (sizeof*, alignof*, write-type, read-type): Add support for (array ...) forms. * guix/build/syscalls.scm ()[spare0, spare1]: Remove. [spare]: New field. * guix/build/syscalls.scm (%statfs)[identifier]: Change to (array int 2). [spare0, spare1]: Remove. [spare]: New field. --- guix/build/syscalls.scm | 37 +++++++++++++++++++++++++++---------- 1 file changed, 27 insertions(+), 10 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index ed7942c10a..721c590f69 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -123,9 +123,11 @@ (define-syntax sizeof* ;; XXX: This duplicates 'compile-time-value'. - (syntax-rules (int128) + (syntax-rules (int128 array) ((_ int128) 16) + ((_ (array type n)) + (* (sizeof* type) n)) ((_ type) (let-syntax ((v (lambda (s) (let ((val (sizeof type))) @@ -135,9 +137,11 @@ (define-syntax alignof* ;; XXX: This duplicates 'compile-time-value'. - (syntax-rules (int128) + (syntax-rules (int128 array) ((_ int128) 16) + ((_ (array type n)) + (alignof* type)) ((_ type) (let-syntax ((v (lambda (s) (let ((val (alignof type))) @@ -182,10 +186,19 @@ result is the alignment of the \"most strictly aligned component\"." types ...)))) (define-syntax write-type - (syntax-rules (~) + (syntax-rules (~ array) ((_ bv offset (type ~ order) value) (bytevector-uint-set! bv offset value (endianness order) (sizeof* type))) + ((_ bv offset (array type n) value) + (let loop ((i 0) + (value value) + (o offset)) + (unless (= i n) + (match value + ((head . tail) + (write-type bv o type head) + (loop (+ 1 i) tail (+ o (sizeof* type)))))))) ((_ bv offset type value) (bytevector-uint-set! bv offset value (native-endianness) (sizeof* type))))) @@ -202,7 +215,7 @@ result is the alignment of the \"most strictly aligned component\"." (types ...) (fields ...)))))) (define-syntax read-type - (syntax-rules (~ quote *) + (syntax-rules (~ array quote *) ((_ bv offset '*) (make-pointer (bytevector-uint-ref bv offset (native-endianness) @@ -210,6 +223,12 @@ result is the alignment of the \"most strictly aligned component\"." ((_ bv offset (type ~ order)) (bytevector-uint-ref bv offset (endianness order) (sizeof* type))) + ((_ bv offset (array type n)) + (unfold (lambda (i) (= i n)) + (lambda (i) + (read-type bv (+ offset (* i (sizeof* type))) type)) + 1+ + 0)) ((_ bv offset type) (bytevector-uint-ref bv offset (native-endianness) (sizeof* type))))) @@ -476,7 +495,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (define-record-type (file-system type block-size blocks blocks-free blocks-available files free-files identifier - name-length fragment-size mount-flags spare0 spare1) + name-length fragment-size mount-flags spare) file-system? (type file-system-type) (block-size file-system-block-size) @@ -489,8 +508,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (name-length file-system-maximum-name-length) (fragment-size file-system-fragment-size) (mount-flags file-system-mount-flags) - (spare0 file-system--spare0) - (spare1 file-system--spare1)) + (spare file-system--spare)) (define-syntax fsword ;fsword_t (identifier-syntax long)) @@ -507,12 +525,11 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'." (blocks-available uint64) (files uint64) (free-files uint64) - (identifier uint64) ;really "int[2]" + (identifier (array int 2)) (name-length fsword) (fragment-size fsword) (mount-flags fsword) - (spare0 int128) ;really "fsword[4]" - (spare1 int128)) + (spare (array fsword 4))) (define statfs (let ((proc (syscall->procedure int "statfs64" '(* *)))) -- cgit v1.2.3 From 29d457c209bbc1a5371025b3247e2db36027c56d Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 1 May 2016 23:59:05 +0200 Subject: syscalls: Add 'tcgetattr' and 'tcsetattr' bindings. * guix/build/syscalls.scm (bits->symbols-body, define-bits) (local-flags): New macros. (TCSANOW, TCSADRAIN, TCSAFLUSH): New variables. (): New record type. (%termios): New C structure. (tcgetattr, tcsetattr): New procedures. * tests/syscalls.scm ("tcgetattr ENOTTY", "tcgetattr") ("tcsetattr"): New tests. --- guix/build/syscalls.scm | 131 ++++++++++++++++++++++++++++++++++++++++++++++++ tests/syscalls.scm | 25 +++++++++ 2 files changed, 156 insertions(+) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 721c590f69..4e543d70d8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -100,6 +100,22 @@ interface-broadcast-address network-interfaces + termios? + termios-input-flags + termios-output-flags + termios-control-flags + termios-local-flags + termios-line-discipline + termios-control-chars + termios-input-speed + termios-output-speed + local-flags + TCSANOW + TCSADRAIN + TCSAFLUSH + tcgetattr + tcsetattr + window-size? window-size-rows window-size-columns @@ -996,6 +1012,121 @@ network interface. This is implemented using the 'getifaddrs' libc function." ;;; Terminals. ;;; +(define-syntax bits->symbols-body + (syntax-rules () + ((_ bits () ()) + '()) + ((_ bits (name names ...) (value values ...)) + (let ((result (bits->symbols-body bits (names ...) (values ...)))) + (if (zero? (logand bits value)) + result + (cons 'name result)))))) + +(define-syntax define-bits + (syntax-rules (define) + "Define the given numerical constants under CONSTRUCTOR, such that + (CONSTRUCTOR NAME) returns VALUE. Define BITS->SYMBOLS as a procedure that, +given an integer, returns the list of names of the constants that are or'd." + ((_ constructor bits->symbols (define names values) ...) + (begin + (define-syntax constructor + (syntax-rules (names ...) + ((_ names) values) ... + ((_ several (... ...)) + (logior (constructor several) (... ...))))) + (define (bits->symbols bits) + (bits->symbols-body bits (names ...) (values ...))) + (define names values) ...)))) + +;; 'local-flags' bits from +(define-bits local-flags + local-flags->symbols + (define ISIG #o0000001) + (define ICANON #o0000002) + (define XCASE #o0000004) + (define ECHO #o0000010) + (define ECHOE #o0000020) + (define ECHOK #o0000040) + (define ECHONL #o0000100) + (define NOFLSH #o0000200) + (define TOSTOP #o0000400) + (define ECHOCTL #o0001000) + (define ECHOPRT #o0002000) + (define ECHOKE #o0004000) + (define FLUSHO #o0010000) + (define PENDIN #o0040000) + (define IEXTEN #o0100000) + (define EXTPROC #o0200000)) + +;; "Actions" values for 'tcsetattr'. +(define TCSANOW 0) +(define TCSADRAIN 1) +(define TCSAFLUSH 2) + +(define-record-type + (termios input-flags output-flags control-flags local-flags + line-discipline control-chars + input-speed output-speed) + termios? + (input-flags termios-input-flags) + (output-flags termios-output-flags) + (control-flags termios-control-flags) + (local-flags termios-local-flags) + (line-discipline termios-line-discipline) + (control-chars termios-control-chars) + (input-speed termios-input-speed) + (output-speed termios-output-speed)) + +(define-c-struct %termios ; + sizeof-termios + termios + read-termios + write-termios! + (input-flags unsigned-int) + (output-flags unsigned-int) + (control-flags unsigned-int) + (local-flags unsigned-int) + (line-discipline uint8) + (control-chars (array uint8 32)) + (input-speed unsigned-int) + (output-speed unsigned-int)) + +(define tcgetattr + (let ((proc (syscall->procedure int "tcgetattr" (list int '*)))) + (lambda (fd) + "Return the structure for the tty at FD." + (let* ((bv (make-bytevector sizeof-termios)) + (ret (proc fd (bytevector->pointer bv))) + (err (errno))) + (if (zero? ret) + (read-termios bv) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + +(define tcsetattr + (let ((proc (syscall->procedure int "tcsetattr" (list int int '*)))) + (lambda (fd actions termios) + "Use TERMIOS for the tty at FD. ACTIONS is one of 'TCSANOW', +'TCSADRAIN', or 'TCSAFLUSH'; see tcsetattr(3) for details." + (define bv + (make-bytevector sizeof-termios)) + + (let-syntax ((match/write (syntax-rules () + ((_ fields ...) + (match termios + (($ fields ...) + (write-termios! bv 0 fields ...))))))) + (match/write input-flags output-flags control-flags local-flags + line-discipline control-chars input-speed output-speed)) + + (let ((ret (proc fd actions (bytevector->pointer bv))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "tcgetattr" "~A" + (list (strerror err)) + (list err))))))) + (define-syntax TIOCGWINSZ ; (identifier-syntax #x5413)) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 71bcbc4d32..ab1e13984d 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -259,6 +259,31 @@ (#f #f) (lo (interface-address lo))))))) +(test-equal "tcgetattr ENOTTY" + ENOTTY + (catch 'system-error + (lambda () + (call-with-input-file "/dev/null" + (lambda (port) + (tcgetattr (fileno port))))) + (compose system-error-errno list))) + +(test-skip (if (and (file-exists? "/proc/self/fd/0") + (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0"))) + 0 + 2)) + +(test-assert "tcgetattr" + (let ((termios (tcgetattr 0))) + (and (termios? termios) + (> (termios-input-speed termios) 0) + (> (termios-output-speed termios) 0)))) + +(test-assert "tcsetattr" + (let ((first (tcgetattr 0))) + (tcsetattr 0 TCSANOW first) + (equal? first (tcgetattr 0)))) + (test-assert "terminal-window-size ENOTTY" (call-with-input-file "/dev/null" (lambda (port) -- cgit v1.2.3 From 842cb82097288265270db3228f8231676107a8b5 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Thu, 4 Feb 2016 15:33:07 +0800 Subject: profiles: Add xdg-desktop-database hook. * guix/profiles.scm (xdg-desktop-database): New function. (%default-profile-hooks): Add it. --- guix/profiles.scm | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index a3277cef71..c298bacdfc 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -686,13 +686,49 @@ creates the GTK+ 'icon-theme.cache' file for each theme." #:substitutable? #f) (return #f)))) +(define (xdg-desktop-database manifest) + "Return a derivation that builds the @file{mimeinfo.cache} database from +desktop files. It's used to query what applications can handle a given +MIME type." + (define desktop-file-utils + (module-ref (resolve-interface '(gnu packages gnome)) + 'desktop-file-utils)) + + (define build + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((destdir (string-append #$output "/share/applications")) + (appdirs (filter file-exists? + (map (cut string-append <> + "/share/applications") + '#$(manifest-inputs manifest)))) + (update-desktop-database (string-append + #+desktop-file-utils + "/bin/update-desktop-database"))) + (mkdir-p (string-append #$output "/share")) + (union-build destdir appdirs + #:log-port (%make-void-port "w")) + (zero? (system* update-desktop-database destdir))))) + + ;; Don't run the hook when 'desktop-file-utils' is not installed. + (if (manifest-lookup manifest (manifest-pattern (name "desktop-file-utils"))) + (gexp->derivation "xdg-desktop-database" build + #:modules '((guix build utils) + (guix build union)) + #:local-build? #t + #:substitutable? #f) + (with-monad %store-monad (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. (list info-dir-file ghc-package-cache-file ca-certificate-bundle - gtk-icon-themes)) + gtk-icon-themes + xdg-desktop-database)) (define* (profile-derivation manifest #:key -- cgit v1.2.3 From 6c06b1fdac1a00385e393e1ad4735212b3ab63ad Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Thu, 4 Feb 2016 15:35:03 +0800 Subject: profiles: Add xdg-mime-database hook. * guix/profiles.scm (xdg-mime-database): New function. (%default-profile-hooks): Add it. --- guix/profiles.scm | 39 ++++++++++++++++++++++++++++++++++++++- 1 file changed, 38 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index c298bacdfc..93d03ce959 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -721,6 +721,42 @@ MIME type." #:substitutable? #f) (with-monad %store-monad (return #f)))) +(define (xdg-mime-database manifest) + "Return a derivation that builds the @file{mime.cache} database from manifest +entries. It's used to query the MIME type of a given file." + (define shared-mime-info + (module-ref (resolve-interface '(gnu packages gnome)) + 'shared-mime-info)) + + (define build + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((datadir (string-append #$output "/share")) + (destdir (string-append datadir "/mime")) + (mimedirs (filter file-exists? + (map (cut string-append <> + "/share/mime") + '#$(manifest-inputs manifest)))) + (update-mime-database (string-append + #+shared-mime-info + "/bin/update-mime-database"))) + (mkdir-p datadir) + (union-build destdir mimedirs + #:log-port (%make-void-port "w")) + (setenv "XDG_DATA_HOME" datadir) + (zero? (system* update-mime-database destdir))))) + + ;; Don't run the hook when 'shared-mime-info' is not installed. + (if (manifest-lookup manifest (manifest-pattern (name "shared-mime-info"))) + (gexp->derivation "xdg-mime-database" build + #:modules '((guix build utils) + (guix build union)) + #:local-build? #t + #:substitutable? #f) + (with-monad %store-monad (return #f)))) + (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by ;; default when making a non-empty profile. @@ -728,7 +764,8 @@ MIME type." ghc-package-cache-file ca-certificate-bundle gtk-icon-themes - xdg-desktop-database)) + xdg-desktop-database + xdg-mime-database)) (define* (profile-derivation manifest #:key -- cgit v1.2.3 From d72d783301df0f519ac1e303c70c8e82e32388e0 Mon Sep 17 00:00:00 2001 From: 宋文武 Date: Sat, 30 Apr 2016 14:52:30 +0800 Subject: profiles: Factor out 'manifest-lookup-package'. * guix/profiles.scm (manifest-lookup-package): New procedure. (gtk-icon-themes, xdg-desktop-database, xdg-mime-database): Use it. --- guix/profiles.scm | 190 +++++++++++++++++++++++++++--------------------------- 1 file changed, 94 insertions(+), 96 deletions(-) (limited to 'guix') diff --git a/guix/profiles.scm b/guix/profiles.scm index 93d03ce959..8355af7a48 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -445,6 +445,40 @@ replace it." (cons (gexp-input thing output) deps))) (manifest-entries manifest))) +(define (manifest-lookup-package manifest name) + "Return as a monadic value the first package or store path referenced by +MANIFEST that named NAME, or #f if not found." + ;; Return as a monadic value the package or store path referenced by the + ;; manifest ENTRY, or #f if not referenced. + (define (entry-lookup-package entry) + (define (find-among-inputs inputs) + (find (lambda (input) + (and (package? input) + (equal? name (package-name input)))) + inputs)) + (define (find-among-store-items items) + (find (lambda (item) + (equal? name (package-name->name+version + (store-path-package-name item)))) + items)) + + ;; TODO: Factorize. + (define references* + (store-lift references)) + + (with-monad %store-monad + (match (manifest-entry-item entry) + ((? package? package) + (match (package-transitive-inputs package) + (((labels inputs . _) ...) + (return (find-among-inputs inputs))))) + ((? string? item) + (mlet %store-monad ((refs (references* item))) + (return (find-among-store-items refs))))))) + + (anym %store-monad + entry-lookup-package (manifest-entries manifest))) + (define (info-dir-file manifest) "Return a derivation that builds the 'dir' file for all the entries of MANIFEST." @@ -608,41 +642,7 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx." (define (gtk-icon-themes manifest) "Return a derivation that unions all icon themes from manifest entries and creates the GTK+ 'icon-theme.cache' file for each theme." - ;; Return as a monadic value the GTK+ package or store path referenced by the - ;; manifest ENTRY, or #f if not referenced. - (define (entry-lookup-gtk+ entry) - (define (find-among-inputs inputs) - (find (lambda (input) - (and (package? input) - (string=? "gtk+" (package-name input)))) - inputs)) - - (define (find-among-store-items items) - (find (lambda (item) - (equal? "gtk+" - (package-name->name+version - (store-path-package-name item)))) - items)) - - ;; TODO: Factorize. - (define references* - (store-lift references)) - - (with-monad %store-monad - (match (manifest-entry-item entry) - ((? package? package) - (match (package-transitive-inputs package) - (((labels inputs . _) ...) - (return (find-among-inputs inputs))))) - ((? string? item) - (mlet %store-monad ((refs (references* item))) - (return (find-among-store-items refs))))))) - - (define (manifest-lookup-gtk+ manifest) - (anym %store-monad - entry-lookup-gtk+ (manifest-entries manifest))) - - (mlet %store-monad ((gtk+ (manifest-lookup-gtk+ manifest))) + (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+"))) (define build #~(begin (use-modules (guix build utils) @@ -690,72 +690,70 @@ creates the GTK+ 'icon-theme.cache' file for each theme." "Return a derivation that builds the @file{mimeinfo.cache} database from desktop files. It's used to query what applications can handle a given MIME type." - (define desktop-file-utils - (module-ref (resolve-interface '(gnu packages gnome)) - 'desktop-file-utils)) + (mlet %store-monad ((desktop-file-utils + (manifest-lookup-package + manifest "desktop-file-utils"))) + (define build + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((destdir (string-append #$output "/share/applications")) + (appdirs (filter file-exists? + (map (cut string-append <> + "/share/applications") + '#$(manifest-inputs manifest)))) + (update-desktop-database (string-append + #+desktop-file-utils + "/bin/update-desktop-database"))) + (mkdir-p (string-append #$output "/share")) + (union-build destdir appdirs + #:log-port (%make-void-port "w")) + (zero? (system* update-desktop-database destdir))))) - (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((destdir (string-append #$output "/share/applications")) - (appdirs (filter file-exists? - (map (cut string-append <> - "/share/applications") - '#$(manifest-inputs manifest)))) - (update-desktop-database (string-append - #+desktop-file-utils - "/bin/update-desktop-database"))) - (mkdir-p (string-append #$output "/share")) - (union-build destdir appdirs - #:log-port (%make-void-port "w")) - (zero? (system* update-desktop-database destdir))))) - - ;; Don't run the hook when 'desktop-file-utils' is not installed. - (if (manifest-lookup manifest (manifest-pattern (name "desktop-file-utils"))) - (gexp->derivation "xdg-desktop-database" build - #:modules '((guix build utils) - (guix build union)) - #:local-build? #t - #:substitutable? #f) - (with-monad %store-monad (return #f)))) + ;; Don't run the hook when 'desktop-file-utils' is not referenced. + (if desktop-file-utils + (gexp->derivation "xdg-desktop-database" build + #:modules '((guix build utils) + (guix build union)) + #:local-build? #t + #:substitutable? #f) + (return #f)))) (define (xdg-mime-database manifest) "Return a derivation that builds the @file{mime.cache} database from manifest entries. It's used to query the MIME type of a given file." - (define shared-mime-info - (module-ref (resolve-interface '(gnu packages gnome)) - 'shared-mime-info)) - - (define build - #~(begin - (use-modules (srfi srfi-26) - (guix build utils) - (guix build union)) - (let* ((datadir (string-append #$output "/share")) - (destdir (string-append datadir "/mime")) - (mimedirs (filter file-exists? - (map (cut string-append <> - "/share/mime") - '#$(manifest-inputs manifest)))) - (update-mime-database (string-append - #+shared-mime-info - "/bin/update-mime-database"))) - (mkdir-p datadir) - (union-build destdir mimedirs - #:log-port (%make-void-port "w")) - (setenv "XDG_DATA_HOME" datadir) - (zero? (system* update-mime-database destdir))))) - - ;; Don't run the hook when 'shared-mime-info' is not installed. - (if (manifest-lookup manifest (manifest-pattern (name "shared-mime-info"))) - (gexp->derivation "xdg-mime-database" build - #:modules '((guix build utils) - (guix build union)) - #:local-build? #t - #:substitutable? #f) - (with-monad %store-monad (return #f)))) + (mlet %store-monad ((shared-mime-info + (manifest-lookup-package + manifest "shared-mime-info"))) + (define build + #~(begin + (use-modules (srfi srfi-26) + (guix build utils) + (guix build union)) + (let* ((datadir (string-append #$output "/share")) + (destdir (string-append datadir "/mime")) + (mimedirs (filter file-exists? + (map (cut string-append <> + "/share/mime") + '#$(manifest-inputs manifest)))) + (update-mime-database (string-append + #+shared-mime-info + "/bin/update-mime-database"))) + (mkdir-p datadir) + (union-build destdir mimedirs + #:log-port (%make-void-port "w")) + (setenv "XDG_DATA_HOME" datadir) + (zero? (system* update-mime-database destdir))))) + + ;; Don't run the hook when 'shared-mime-info' is referenced. + (if shared-mime-info + (gexp->derivation "xdg-mime-database" build + #:modules '((guix build utils) + (guix build union)) + #:local-build? #t + #:substitutable? #f) + (return #f)))) (define %default-profile-hooks ;; This is the list of derivation-returning procedures that are called by -- cgit v1.2.3 From a8f3424b25cbbc585126420bcc1434c4a2398588 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 2 May 2016 08:59:57 +0200 Subject: syscalls: Wrap TCSA* constants in 'tcsetattr-action' macro. * guix/build/syscalls.scm (tcsetattr-action): New macro. (TCSANOW, TCSADRAIN, TCSAFLUSH): Remove. (tcsetattr): Adjust docstring accordingly. * tests/syscalls.scm ("tcsetattr"): Adjust accordingly. --- guix/build/syscalls.scm | 16 ++++++++-------- tests/syscalls.scm | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 4e543d70d8..a9cd6e93c8 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -110,9 +110,7 @@ termios-input-speed termios-output-speed local-flags - TCSANOW - TCSADRAIN - TCSAFLUSH + tcsetattr-action tcgetattr tcsetattr @@ -1059,9 +1057,11 @@ given an integer, returns the list of names of the constants that are or'd." (define EXTPROC #o0200000)) ;; "Actions" values for 'tcsetattr'. -(define TCSANOW 0) -(define TCSADRAIN 1) -(define TCSAFLUSH 2) +(define-bits tcsetattr-action + %unused-tcsetattr-action->symbols + (define TCSANOW 0) + (define TCSADRAIN 1) + (define TCSAFLUSH 2)) (define-record-type (termios input-flags output-flags control-flags local-flags @@ -1107,8 +1107,8 @@ given an integer, returns the list of names of the constants that are or'd." (define tcsetattr (let ((proc (syscall->procedure int "tcsetattr" (list int int '*)))) (lambda (fd actions termios) - "Use TERMIOS for the tty at FD. ACTIONS is one of 'TCSANOW', -'TCSADRAIN', or 'TCSAFLUSH'; see tcsetattr(3) for details." + "Use TERMIOS for the tty at FD. ACTIONS is one of of the values +produced by 'tcsetattr-action'; see tcsetattr(3) for details." (define bv (make-bytevector sizeof-termios)) diff --git a/tests/syscalls.scm b/tests/syscalls.scm index ab1e13984d..0b73fb4b0c 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -281,7 +281,7 @@ (test-assert "tcsetattr" (let ((first (tcgetattr 0))) - (tcsetattr 0 TCSANOW first) + (tcsetattr 0 (tcsetattr-action TCSANOW) first) (equal? first (tcgetattr 0)))) (test-assert "terminal-window-size ENOTTY" -- cgit v1.2.3 From 8bf92e3904cb656d4c2160fc8befebaf21a65492 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 May 2016 16:38:22 +0200 Subject: services: herd: Move UI handling to 'guix system'. This makes (gnu services herd) independent of (guix ui). * gnu/services/herd.scm (&shepherd-error, &service-not-found-error) (&action-not-found-error, &action-exception-error) (&unknown-shepherd-error): New error condition types. (report-action-error): Remove. (raise-shepherd-error): New procedure. (display-message): Do not use 'info' and '_'. (invoke-action): Use 'raise-shepherd-error' instead of 'report-action-error'. Do not use 'warning'. (current-services): Do not use 'warning'. * guix/scripts/system.scm (with-shepherd-error-handling): New macro. (report-shepherd-error, call-with-service-upgrade-info): New procedures. (upgrade-shepherd-services): Use it. --- gnu/services/herd.scm | 80 ++++++++++++++++++++------- guix/scripts/system.scm | 142 ++++++++++++++++++++++++++++++++---------------- 2 files changed, 153 insertions(+), 69 deletions(-) (limited to 'guix') diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index 9cb33a9fd0..c06e98800e 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -17,12 +17,27 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services herd) - #:use-module (guix ui) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (ice-9 match) - #:export (current-services + #:export (shepherd-error? + service-not-found-error? + service-not-found-error-service + action-not-found-error? + action-not-found-error-service + action-not-found-error-action + action-exception-error? + action-exception-error-service + action-exception-error-action + action-exception-error-key + action-exception-error-arguments + unknown-shepherd-error? + unknown-shepherd-error-sexp + + current-services unload-services unload-service load-services @@ -61,31 +76,54 @@ return the socket." (let ((connection (open-connection))) body ...)) -(define (report-action-error error) - "Report ERROR, an sexp received by a shepherd client in reply to COMMAND, a -command object." +(define-condition-type &shepherd-error &error + shepherd-error?) + +(define-condition-type &service-not-found-error &shepherd-error + service-not-found-error? + (service service-not-found-error-service)) + +(define-condition-type &action-not-found-error &shepherd-error + action-not-found-error? + (service action-not-found-error-service) + (action action-not-found-error-action)) + +(define-condition-type &action-exception-error &shepherd-error + action-exception-error? + (service action-exception-error-service) + (action action-exception-error-action) + (key action-exception-error-key) + (args action-exception-error-arguments)) + +(define-condition-type &unknown-shepherd-error &shepherd-error + unknown-shepherd-error? + (sexp unknown-shepherd-error-sexp)) + +(define (raise-shepherd-error error) + "Raise an error condition corresponding to ERROR, an sexp received by a +shepherd client in reply to COMMAND, a command object. Return #t if ERROR +does not denote an error." (match error (('error ('version 0 x ...) 'service-not-found service) - (report-error (_ "service '~a' could not be found~%") - service)) + (raise (condition (&service-not-found-error + (service service))))) (('error ('version 0 x ...) 'action-not-found action service) - (report-error (_ "service '~a' does not have an action '~a'~%") - service action)) + (raise (condition (&action-not-found-error + (service service) + (action action))))) (('error ('version 0 x ...) 'action-exception action service key (args ...)) - (report-error (_ "exception caught while executing '~a' \ -on service '~a':~%") - action service) - (print-exception (current-error-port) #f key args)) + (raise (condition (&action-exception-error + (service service) + (action action) + (key key) (args args))))) (('error . _) - (report-error (_ "something went wrong: ~s~%") - error)) + (raise (condition (&unknown-shepherd-error (sexp error))))) (#f ;not an error #t))) (define (display-message message) - ;; TRANSLATORS: Nothing to translate here. - (info (_ "shepherd: ~a~%") message)) + (format (current-error-port) "shepherd: ~a~%" message)) (define* (invoke-action service action arguments cont) "Invoke ACTION on SERVICE with ARGUMENTS. On success, call CONT with the @@ -107,10 +145,10 @@ result. Otherwise return #f." (('reply ('version 0 x ...) ('result y) ('error error) ('messages messages)) (for-each display-message messages) - (report-action-error error) + (raise-shepherd-error error) #f) (x - (warning (_ "invalid shepherd reply~%")) + ;; invalid reply #f)))) (define-syntax-rule (with-shepherd-action service (action args ...) @@ -129,7 +167,8 @@ of pairs." (define (current-services) "Return two lists: the list of currently running services, and the list of -currently stopped services." +currently stopped services. Return #f and #f if the list of services could +not be obtained." (with-shepherd-action 'root ('status) services (match services ((('service ('version 0 _ ...) _ ...) ...) @@ -144,7 +183,6 @@ currently stopped services." '() services)) (x - (warning (_ "failed to obtain list of shepherd services~%")) (values #f #f))))) (define (unload-service service) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index e5d754a6fa..dd1e534c9b 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -236,6 +236,72 @@ BODY..., and restore them." (with-monad %store-monad (return #f))))) +(define-syntax-rule (with-shepherd-error-handling body ...) + (warn-on-system-error + (guard (c ((shepherd-error? c) + (report-shepherd-error c))) + body ...))) + +(define (report-shepherd-error error) + "Report ERROR, a '&shepherd-error' error condition object." + (cond ((service-not-found-error? error) + (report-error (_ "service '~a' could not be found~%") + (service-not-found-error-service error))) + ((action-not-found-error? error) + (report-error (_ "service '~a' does not have an action '~a'~%") + (action-not-found-error-service error) + (action-not-found-error-action error))) + ((action-exception-error? error) + (report-error (_ "exception caught while executing '~a' \ +on service '~a':~%") + (action-exception-error-action error) + (action-exception-error-service error)) + (print-exception (current-error-port) #f + (action-exception-error-key error) + (action-exception-error-arguments error))) + ((unknown-shepherd-error? error) + (report-error (_ "something went wrong: ~s~%") + (unknown-shepherd-error-sexp error))) + ((shepherd-error? error) + (report-error (_ "shepherd error~%"))) + ((not error) ;not an error + #t))) + +(define (call-with-service-upgrade-info new-services mproc) + "Call MPROC, a monadic procedure in %STORE-MONAD, passing it the list of +names of services to load (upgrade), and the list of names of services to +unload." + (define (essential? service) + (memq service '(root shepherd))) + + (define new-service-names + (map (compose first shepherd-service-provision) + new-services)) + + (let-values (((running stopped) (current-services))) + (if (and running stopped) + (let* ((to-load + ;; Only load services that are either new or currently stopped. + (remove (lambda (service) + (memq (first (shepherd-service-provision service)) + running)) + new-services)) + (to-unload + ;; Unload services that are (1) no longer required, or (2) are + ;; in TO-LOAD. + (remove essential? + (append (remove (lambda (service) + (memq service new-service-names)) + (append running stopped)) + (filter (lambda (service) + (memq service stopped)) + (map shepherd-service-canonical-name + to-load)))))) + (mproc to-load to-unload)) + (with-monad %store-monad + (warning (_ "failed to obtain list of shepherd services~%")) + (return #f))))) + (define (upgrade-shepherd-services os) "Upgrade the Shepherd (PID 1) by unloading obsolete services and loading new services specified in OS and not currently running. @@ -243,59 +309,35 @@ services specified in OS and not currently running. This is currently very conservative in that it does not stop or unload any running service. Unloading or stopping the wrong service ('udev', say) could bring the system down." - (define (essential? service) - (memq service '(root shepherd))) - (define new-services (service-parameters (fold-services (operating-system-services os) #:target-type shepherd-root-service-type))) - (define new-service-names - (map (compose first shepherd-service-provision) - new-services)) - - ;; Arrange to simply emit a warning if we cannot connect to the shepherd. - (warn-on-system-error - (let-values (((running stopped) (current-services))) - (define to-load - ;; Only load services that are either new or currently stopped. - (remove (lambda (service) - (memq (first (shepherd-service-provision service)) - running)) - new-services)) - (define to-unload - ;; Unload services that are (1) no longer required, or (2) are in - ;; TO-LOAD. - (remove essential? - (append (remove (lambda (service) - (memq service new-service-names)) - (append running stopped)) - (filter (lambda (service) - (memq service stopped)) - (map shepherd-service-canonical-name - to-load))))) - - (for-each (lambda (unload) - (info (_ "unloading service '~a'...~%") unload) - (unload-service unload)) - to-unload) - - (with-monad %store-monad - (munless (null? to-load) - (let ((to-load-names (map shepherd-service-canonical-name to-load)) - (to-start (filter shepherd-service-auto-start? to-load))) - (info (_ "loading new services:~{ ~a~}...~%") to-load-names) - (mlet %store-monad ((files (mapm %store-monad shepherd-service-file - to-load))) - ;; Here we assume that FILES are exactly those that were computed - ;; as part of the derivation that built OS, which is normally the - ;; case. - (load-services (map derivation->output-path files)) - - (for-each start-service - (map shepherd-service-canonical-name to-start)) - (return #t)))))))) + ;; Arrange to simply emit a warning if the service upgrade fails. + (with-shepherd-error-handling + (call-with-service-upgrade-info new-services + (lambda (to-load to-unload) + (for-each (lambda (unload) + (info (_ "unloading service '~a'...~%") unload) + (unload-service unload)) + to-unload) + + (with-monad %store-monad + (munless (null? to-load) + (let ((to-load-names (map shepherd-service-canonical-name to-load)) + (to-start (filter shepherd-service-auto-start? to-load))) + (info (_ "loading new services:~{ ~a~}...~%") to-load-names) + (mlet %store-monad ((files (mapm %store-monad shepherd-service-file + to-load))) + ;; Here we assume that FILES are exactly those that were computed + ;; as part of the derivation that built OS, which is normally the + ;; case. + (load-services (map derivation->output-path files)) + + (for-each start-service + (map shepherd-service-canonical-name to-start)) + (return #t))))))))) (define* (switch-to-system os #:optional (profile %system-profile)) @@ -839,4 +881,8 @@ argument list and OPTS is the option alist." (parameterize ((%graft? (assoc-ref opts 'graft?))) (process-command command args opts))))) +;;; Local Variables: +;;; eval: (put 'call-with-service-upgrade-info 'scheme-indent-function 1) +;;; End: + ;;; system.scm ends here -- cgit v1.2.3 From 6aaf3ea62d883a717a3459b6c6da3c1cfede55e2 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 May 2016 16:59:31 +0200 Subject: environment: Use 'break' instead of 'split'. * guix/scripts/environment.scm (parse-args): Use 'break' instead of 'split'. --- guix/scripts/environment.scm | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index d4c09ef54c..9ba487d1eb 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -25,7 +25,6 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix search-paths) - #:use-module (guix utils) #:use-module (guix build utils) #:use-module (guix monads) #:use-module ((guix gexp) #:select (lower-inputs)) @@ -499,12 +498,13 @@ Otherwise, return the derivation for the Bash package." ;; The '--' token is used to separate the command to run from the rest of ;; the operands. - (let-values (((args command) (split args "--"))) + (let-values (((args command) (break (cut string=? "--" <>) args))) (let ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument))) - (if (null? command) - opts - (alist-cons 'exec command opts))))) + (match command + (() opts) + (("--") opts) + (("--" command ...) (alist-cons 'exec command opts)))))) (define (assert-container-features) "Check if containers can be created and exit with an informative error -- cgit v1.2.3 From 4b6fa8b33970be414ae035f63ed80b147dcd8200 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 May 2016 17:02:15 +0200 Subject: utils: Remove 'split'. This procedure was redundant with SRFI-1's 'break'. * guix/utils.scm (split): Remove. * tests/utils.scm ("split, element is in list") ("split, element is not in list"): Remove. --- guix/utils.scm | 18 ------------------ tests/utils.scm | 14 -------------- 2 files changed, 32 deletions(-) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 6c01edde21..725f4346c3 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -85,7 +85,6 @@ fold2 fold-tree fold-tree-leaves - split cache-directory readlink* edit-expression @@ -788,23 +787,6 @@ are connected to NODE in the tree, or '() or #f if NODE is a leaf node." (else result))) init children roots)) -(define (split lst e) - "Return two values, a list containing the elements of the list LST that -appear before the first occurence of the object E and a list containing the -elements after E." - (define (same? x) - (equal? e x)) - - (let loop ((rest lst) - (acc '())) - (match rest - (() - (values lst '())) - (((? same?) . tail) - (values (reverse acc) tail)) - ((head . tail) - (loop tail (cons head acc)))))) - (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." (or (getenv "XDG_CONFIG_HOME") diff --git a/tests/utils.scm b/tests/utils.scm index d0ee02a1cf..854999f670 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -122,20 +122,6 @@ '(0 1 2 3))) list)) -(test-equal "split, element is in list" - '((foo) (baz)) - (call-with-values - (lambda () - (split '(foo bar baz) 'bar)) - list)) - -(test-equal "split, element is not in list" - '((foo bar baz) ()) - (call-with-values - (lambda () - (split '(foo bar baz) 'quux)) - list)) - (test-equal "strip-keyword-arguments" '(a #:b b #:c c) (strip-keyword-arguments '(#:foo #:bar #:baz) -- cgit v1.2.3 From 958dd3ce68733bcd5c1231424c7e4ad39e67594a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 4 May 2016 17:35:47 +0200 Subject: utils: Move combinators to (guix combinators). * guix/utils.scm (compile-time-value, memoize, fold2) (fold-tree, fold-tree-leaves): Move to... * guix/combinators: ... here. New file. * tests/utils.scm ("fold2, 1 list", "fold2, 2 lists") (fold-tree tests): Move to... * tests/combinators.scm: ... here. New file. * Makefile.am (MODULES, SCM_TESTS): Add them. * gnu/packages.scm, gnu/packages/bootstrap.scm, gnu/services/herd.scm, guix/build-system/gnu.scm, guix/build-system/python.scm, guix/derivations.scm, guix/gnu-maintenance.scm, guix/import/elpa.scm, guix/scripts/archive.scm, guix/scripts/build.scm, guix/scripts/graph.scm, guix/scripts/lint.scm, guix/scripts/size.scm, guix/scripts/substitute.scm, guix/serialization.scm, guix/store.scm, guix/ui.scm: Adjust imports accordingly. --- Makefile.am | 2 + gnu/packages.scm | 1 + gnu/packages/bootstrap.scm | 3 +- gnu/services/herd.scm | 2 +- guix/build-system/gnu.scm | 1 + guix/build-system/python.scm | 1 + guix/combinators.scm | 116 +++++++++++++++++++++++++++++++++++++++++++ guix/derivations.scm | 1 + guix/gnu-maintenance.scm | 3 +- guix/import/elpa.scm | 4 +- guix/scripts/archive.scm | 1 + guix/scripts/build.scm | 1 + guix/scripts/graph.scm | 2 +- guix/scripts/lint.scm | 1 + guix/scripts/size.scm | 2 +- guix/scripts/substitute.scm | 1 + guix/serialization.scm | 4 +- guix/store.scm | 1 + guix/ui.scm | 1 + guix/utils.scm | 98 +++--------------------------------- tests/combinators.scm | 85 +++++++++++++++++++++++++++++++ tests/utils.scm | 56 --------------------- 22 files changed, 231 insertions(+), 156 deletions(-) create mode 100644 guix/combinators.scm create mode 100644 tests/combinators.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index d0c1826782..4685fe1650 100644 --- a/Makefile.am +++ b/Makefile.am @@ -38,6 +38,7 @@ MODULES = \ guix/hash.scm \ guix/pk-crypto.scm \ guix/pki.scm \ + guix/combinators.scm \ guix/utils.scm \ guix/sets.scm \ guix/download.scm \ @@ -231,6 +232,7 @@ SCM_TESTS = \ tests/ui.scm \ tests/records.scm \ tests/upstream.scm \ + tests/combinators.scm \ tests/utils.scm \ tests/build-utils.scm \ tests/packages.scm \ diff --git a/gnu/packages.scm b/gnu/packages.scm index 1e3f383cbc..7130f58fdd 100644 --- a/gnu/packages.scm +++ b/gnu/packages.scm @@ -24,6 +24,7 @@ #:use-module (guix packages) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module ((guix build utils) #:select ((package-name->name+version . hyphen-separated-name->name+version))) diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm index a3cd18519c..6a4eba99ef 100644 --- a/gnu/packages/bootstrap.scm +++ b/gnu/packages/bootstrap.scm @@ -27,7 +27,8 @@ #:use-module (guix build-system trivial) #:use-module ((guix store) #:select (add-to-store add-text-to-store)) #:use-module ((guix derivations) #:select (derivation)) - #:use-module (guix utils) + #:use-module ((guix utils) #:select (gnu-triplet->nix-system)) + #:use-module (guix combinators) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) diff --git a/gnu/services/herd.scm b/gnu/services/herd.scm index c06e98800e..7a9db90012 100644 --- a/gnu/services/herd.scm +++ b/gnu/services/herd.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu services herd) - #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-34) diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm index a7d1952b57..f6df183da4 100644 --- a/guix/build-system/gnu.scm +++ b/guix/build-system/gnu.scm @@ -19,6 +19,7 @@ (define-module (guix build-system gnu) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix derivations) #:use-module (guix search-paths) #:use-module (guix build-system) diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 326e6fd429..c3d6c62404 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -21,6 +21,7 @@ (define-module (guix build-system python) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix search-paths) diff --git a/guix/combinators.scm b/guix/combinators.scm new file mode 100644 index 0000000000..9e4689ba9c --- /dev/null +++ b/guix/combinators.scm @@ -0,0 +1,116 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014 Eric Bavier +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (guix combinators) + #:use-module (ice-9 match) + #:use-module (ice-9 vlist) + #:export (memoize + fold2 + fold-tree + fold-tree-leaves + compile-time-value)) + +;;; Commentary: +;;; +;;; This module provides useful combinators that complement SRFI-1 and +;;; friends. +;;; +;;; Code: + +(define (memoize proc) + "Return a memoizing version of PROC." + (let ((cache (make-hash-table))) + (lambda args + (let ((results (hash-ref cache args))) + (if results + (apply values results) + (let ((results (call-with-values (lambda () + (apply proc args)) + list))) + (hash-set! cache args results) + (apply values results))))))) + +(define fold2 + (case-lambda + ((proc seed1 seed2 lst) + "Like `fold', but with a single list and two seeds." + (let loop ((result1 seed1) + (result2 seed2) + (lst lst)) + (if (null? lst) + (values result1 result2) + (call-with-values + (lambda () (proc (car lst) result1 result2)) + (lambda (result1 result2) + (loop result1 result2 (cdr lst))))))) + ((proc seed1 seed2 lst1 lst2) + "Like `fold', but with a two lists and two seeds." + (let loop ((result1 seed1) + (result2 seed2) + (lst1 lst1) + (lst2 lst2)) + (if (or (null? lst1) (null? lst2)) + (values result1 result2) + (call-with-values + (lambda () (proc (car lst1) (car lst2) result1 result2)) + (lambda (result1 result2) + (fold2 proc result1 result2 (cdr lst1) (cdr lst2))))))))) + +(define (fold-tree proc init children roots) + "Call (PROC NODE RESULT) for each node in the tree that is reachable from +ROOTS, using INIT as the initial value of RESULT. The order in which nodes +are traversed is not specified, however, each node is visited only once, based +on an eq? check. Children of a node to be visited are generated by +calling (CHILDREN NODE), the result of which should be a list of nodes that +are connected to NODE in the tree, or '() or #f if NODE is a leaf node." + (let loop ((result init) + (seen vlist-null) + (lst roots)) + (match lst + (() result) + ((head . tail) + (if (not (vhash-assq head seen)) + (loop (proc head result) + (vhash-consq head #t seen) + (match (children head) + ((or () #f) tail) + (children (append tail children)))) + (loop result seen tail)))))) + +(define (fold-tree-leaves proc init children roots) + "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes." + (fold-tree + (lambda (node result) + (match (children node) + ((or () #f) (proc node result)) + (else result))) + init children roots)) + +(define-syntax compile-time-value ;not quite at home + (syntax-rules () + "Evaluate the given expression at compile time. The expression must +evaluate to a simple datum." + ((_ exp) + (let-syntax ((v (lambda (s) + (let ((val exp)) + (syntax-case s () + (_ #`'#,(datum->syntax s val))))))) + v)))) + +;;; combinators.scm ends here diff --git a/guix/derivations.scm b/guix/derivations.scm index 2d8584e72d..d4f697477b 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -30,6 +30,7 @@ #:use-module (ice-9 vlist) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix monads) #:use-module (guix hash) #:use-module (guix base32) diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 8021d99c8b..adb62aa68c 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2012, 2013 Nikita Karetnikov ;;; ;;; This file is part of GNU Guix. @@ -30,6 +30,7 @@ #:use-module (guix http-client) #:use-module (guix ftp-client) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix records) #:use-module (guix upstream) #:use-module (guix packages) diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index ccc4063a53..320a09e8c6 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -35,8 +35,8 @@ #:use-module (guix base32) #:use-module (guix upstream) #:use-module (guix packages) - #:use-module ((guix utils) #:select (call-with-temporary-output-file - memoize)) + #:use-module ((guix combinators) #:select (memoize)) + #:use-module ((guix utils) #:select (call-with-temporary-output-file)) #:export (elpa->guix-package %elpa-updater)) diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm index 3fb210ee91..e06c38aaab 100644 --- a/guix/scripts/archive.scm +++ b/guix/scripts/archive.scm @@ -19,6 +19,7 @@ (define-module (guix scripts archive) #:use-module (guix config) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix serialization) #:select (restore-file)) #:use-module (guix store) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 9a6b427fc5..320ec39be2 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -24,6 +24,7 @@ #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix grafts) + #:use-module (guix combinators) ;; Use the procedure that destructures "NAME-VERSION" forms. #:use-module ((guix utils) #:hide (package-name->name+version)) diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm index b0d7c08582..ba63780e2b 100644 --- a/guix/scripts/graph.scm +++ b/guix/scripts/graph.scm @@ -21,7 +21,7 @@ #:use-module (guix graph) #:use-module (guix grafts) #:use-module (guix scripts) - #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix packages) #:use-module (guix monads) #:use-module (guix store) diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index c581586ac3..06001d3eae 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -31,6 +31,7 @@ #:use-module (guix records) #:use-module (guix ui) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix scripts) #:use-module (guix gnu-maintenance) #:use-module (guix monads) diff --git a/guix/scripts/size.scm b/guix/scripts/size.scm index 8f0cb7decd..be1e8ca087 100644 --- a/guix/scripts/size.scm +++ b/guix/scripts/size.scm @@ -21,7 +21,7 @@ #:use-module (guix scripts) #:use-module (guix store) #:use-module (guix monads) - #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix grafts) #:use-module (guix packages) #:use-module (guix derivations) diff --git a/guix/scripts/substitute.scm b/guix/scripts/substitute.scm index 1cfab81dbd..d46d610347 100755 --- a/guix/scripts/substitute.scm +++ b/guix/scripts/substitute.scm @@ -21,6 +21,7 @@ #:use-module (guix ui) #:use-module ((guix store) #:hide (close-connection)) #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (guix config) #:use-module (guix records) #:use-module (guix serialization) diff --git a/guix/serialization.scm b/guix/serialization.scm index 7a3defc03d..286b4cbf30 100644 --- a/guix/serialization.scm +++ b/guix/serialization.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix serialization) - #:use-module (guix utils) + #:use-module (guix combinators) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) diff --git a/guix/store.scm b/guix/store.scm index 8d1099dab2..f352a99cbd 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -19,6 +19,7 @@ (define-module (guix store) #:use-module (guix utils) #:use-module (guix config) + #:use-module (guix combinators) #:use-module (guix serialization) #:use-module (guix monads) #:autoload (guix base32) (bytevector->base32-string) diff --git a/guix/ui.scm b/guix/ui.scm index 04ac43723e..8310974ac7 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -30,6 +30,7 @@ #:use-module (guix packages) #:use-module (guix profiles) #:use-module (guix derivations) + #:use-module (guix combinators) #:use-module (guix build-system) #:use-module (guix serialization) #:use-module ((guix build utils) #:select (mkdir-p)) diff --git a/guix/utils.scm b/guix/utils.scm index 725f4346c3..f18bbd19ac 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -32,6 +32,7 @@ #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #: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 (ice-9 vlist) @@ -46,9 +47,7 @@ #:export (bytevector->base16-string base16-string->bytevector - compile-time-value fcntl-flock - memoize strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -82,9 +81,6 @@ call-with-temporary-output-file call-with-temporary-directory with-atomic-file-output - fold2 - fold-tree - fold-tree-leaves cache-directory readlink* edit-expression @@ -97,22 +93,6 @@ call-with-compressed-output-port canonical-newline-port)) - -;;; -;;; Compile-time computations. -;;; - -(define-syntax compile-time-value - (syntax-rules () - "Evaluate the given expression at compile time. The expression must -evaluate to a simple datum." - ((_ exp) - (let-syntax ((v (lambda (s) - (let ((val exp)) - (syntax-case s () - (_ #`'#,(datum->syntax s val))))))) - v)))) - ;;; ;;; Base 16. @@ -432,22 +412,9 @@ exception if it's already taken." ;;; -;;; Miscellaneous. +;;; Keyword arguments. ;;; -(define (memoize proc) - "Return a memoizing version of PROC." - (let ((cache (make-hash-table))) - (lambda args - (let ((results (hash-ref cache args))) - (if results - (apply values results) - (let ((results (call-with-values (lambda () - (apply proc args)) - list))) - (hash-set! cache args results) - (apply values results))))))) - (define (strip-keyword-arguments keywords args) "Remove all of the keyword arguments listed in KEYWORDS from ARGS." (let loop ((args args) @@ -533,6 +500,11 @@ For instance: (#f (loop rest kw/values (cons* value kw result)))))))) + +;;; +;;; System strings. +;;; + (define* (nix-system->gnu-triplet #:optional (system (%current-system)) (vendor "unknown")) "Return a guess of the GNU triplet corresponding to Nix system @@ -731,62 +703,6 @@ output port, and PROC's result is returned." (lambda (key . args) (false-if-exception (delete-file template)))))) -(define fold2 - (case-lambda - ((proc seed1 seed2 lst) - "Like `fold', but with a single list and two seeds." - (let loop ((result1 seed1) - (result2 seed2) - (lst lst)) - (if (null? lst) - (values result1 result2) - (call-with-values - (lambda () (proc (car lst) result1 result2)) - (lambda (result1 result2) - (loop result1 result2 (cdr lst))))))) - ((proc seed1 seed2 lst1 lst2) - "Like `fold', but with a two lists and two seeds." - (let loop ((result1 seed1) - (result2 seed2) - (lst1 lst1) - (lst2 lst2)) - (if (or (null? lst1) (null? lst2)) - (values result1 result2) - (call-with-values - (lambda () (proc (car lst1) (car lst2) result1 result2)) - (lambda (result1 result2) - (fold2 proc result1 result2 (cdr lst1) (cdr lst2))))))))) - -(define (fold-tree proc init children roots) - "Call (PROC NODE RESULT) for each node in the tree that is reachable from -ROOTS, using INIT as the initial value of RESULT. The order in which nodes -are traversed is not specified, however, each node is visited only once, based -on an eq? check. Children of a node to be visited are generated by -calling (CHILDREN NODE), the result of which should be a list of nodes that -are connected to NODE in the tree, or '() or #f if NODE is a leaf node." - (let loop ((result init) - (seen vlist-null) - (lst roots)) - (match lst - (() result) - ((head . tail) - (if (not (vhash-assq head seen)) - (loop (proc head result) - (vhash-consq head #t seen) - (match (children head) - ((or () #f) tail) - (children (append tail children)))) - (loop result seen tail)))))) - -(define (fold-tree-leaves proc init children roots) - "Like fold-tree, but call (PROC NODE RESULT) only for leaf nodes." - (fold-tree - (lambda (node result) - (match (children node) - ((or () #f) (proc node result)) - (else result))) - init children roots)) - (define (cache-directory) "Return the cache directory for Guix, by default ~/.cache/guix." (or (getenv "XDG_CONFIG_HOME") diff --git a/tests/combinators.scm b/tests/combinators.scm new file mode 100644 index 0000000000..1e4bb236b7 --- /dev/null +++ b/tests/combinators.scm @@ -0,0 +1,85 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès +;;; Copyright © 2014 Eric Bavier +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see . + +(define-module (test-combinators) + #:use-module (guix combinators) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (ice-9 vlist)) + +(test-begin "combinators") + +(test-equal "fold2, 1 list" + (list (reverse (iota 5)) + (map - (reverse (iota 5)))) + (call-with-values + (lambda () + (fold2 (lambda (i r1 r2) + (values (cons i r1) + (cons (- i) r2))) + '() '() + (iota 5))) + list)) + +(test-equal "fold2, 2 lists" + (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3))) + (reverse '((a . 0) (b . -1) (c . -2) (d . -3)))) + (call-with-values + (lambda () + (fold2 (lambda (k v r1 r2) + (values (alist-cons k v r1) + (alist-cons k (- v) r2))) + '() '() + '(a b c d) + '(0 1 2 3))) + list)) + +(let* ((tree (alist->vhash + '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6)) + hashq)) + (add-one (lambda (_ r) (1+ r))) + (tree-lookup (lambda (n) (cdr (vhash-assq n tree))))) + (test-equal "fold-tree, single root" + 5 (fold-tree add-one 0 tree-lookup '(0))) + (test-equal "fold-tree, two roots" + 7 (fold-tree add-one 0 tree-lookup '(0 1))) + (test-equal "fold-tree, sum" + 16 (fold-tree + 0 tree-lookup '(0))) + (test-equal "fold-tree, internal" + 18 (fold-tree + 0 tree-lookup '(3 4))) + (test-equal "fold-tree, cons" + '(1 3 4 5 6) + (sort (fold-tree cons '() tree-lookup '(1)) <)) + (test-equal "fold-tree, overlapping paths" + '(1 3 4 5 6) + (sort (fold-tree cons '() tree-lookup '(1 4)) <)) + (test-equal "fold-tree, cons, two roots" + '(0 2 3 4 5 6) + (sort (fold-tree cons '() tree-lookup '(0 4)) <)) + (test-equal "fold-tree-leaves, single root" + 2 (fold-tree-leaves add-one 0 tree-lookup '(1))) + (test-equal "fold-tree-leaves, single root, sum" + 11 (fold-tree-leaves + 0 tree-lookup '(1))) + (test-equal "fold-tree-leaves, two roots" + 3 (fold-tree-leaves add-one 0 tree-lookup '(0 1))) + (test-equal "fold-tree-leaves, two roots, sum" + 13 (fold-tree-leaves + 0 tree-lookup '(0 1)))) + +(test-end) + diff --git a/tests/utils.scm b/tests/utils.scm index 854999f670..a54482e94c 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -97,31 +97,6 @@ (string-replace-substring "/nix/store/chbouib" "/nix/" "/gnu/") (string-replace-substring "" "foo" "bar"))) -(test-equal "fold2, 1 list" - (list (reverse (iota 5)) - (map - (reverse (iota 5)))) - (call-with-values - (lambda () - (fold2 (lambda (i r1 r2) - (values (cons i r1) - (cons (- i) r2))) - '() '() - (iota 5))) - list)) - -(test-equal "fold2, 2 lists" - (list (reverse '((a . 0) (b . 1) (c . 2) (d . 3))) - (reverse '((a . 0) (b . -1) (c . -2) (d . -3)))) - (call-with-values - (lambda () - (fold2 (lambda (k v r1 r2) - (values (alist-cons k v r1) - (alist-cons k (- v) r2))) - '() '() - '(a b c d) - '(0 1 2 3))) - list)) - (test-equal "strip-keyword-arguments" '(a #:b b #:c c) (strip-keyword-arguments '(#:foo #:bar #:baz) @@ -136,37 +111,6 @@ (ensure-keyword-arguments '(#:foo 2) '(#:bar 3)) (ensure-keyword-arguments '(#:foo 2) '(#:bar 3 #:foo 42)))) -(let* ((tree (alist->vhash - '((0 2 3) (1 3 4) (2) (3 5 6) (4 6) (5) (6)) - hashq)) - (add-one (lambda (_ r) (1+ r))) - (tree-lookup (lambda (n) (cdr (vhash-assq n tree))))) - (test-equal "fold-tree, single root" - 5 (fold-tree add-one 0 tree-lookup '(0))) - (test-equal "fold-tree, two roots" - 7 (fold-tree add-one 0 tree-lookup '(0 1))) - (test-equal "fold-tree, sum" - 16 (fold-tree + 0 tree-lookup '(0))) - (test-equal "fold-tree, internal" - 18 (fold-tree + 0 tree-lookup '(3 4))) - (test-equal "fold-tree, cons" - '(1 3 4 5 6) - (sort (fold-tree cons '() tree-lookup '(1)) <)) - (test-equal "fold-tree, overlapping paths" - '(1 3 4 5 6) - (sort (fold-tree cons '() tree-lookup '(1 4)) <)) - (test-equal "fold-tree, cons, two roots" - '(0 2 3 4 5 6) - (sort (fold-tree cons '() tree-lookup '(0 4)) <)) - (test-equal "fold-tree-leaves, single root" - 2 (fold-tree-leaves add-one 0 tree-lookup '(1))) - (test-equal "fold-tree-leaves, single root, sum" - 11 (fold-tree-leaves + 0 tree-lookup '(1))) - (test-equal "fold-tree-leaves, two roots" - 3 (fold-tree-leaves add-one 0 tree-lookup '(0 1))) - (test-equal "fold-tree-leaves, two roots, sum" - 13 (fold-tree-leaves + 0 tree-lookup '(0 1)))) - (test-assert "filtered-port, file" (let* ((file (search-path %load-path "guix.scm")) (input (open-file file "r0b"))) -- cgit v1.2.3 From 4e0ea3eb288c2143b44bf324c64047762c72d3b3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 May 2016 13:12:45 +0200 Subject: utils: Move 'fcntl-flock' to (guix build syscalls). * 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. --- guix/build/syscalls.scm | 69 ++++++++++++++++++++++++++++++++++++++ guix/nar.scm | 4 +-- guix/utils.scm | 75 +---------------------------------------- tests/syscalls.scm | 88 +++++++++++++++++++++++++++++++++++++++++++++++++ tests/utils.scm | 82 --------------------------------------------- 5 files changed, 160 insertions(+), 158 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a9cd6e93c8..86723c23c7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -65,6 +65,7 @@ processes mkdtemp! pivot-root + fcntl-flock CLONE_CHILD_CLEARTID CLONE_CHILD_SETTID @@ -637,6 +638,74 @@ system to PUT-OLD." (list new-root put-old (strerror err)) (list err))))))) + +;;; +;;; Advisory file locking. +;;; + +(define %struct-flock + ;; 'struct flock' from . + (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. diff --git a/guix/nar.scm b/guix/nar.scm index 43e5210752..739d3d3a57 100644 --- a/guix/nar.scm +++ b/guix/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès ;;; Copyright © 2014 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -18,8 +18,8 @@ ;;; along with GNU Guix. If not, see . (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) diff --git a/guix/utils.scm b/guix/utils.scm index f18bbd19ac..d924e434bd 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -34,7 +34,7 @@ #: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 @@ #:export (bytevector->base16-string base16-string->bytevector - fcntl-flock strip-keyword-arguments default-keyword-arguments substitute-keyword-arguments @@ -338,78 +337,6 @@ This procedure returns #t on success." (put-bytevector out post-bv)) #t)))))) - -;;; -;;; Advisory file locking. -;;; - -(define %struct-flock - ;; 'struct flock' from . - (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. diff --git a/tests/syscalls.scm b/tests/syscalls.scm index 0b73fb4b0c..73fa8a7acf 100644 --- a/tests/syscalls.scm +++ b/tests/syscalls.scm @@ -29,6 +29,10 @@ ;; 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 @@ (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 @@ 0)) (test-end) + +(false-if-exception (delete-file temp-file)) diff --git a/tests/utils.scm b/tests/utils.scm index a54482e94c..6590ed91cf 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -168,88 +168,6 @@ (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" -- cgit v1.2.3 From d33c8b464915fb9bbe07434116fd6f3428e8cef0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 6 May 2016 13:23:54 +0200 Subject: syscalls: Use 'define-c-struct' for 'fcntl-flock'. * guix/build/syscalls.scm (%struct-flock): Use 'define-c-struct'. (fcntl-flock): Use 'write-flock!' and 'make-bytevector' instead of 'make-c-struct'. --- guix/build/syscalls.scm | 41 ++++++++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 86723c23c7..48ff227e10 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -643,13 +643,16 @@ system to PUT-OLD." ;;; Advisory file locking. ;;; -(define %struct-flock - ;; 'struct flock' from . - (list short ; l_type - short ; l_whence - size_t ; l_start - size_t ; l_len - int)) ; l_pid +(define-c-struct %struct-flock ; + sizeof-flock + list + read-flock + write-flock! + (type short) + (whence short) + (start size_t) + (length size_t) + (pid int)) (define F_SETLKW ;; On Linux-based systems, this is usually 7, but not always @@ -690,21 +693,25 @@ exception if it's already taken." (fileno fd-or-port) fd-or-port)) + (define bv + (make-bytevector sizeof-flock)) + + (write-flock! bv 0 + (operation->int operation) SEEK_SET + 0 0 ;whole file + 0) + ;; XXX: 'fcntl' is a vararg function, but here we happily use the ;; standard ABI; crossing fingers. - (let ((err (proc fd + (let ((ret (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))))))) + (bytevector->pointer bv))) + (err (errno))) + (unless (zero? ret) + ;; Presumably we got EAGAIN or so. + (throw 'flock-error err)))))) ;;; -- cgit v1.2.3 From 19e1d5f7f90194f1ac7e783b28a688ce1441786d Mon Sep 17 00:00:00 2001 From: Alex Kost Date: Fri, 6 May 2016 21:19:06 +0300 Subject: guix: utils: Re-export 'memoize'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Suggested by Ludovic Courtès . * guix/utils.scm: Re-export 'memoize' to avoid a potential breakage of emacs interface. See for details. --- guix/utils.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index d924e434bd..c77da5d846 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -44,6 +44,7 @@ #:use-module (ice-9 format) #:use-module ((ice-9 iconv) #:select (bytevector->string)) #:use-module (system foreign) + #:re-export (memoize) ; for backwards compatibility #:export (bytevector->base16-string base16-string->bytevector -- cgit v1.2.3