diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build/download.scm | 18 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 163 | ||||
| -rw-r--r-- | guix/profiles.scm | 8 | ||||
| -rw-r--r-- | guix/scripts/offload.scm | 43 | ||||
| -rw-r--r-- | guix/scripts/package.scm | 15 | ||||
| -rw-r--r-- | guix/scripts/pull.scm | 86 | ||||
| -rw-r--r-- | guix/ui.scm | 13 | ||||
| -rw-r--r-- | guix/utils.scm | 5 |
8 files changed, 267 insertions, 84 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index d98933a907..c081f3b29b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -112,13 +112,25 @@ abbreviation of URI showing the scheme, host, and basename of the file." "Hold a weak reference from FROM to TO." (hashq-set! table from to)))) -(define (tls-wrap port) - "Return PORT wrapped in a TLS connection." +(define (tls-wrap port server) + "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS +host name without trailing dot." (define (log level str) (format (current-error-port) "gnutls: [~a|~a] ~a" (getpid) level str)) (let ((session (make-session connection-end/client))) + + ;; Some servers such as 'cloud.github.com' require the client to support + ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is + ;; not available in older GnuTLS releases. See + ;; <http://bugs.gnu.org/18526> for details. + (if (module-defined? (resolve-interface '(gnutls)) + 'set-session-server-name!) + (set-session-server-name! session server-name-type/dns server) + (format (current-error-port) + "warning: TLS 'SERVER NAME' extension not supported~%")) + (set-session-transport-fd! session (fileno port)) (set-session-default-priority! session) (set-session-credentials! session (make-certificate-credentials)) @@ -169,7 +181,7 @@ which is not available during bootstrap." (setvbuf s _IOFBF) (if (eq? 'https (uri-scheme uri)) - (tls-wrap s) + (tls-wrap s (uri-host uri)) s)) (lambda args ;; Connection failed, so try one of the other addresses. diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 7a1bad7331..7e5245fcc6 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -21,6 +21,7 @@ #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) #:use-module (ice-9 match) #:use-module (ice-9 ftw) #:export (errno @@ -30,7 +31,17 @@ MS_MOVE mount umount - processes)) + swapon + swapoff + processes + + IFF_UP + IFF_BROADCAST + IFF_LOOPBACK + all-network-interfaces + network-interfaces + network-interface-flags + loopback-network-interface?)) ;;; Commentary: ;;; @@ -155,6 +166,30 @@ constants from <sys/mount.h>." (when update-mtab? (remove-from-mtab target)))))) +(define swapon + (let* ((ptr (dynamic-func "swapon" (dynamic-link))) + (proc (pointer->procedure int ptr (list '* int)))) + (lambda* (device #:optional (flags 0)) + "Use the block special device at DEVICE for swapping." + (let ((ret (proc (string->pointer device) flags)) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "swapon" "~S: ~A" + (list device (strerror err)) + (list err))))))) + +(define swapoff + (let* ((ptr (dynamic-func "swapoff" (dynamic-link))) + (proc (pointer->procedure int ptr '(*)))) + (lambda (device) + "Stop using block special device DEVICE for swapping." + (let ((ret (proc (string->pointer device))) + (err (errno))) + (unless (zero? ret) + (throw 'system-error "swapff" "~S: ~A" + (list device (strerror err)) + (list err))))))) + (define (kernel? pid) "Return #t if PID designates a \"kernel thread\" rather than a normal user-land process." @@ -180,4 +215,130 @@ user-land process." (scandir "/proc")) <)) + +;;; +;;; Network interfaces. +;;; + +(define SIOCGIFCONF ;from <bits/ioctls.h> + (if (string-contains %host-type "linux") + #x8912 ;GNU/Linux + #xf00801a4)) ;GNU/Hurd +(define SIOCGIFFLAGS + (if (string-contains %host-type "linux") + #x8913 ;GNU/Linux + #xc4804191)) ;GNU/Hurd + +;; Flags and constants from <net/if.h>. + +(define IFF_UP #x1) ;Interface is up +(define IFF_BROADCAST #x2) ;Broadcast address valid. +(define IFF_LOOPBACK #x8) ;Is a loopback net. + +(define IF_NAMESIZE 16) ;maximum interface name size + +(define ifconf-struct + ;; 'struct ifconf', from <net/if.h>. + (list int ;int ifc_len + '*)) ;struct ifreq *ifc_ifcu + +(define ifreq-struct-size + ;; 'struct ifreq' begins with an array of IF_NAMESIZE bytes containing the + ;; interface name (nul-terminated), followed by a bunch of stuff. This is + ;; its size in bytes. + (if (= 8 (sizeof '*)) + 40 + 32)) + +(define %ioctl + ;; The most terrible interface, live from Scheme. + (pointer->procedure int + (dynamic-func "ioctl" (dynamic-link)) + (list int unsigned-long '*))) + +(define (bytevector->string-list bv stride len) + "Return the null-terminated strings found in BV every STRIDE bytes. Read at +most LEN bytes from BV." + (let loop ((bytes (take (bytevector->u8-list bv) + (min len (bytevector-length bv)))) + (result '())) + (match bytes + (() + (reverse result)) + (_ + (loop (drop bytes stride) + (cons (list->string (map integer->char + (take-while (negate zero?) bytes))) + result)))))) + +(define* (network-interfaces #:optional sock) + "Return the list of existing network interfaces. This is typically limited +to interfaces that are currently up." + (let* ((close? (not sock)) + (sock (or sock (socket SOCK_STREAM AF_INET 0))) + (len (* ifreq-struct-size 10)) + (reqs (make-bytevector len)) + (conf (make-c-struct ifconf-struct + (list len (bytevector->pointer reqs)))) + (ret (%ioctl (fileno sock) SIOCGIFCONF conf)) + (err (errno))) + (when close? + (close-port sock)) + (if (zero? ret) + (bytevector->string-list reqs ifreq-struct-size + (match (parse-c-struct conf ifconf-struct) + ((len . _) len))) + (throw 'system-error "network-interface-list" + "network-interface-list: ~A" + (list (strerror err)) + (list err))))) + +(define %interface-line + ;; Regexp matching an interface line in Linux's /proc/net/dev. + (make-regexp "^[[:blank:]]*([[:alnum:]]+):.*$")) + +(define (all-network-interfaces) + "Return all the registered network interfaces, including those that are not +up." + (call-with-input-file "/proc/net/dev" ;XXX: Linux-specific + (lambda (port) + (let loop ((interfaces '())) + (let ((line (read-line port))) + (cond ((eof-object? line) + (reverse interfaces)) + ((regexp-exec %interface-line line) + => + (lambda (match) + (loop (cons (match:substring match 1) interfaces)))) + (else + (loop interfaces)))))))) + +(define (network-interface-flags socket name) + "Return a number that is the bit-wise or of 'IFF*' flags for network +interface NAME." + (let ((req (make-bytevector ifreq-struct-size))) + (bytevector-copy! (string->utf8 name) 0 req 0 + (min (string-length name) (- IF_NAMESIZE 1))) + (let* ((ret (%ioctl (fileno socket) SIOCGIFFLAGS + (bytevector->pointer req))) + (err (errno))) + (if (zero? ret) + + ;; The 'ifr_flags' field is IF_NAMESIZE bytes after the beginning of + ;; 'struct ifreq', and it's a short int. + (bytevector-sint-ref req IF_NAMESIZE (native-endianness) + (sizeof short)) + + (throw 'system-error "network-interface-flags" + "network-interface-flags on ~A: ~A" + (list name (strerror err)) + (list err)))))) + +(define (loopback-network-interface? name) + "Return true if NAME designates a loopback network interface." + (let* ((sock (socket SOCK_STREAM AF_INET 0)) + (flags (network-interface-flags sock name))) + (close-port sock) + (not (zero? (logand flags IFF_LOOPBACK))))) + ;;; syscalls.scm ends here diff --git a/guix/profiles.scm b/guix/profiles.scm index aa88b849e1..18733a6664 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -70,6 +70,7 @@ profile-derivation generation-number generation-numbers + profile-generations previous-generation-number generation-time generation-file-name)) @@ -561,6 +562,13 @@ former profiles were found." profiles) <)))) +(define (profile-generations profile) + "Return a list of PROFILE's generations." + (let ((generations (generation-numbers profile))) + (if (equal? generations '(0)) + '() + generations))) + (define (previous-generation-number profile number) "Return the number of the generation before generation NUMBER of PROFILE, or 0 if none exists. It could be NUMBER - 1, but it's not the diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm index b3b502425c..391906ff79 100644 --- a/guix/scripts/offload.scm +++ b/guix/scripts/offload.scm @@ -534,10 +534,6 @@ success, #f otherwise." (build-requirements-features requirements) (build-machine-features machine)))) -(define (machine-faster? m1 m2) - "Return #t if M1 is faster than M2." - (> (build-machine-speed m1) (build-machine-speed m2))) - (define (machine-load machine) "Return the load of MACHINE, divided by the number of parallel builds allowed on MACHINE." @@ -558,14 +554,16 @@ allowed on MACHINE." (_ +inf.0))))) ;something's fishy about MACHINE, so avoid it -(define (machine-less-loaded? m1 m2) - "Return #t if the load on M1 is lower than that on M2." - (< (machine-load m1) (machine-load m2))) +(define (machine-power-factor m) + "Return a factor that aggregates the speed and load of M. The higher the +better." + (/ (build-machine-speed m) + (+ 1 (machine-load m)))) (define (machine-less-loaded-or-faster? m1 m2) - "Return #t if M1 is either less loaded or faster than M2." - (or (machine-less-loaded? m1 m2) - (machine-faster? m1 m2))) + "Return #t if M1 is either less loaded or faster than M2. (This relation +defines a total order on machines.)" + (> (machine-power-factor m1) (machine-power-factor m2))) (define (machine-lock-file machine hint) "Return the name of MACHINE's lock file for HINT." @@ -610,22 +608,25 @@ allowed on MACHINE." (list machine1 slot1) (list machine2 slot2)))))))) - (let ((machines+slots (sort machines+slots - (undecorate machine-less-loaded-or-faster?)))) + (let loop ((machines+slots + (sort machines+slots + (undecorate machine-less-loaded-or-faster?)))) (match machines+slots - (((best slot) (others slots) ...) - ;; Release slots from the uninteresting machines. - (for-each release-build-slot slots) - + (((best slot) others ...) ;; Return the best machine unless it's already overloaded. (if (< (machine-load best) 2.) + (match others + (((machines slots) ...) + ;; Release slots from the uninteresting machines. + (for-each release-build-slot slots) + + ;; Prevent SLOT from being GC'd. + (set! %slots (cons slot %slots)) + best)) (begin - ;; Prevent SLOT from being GC'd. - (set! %slots (cons slot %slots)) - best) - (begin + ;; BEST is overloaded, so try the next one. (release-build-slot slot) - #f))) + (loop others)))) (() #f))))) (define* (process-request wants-local? system drv features diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm index 95c0130c95..7cd95167d2 100644 --- a/guix/scripts/package.scm +++ b/guix/scripts/package.scm @@ -716,12 +716,9 @@ more information.~%")) (leave (_ "profile '~a' does not exist~%") profile)) ((string-null? pattern) - (let ((numbers (generation-numbers profile))) - (if (equal? numbers '(0)) - (exit 0) - (for-each display-and-delete - (delete current-generation-number - numbers))))) + (for-each display-and-delete + (delete current-generation-number + (profile-generations profile)))) ;; Do not delete the zeroth generation. ((equal? 0 (string->number pattern)) (exit 0)) @@ -828,11 +825,7 @@ more information.~%")) (leave (_ "profile '~a' does not exist~%") profile)) ((string-null? pattern) - (let ((numbers (generation-numbers profile))) - (leave-on-EPIPE - (if (equal? numbers '(0)) - (exit 0) - (for-each list-generation numbers))))) + (for-each list-generation (profile-generations profile))) ((matching-generations pattern profile) => (lambda (numbers) diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 5dafb84f91..c2ea0e3d97 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -23,6 +23,8 @@ #:use-module (guix packages) #:use-module (guix derivations) #:use-module (guix download) + #:use-module (guix gexp) + #:use-module (guix monads) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) @@ -38,34 +40,27 @@ "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) -(define* (unpack store tarball #:key verbose?) +(define* (unpack tarball #:key verbose?) "Return a derivation that unpacks TARBALL into STORE and compiles Scheme files." (define builder - `(begin - (use-modules (guix build pull)) + #~(begin + (use-modules (guix build pull)) - (build-guix (assoc-ref %outputs "out") - (assoc-ref %build-inputs "tarball") + (build-guix #$output #$tarball - ;; XXX: This is not perfect, enabling VERBOSE? means - ;; building a different derivation. - #:debug-port (if ',verbose? - (current-error-port) - (%make-void-port "w")) - #:tar (assoc-ref %build-inputs "tar") - #:gzip (assoc-ref %build-inputs "gzip") - #:gcrypt (assoc-ref %build-inputs "gcrypt")))) + ;; XXX: This is not perfect, enabling VERBOSE? means + ;; building a different derivation. + #:debug-port (if #$verbose? + (current-error-port) + (%make-void-port "w")) + #:tar #$tar + #:gzip #$gzip + #:gcrypt #$libgcrypt))) - (build-expression->derivation store "guix-latest" builder - #:inputs - `(("tar" ,(package-derivation store tar)) - ("gzip" ,(package-derivation store gzip)) - ("gcrypt" ,(package-derivation store - libgcrypt)) - ("tarball" ,tarball)) - #:modules '((guix build pull) - (guix build utils)))) + (gexp->derivation "guix-latest" builder + #:modules '((guix build pull) + (guix build utils)))) ;;; @@ -114,6 +109,33 @@ Download and deploy the latest version of Guix.\n")) (lambda args (show-version-and-exit "guix pull"))))) +(define what-to-build + (store-lift show-what-to-build)) +(define indirect-root-added + (store-lift add-indirect-root)) + +(define* (build-and-install tarball config-dir + #:key verbose?) + "Build the tool from TARBALL, and install it in CONFIG-DIR." + (mlet* %store-monad ((source (unpack tarball #:verbose? verbose?)) + (source-dir -> (derivation->output-path source)) + (to-do? (what-to-build (list source)))) + (if to-do? + (mlet* %store-monad ((built? (built-derivations (list source)))) + (if built? + (mlet* %store-monad + ((latest -> (string-append config-dir "/latest")) + (done (indirect-root-added latest))) + (switch-symlinks latest source-dir) + (format #t + (_ "updated ~a successfully deployed under `~a'~%") + %guix-package-name latest) + (return #t)) + (leave (_ "failed to update Guix, check the build log~%")))) + (begin + (display (_ "Guix already up to date\n")) + (return #t))))) + (define (guix-pull . args) (define (parse-options) ;; Return the alist of option values. @@ -136,20 +158,6 @@ Download and deploy the latest version of Guix.\n")) (if (assoc-ref opts 'bootstrap?) %bootstrap-guile (canonical-package guile-2.0))))) - (let* ((config-dir (config-directory)) - (source (unpack store tarball - #:verbose? (assoc-ref opts 'verbose?))) - (source-dir (derivation->output-path source))) - (if (show-what-to-build store (list source)) - (if (build-derivations store (list source)) - (let ((latest (string-append config-dir "/latest"))) - (add-indirect-root store latest) - (switch-symlinks latest source-dir) - (format #t - (_ "updated ~a successfully deployed under `~a'~%") - %guix-package-name latest) - #t) - (leave (_ "failed to update Guix, check the build log~%"))) - (begin - (display (_ "Guix already up to date\n")) - #t)))))))) + (run-with-store store + (build-and-install tarball (config-directory) + #:verbose? (assoc-ref opts 'verbose?)))))))) diff --git a/guix/ui.scm b/guix/ui.scm index f11c2e9c92..531d922ad9 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -25,6 +25,7 @@ #:use-module (guix packages) #:use-module (guix build-system) #:use-module (guix derivations) + #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix licenses) #:select (license? license-name)) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) @@ -370,15 +371,13 @@ exists. Honor the XDG specs, (cut string-append <> "/guix")))) (catch 'system-error (lambda () - (mkdir dir) + (mkdir-p dir) dir) (lambda args - (match (system-error-errno args) - ((or EEXIST 0) - dir) - (err - (leave (_ "failed to create configuration directory `~a': ~a~%") - dir (strerror err)))))))) + (let ((err (system-error-errno args))) + ;; ERR is necessarily different from EEXIST. + (leave (_ "failed to create configuration directory `~a': ~a~%") + dir (strerror err))))))) (define* (fill-paragraph str width #:optional (column 0)) "Fill STR such that each line contains at most WIDTH characters, assuming diff --git a/guix/utils.scm b/guix/utils.scm index b61ff2477d..34a5e6c971 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -600,8 +600,9 @@ REPLACEMENT." "Call PROC with a name of a temporary file and open output port to that file; close the file and delete it when leaving the dynamic extent of this call." - (let* ((template (string-copy "guix-file.XXXXXX")) - (out (mkstemp! template))) + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/guix-file.XXXXXX")) + (out (mkstemp! template))) (dynamic-wind (lambda () #t) |