Merge branch 'master' into core-updates

15 files changed, 899 insertions, 60 deletions

diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index cbdb363b4e..ae18a16e11 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -95,7 +95,9 @@
 
   ;; Other useful nodes.
   (mknod (scope "dev/null") 'char-special #o666 (device-number 1 3))
-  (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5)))
+  (mknod (scope "dev/zero") 'char-special #o666 (device-number 1 5))
+  (chmod (scope "dev/null") #o666)
+  (chmod (scope "dev/zero") #o666))
 
 (define %host-qemu-ipv4-address
   (inet-pton AF_INET "10.0.2.10"))
diff --git a/guix/config.scm.in b/guix/config.scm.in
index 3a5c50e00a..5edb4ced30 100644
--- a/guix/config.scm.in
+++ b/guix/config.scm.in
@@ -24,6 +24,7 @@
             %store-directory
             %state-directory
             %config-directory
+            %guix-register-program
             %system
             %libgcrypt
             %nixpkgs
@@ -62,6 +63,10 @@
   ;; This must match `NIX_CONF_DIR' as defined in `daemon.am'.
   (or (getenv "NIX_CONF_DIR") "@guix_sysconfdir@/guix"))
 
+(define %guix-register-program
+  ;; The 'guix-register' program.
+  (or (getenv "GUIX_REGISTER") "@guix_sbindir@/guix-register"))
+
 (define %system
   "@guix_system@")
 
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 3d9f0affbf..cc8e37c973 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -532,7 +532,8 @@ the derivation called NAME with hash HASH."
                      (system (%current-system)) (env-vars '())
                      (inputs '()) (outputs '("out"))
                      hash hash-algo hash-mode
-                     references-graphs)
+                     references-graphs
+                     local-build?)
   "Build a derivation with the given arguments, and return the resulting
 <derivation> object.  When HASH, HASH-ALGO, and HASH-MODE are given, a
 fixed-output derivation is created---i.e., one whose result is known in
@@ -540,7 +541,11 @@ advance, such as a file download.
 
 When REFERENCES-GRAPHS is true, it must be a list of file name/store path
 pairs.  In that case, the reference graph of each store path is exported in
-the build environment in the corresponding file, in a simple text format."
+the build environment in the corresponding file, in a simple text format.
+
+When LOCAL-BUILD? is true, declare that the derivation is not a good candidate
+for offloading and should rather be built locally.  This is the case for small
+derivations where the costs of data transfers would outweigh the benefits."
   (define (add-output-paths drv)
     ;; Return DRV with an actual store path for each of its output and the
     ;; corresponding environment variable.
@@ -571,16 +576,20 @@ the build environment in the corresponding file, in a simple text format."
     ;; Some options are passed to the build daemon via the env. vars of
     ;; derivations (urgh!).  We hide that from our API, but here is the place
     ;; where we kludgify those options.
-    (match references-graphs
-      (((file . path) ...)
-       (let ((value (map (cut string-append <> " " <>)
-                         file path)))
-         ;; XXX: This all breaks down if an element of FILE or PATH contains
-         ;; white space.
-         `(("exportReferencesGraph" . ,(string-join value " "))
-           ,@env-vars)))
-      (#f
-       env-vars)))
+    (let ((env-vars (if local-build?
+                        `(("preferLocalBuild" . "1")
+                          ,@env-vars)
+                        env-vars)))
+      (match references-graphs
+        (((file . path) ...)
+         (let ((value (map (cut string-append <> " " <>)
+                           file path)))
+           ;; XXX: This all breaks down if an element of FILE or PATH contains
+           ;; white space.
+           `(("exportReferencesGraph" . ,(string-join value " "))
+             ,@env-vars)))
+        (#f
+         env-vars))))
 
   (define (env-vars-with-empty-outputs env-vars)
     ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
@@ -904,7 +913,8 @@ they can refer to each other."
                                        (env-vars '())
                                        (modules '())
                                        guile-for-build
-                                       references-graphs)
+                                       references-graphs
+                                       local-build?)
   "Return a derivation that executes Scheme expression EXP as a builder
 for derivation NAME.  INPUTS must be a list of (NAME DRV-PATH SUB-DRV)
 tuples; when SUB-DRV is omitted, \"out\" is assumed.  MODULES is a list
@@ -923,7 +933,8 @@ EXP returns #f, the build is considered to have failed.
 EXP is built using GUILE-FOR-BUILD (a derivation).  When GUILE-FOR-BUILD is
 omitted or is #f, the value of the `%guile-for-build' fluid is used instead.
 
-See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
+See the `derivation' procedure for the meaning of REFERENCES-GRAPHS and
+LOCAL-BUILD?."
   (define guile-drv
     (or guile-for-build (%guile-for-build)))
 
@@ -1046,4 +1057,5 @@ See the `derivation' procedure for the meaning of REFERENCES-GRAPHS."
 
                 #:hash hash #:hash-algo hash-algo
                 #:outputs outputs
-                #:references-graphs references-graphs)))
+                #:references-graphs references-graphs
+                #:local-build? local-build?)))
diff --git a/guix/hash.scm b/guix/hash.scm
index 92ecaf78d5..fb85f47586 100644
--- a/guix/hash.scm
+++ b/guix/hash.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,7 +25,8 @@
   #:use-module (srfi srfi-11)
   #:export (sha256
             open-sha256-port
-            port-sha256))
+            port-sha256
+            open-sha256-input-port))
 
 ;;; Commentary:
 ;;;
@@ -128,4 +129,41 @@ output port."
     (close-port out)
     (get)))
 
+(define (open-sha256-input-port port)
+  "Return an input port that wraps PORT and a thunk to get the hash of all the
+data read from PORT.  The thunk always returns the same value."
+  (define md
+    (open-sha256-md))
+
+  (define (read! bv start count)
+    (let ((n (get-bytevector-n! port bv start count)))
+      (if (eof-object? n)
+          0
+          (begin
+            (unless digest
+              (let ((ptr (bytevector->pointer bv start)))
+                (md-write md ptr n)))
+            n))))
+
+  (define digest #f)
+
+  (define (finalize!)
+    (let ((ptr (md-read md 0)))
+      (set! digest (bytevector-copy (pointer->bytevector ptr 32)))
+      (md-close md)))
+
+  (define (get-hash)
+    (unless digest
+      (finalize!))
+    digest)
+
+  (define (unbuffered port)
+    ;; Guile <= 2.0.9 does not support 'setvbuf' on custom binary input ports.
+    ;; If you get a wrong-type-arg error here, the fix is to upgrade Guile.  :-)
+    (setvbuf port _IONBF)
+    port)
+
+  (values (unbuffered (make-custom-binary-input-port "sha256" read! #f #f #f))
+          get-hash))
+
 ;;; hash.scm ends here
diff --git a/guix/licenses.scm b/guix/licenses.scm
index c0a0e60b36..5f1b3c16cf 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
@@ -31,6 +31,7 @@
             expat
             freetype
             gpl1 gpl1+ gpl2 gpl2+ gpl3 gpl3+
+            fdl1.3+
             isc
             ijg
             ibmpl1.0
@@ -161,6 +162,11 @@ which may be a file:// URI pointing the package's tree."
            "https://www.gnu.org/licenses/gpl.html"
            "https://www.gnu.org/licenses/license-list#GNUGPLv3"))
 
+(define fdl1.3+
+  (license "FDL 1.3+"
+           "https://www.gnu.org/licenses/fdl.html"
+           "https://www.gnu.org/licenses/license-list#FDL"))
+
 (define isc
   (license "ISC"
            "http://directory.fsf.org/wiki/License:ISC"
diff --git a/guix/nar.scm b/guix/nar.scm
index ea119a25fe..4bc2deb229 100644
--- a/guix/nar.scm
+++ b/guix/nar.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -19,23 +19,40 @@
 (define-module (guix nar)
   #:use-module (guix utils)
   #:use-module (guix serialization)
-  #:use-module ((guix build utils) #:select (with-directory-excursion))
+  #:use-module ((guix build utils)
+                #:select (delete-file-recursively with-directory-excursion))
+  #:use-module (guix store)
+  #:use-module (guix ui)                          ; for '_'
+  #:use-module (guix hash)
+  #:use-module (guix pki)
+  #:use-module (guix pk-crypto)
   #:use-module (rnrs bytevectors)
   #:use-module (rnrs io ports)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:export (nar-error?
+            nar-error-port
+            nar-error-file
+
             nar-read-error?
-            nar-read-error-file
-            nar-read-error-port
             nar-read-error-token
 
+            nar-invalid-hash-error?
+            nar-invalid-hash-error-expected
+            nar-invalid-hash-error-actual
+
+            nar-signature-error?
+            nar-signature-error-signature
+
             write-file
-            restore-file))
+            restore-file
+
+            restore-file-set))
 
 ;;; Comment:
 ;;;
@@ -44,15 +61,24 @@
 ;;; Code:
 
 (define-condition-type &nar-error &error      ; XXX: inherit from &nix-error ?
-  nar-error?)
+  nar-error?
+  (file  nar-error-file)                       ; file we were restoring, or #f
+  (port  nar-error-port))                      ; port from which we read
 
 (define-condition-type &nar-read-error &nar-error
   nar-read-error?
-  (port  nar-read-error-port)                   ; port from which we read
-  (file  nar-read-error-file)                   ; file we were restoring, or #f
   (token nar-read-error-token))                 ; faulty token, or #f
 
+(define-condition-type &nar-signature-error &nar-error
+  nar-signature-error?
+  (signature nar-signature-error-signature))      ; faulty signature or #f
 
+(define-condition-type &nar-invalid-hash-error &nar-signature-error
+  nar-invalid-hash-error?
+  (expected  nar-invalid-hash-error-expected)     ; expected hash (a bytevector)
+  (actual    nar-invalid-hash-error-actual))      ; actual hash
+
+
 (define (dump in out size)
   "Copy SIZE bytes from IN to OUT."
   (define buf-size 65536)
@@ -239,4 +265,191 @@ Restore it as FILE."
          (&message (message "unsupported nar entry type"))
          (&nar-read-error (port port) (file file) (token x))))))))
 
+
+;;;
+;;; Restoring a file set into the store.
+;;;
+
+;; The code below accesses the store directly and is meant to be run from
+;; "build hooks", which cannot invoke the daemon's 'import-paths' RPC since
+;; (1) the locks on the files to be restored as already held, and (2) the
+;; $NIX_HELD_LOCKS hackish environment variable cannot be set.
+;;
+;; So we're really duplicating that functionality of the daemon (well, until
+;; most of the daemon is in Scheme :-)).  But note that we do use a couple of
+;; RPCs for functionality not available otherwise, like 'valid-path?'.
+
+(define (lock-store-file file)
+  "Acquire exclusive access to FILE, a store file."
+  (call-with-output-file (string-append file ".lock")
+    (cut fcntl-flock <> 'write-lock)))
+
+(define (unlock-store-file file)
+  "Release access to FILE."
+  (call-with-input-file (string-append file ".lock")
+    (cut fcntl-flock <> 'unlock)))
+
+(define* (finalize-store-file source target
+                              #:key (references '()) deriver (lock? #t))
+  "Rename SOURCE to TARGET and register TARGET as a valid store item, with
+REFERENCES and DERIVER.  When LOCK? is true, acquire exclusive locks on TARGET
+before attempting to register it; otherwise, assume TARGET's locks are already
+held."
+
+  ;; XXX: Currently we have to call out to the daemon to check whether TARGET
+  ;; is valid.
+  (with-store store
+    (unless (valid-path? store target)
+      (when lock?
+        (lock-store-file target))
+
+      (unless (valid-path? store target)
+        ;; If FILE already exists, delete it (it's invalid anyway.)
+        (when (file-exists? target)
+          (delete-file-recursively target))
+
+        ;; Install the new TARGET.
+        (rename-file source target)
+
+        ;; Register TARGET.  As a side effect, it resets the timestamps of all
+        ;; its files, recursively.  However, it doesn't attempt to deduplicate
+        ;; its files like 'importPaths' does (FIXME).
+        (register-path target
+                       #:references references
+                       #:deriver deriver))
+
+      (when lock?
+        (unlock-store-file target)))))
+
+(define (temporary-store-directory)
+  "Return the file name of a temporary directory created in the store that is
+protected from garbage collection."
+  (let* ((template (string-append (%store-prefix) "/guix-XXXXXX"))
+         (port     (mkstemp! template)))
+    (close-port port)
+    (with-store store
+      (add-temp-root store template))
+
+    ;; There's a small window during which the GC could delete the file.  Try
+    ;; again if that happens.
+    (if (file-exists? template)
+        (begin
+          ;; It's up to the caller to create that file or directory.
+          (delete-file template)
+          template)
+        (temporary-store-directory))))
+
+(define* (restore-file-set port
+                           #:key (verify-signature? #t) (lock? #t)
+                           (log-port (current-error-port)))
+  "Restore the file set read from PORT to the store.  The format of the data
+on PORT must be as created by 'export-paths'---i.e., a series of Nar-formatted
+archives with interspersed meta-data joining them together, possibly with a
+digital signature at the end.  Log progress to LOG-PORT.  Return the list of
+files restored.
+
+When LOCK? is #f, assume locks for the files to be restored are already held.
+This is the case when the daemon calls a build hook.
+
+Note that this procedure accesses the store directly, so it's only meant to be
+used by the daemon's build hooks since they cannot call back to the daemon
+while the locks are held."
+  (define %export-magic
+    ;; Number used to identify genuine file set archives.
+    #x4558494e)
+
+  (define port*
+    ;; Keep that one around, for error conditions.
+    port)
+
+  (define (assert-valid-signature signature hash file)
+    ;; Bail out if SIGNATURE, an sexp, doesn't match HASH, a bytevector
+    ;; containing the expected hash for FILE.
+    (let* ((signature (catch 'gcry-error
+                        (lambda ()
+                          (string->canonical-sexp signature))
+                        (lambda (err . _)
+                          (raise (condition
+                                  (&message
+                                   (message "signature is not a valid \
+s-expression"))
+                                  (&nar-signature-error
+                                   (file file)
+                                   (signature signature) (port port)))))))
+           (subject   (signature-subject signature))
+           (data      (signature-signed-data signature)))
+      (if (and data subject)
+          (if (authorized-key? subject)
+              (if (equal? (hash-data->bytevector data) hash)
+                  (unless (valid-signature? signature)
+                    (raise (condition
+                            (&message (message "invalid signature"))
+                            (&nar-signature-error
+                             (file file) (signature signature) (port port)))))
+                  (raise (condition (&message (message "invalid hash"))
+                                    (&nar-invalid-hash-error
+                                     (port port) (file file)
+                                     (signature signature)
+                                     (expected (hash-data->bytevector data))
+                                     (actual hash)))))
+              (raise (condition (&message (message "unauthorized public key"))
+                                (&nar-signature-error
+                                 (signature signature) (file file) (port port)))))
+          (raise (condition
+                  (&message (message "corrupt signature data"))
+                  (&nar-signature-error
+                   (signature signature) (file file) (port port)))))))
+
+  (let loop ((n     (read-long-long port))
+             (files '()))
+    (case n
+      ((0)
+       (reverse files))
+      ((1)
+       (let-values (((port get-hash)
+                     (open-sha256-input-port port)))
+         (let ((temp (temporary-store-directory)))
+           (restore-file port temp)
+           (let ((magic (read-int port)))
+             (unless (= magic %export-magic)
+               (raise (condition
+                       (&message (message "corrupt file set archive"))
+                       (&nar-read-error
+                        (port port*) (file #f) (token #f))))))
+
+           (let ((file     (read-store-path port))
+                 (refs     (read-store-path-list port))
+                 (deriver  (read-string port))
+                 (hash     (get-hash))
+                 (has-sig? (= 1 (read-int port))))
+             (format log-port
+                     (_ "importing file or directory '~a'...~%")
+                     file)
+
+             (let ((sig (and has-sig? (read-string port))))
+               (when verify-signature?
+                 (if sig
+                     (begin
+                       (assert-valid-signature sig hash file)
+                       (format log-port
+                               (_ "found valid signature for '~a'~%")
+                               file)
+                       (finalize-store-file temp file
+                                            #:references refs
+                                            #:deriver deriver
+                                            #:lock? lock?)
+                       (loop (read-long-long port)
+                             (cons file files)))
+                     (raise (condition
+                             (&message (message "imported file lacks \
+a signature"))
+                             (&nar-signature-error
+                              (port port*) (file file) (signature #f)))))))))))
+      (else
+       ;; Neither 0 nor 1.
+       (raise (condition
+               (&message (message "invalid inter-file archive mark"))
+               (&nar-read-error
+                (port port) (file #f) (token #f))))))))
+
 ;;; nar.scm ends here
diff --git a/guix/pki.scm b/guix/pki.scm
index 5e4dbadd35..4b90b65a13 100644
--- a/guix/pki.scm
+++ b/guix/pki.scm
@@ -29,8 +29,12 @@
             current-acl
             public-keys->acl
             acl->public-keys
+            authorized-key?
+
             signature-sexp
-            authorized-key?))
+            signature-subject
+            signature-signed-data
+            valid-signature?))
 
 ;;; Commentary:
 ;;;
@@ -136,4 +140,21 @@ PUBLIC-KEY (see <http://theworld.com/~cme/spki.txt> for examples.)"
            (canonical-sexp->string (sign data secret-key))
            (canonical-sexp->string public-key))))
 
+(define (signature-subject sig)
+  "Return the signer's public key for SIG."
+  (find-sexp-token sig 'public-key))
+
+(define (signature-signed-data sig)
+  "Return the signed data from SIG, typically an sexp such as
+  (hash \"sha256\" #...#)."
+  (find-sexp-token sig 'data))
+
+(define (valid-signature? sig)
+  "Return #t if SIG is valid."
+  (let* ((data       (signature-signed-data sig))
+         (signature  (find-sexp-token sig 'sig-val))
+         (public-key (signature-subject sig)))
+    (and data signature
+         (verify signature data public-key))))
+
 ;;; pki.scm ends here
diff --git a/guix/profiles.scm b/guix/profiles.scm
index 9b5c5f515c..1ff6c97f9f 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -238,8 +238,6 @@ the given MANIFEST."
 
        (let ((output (assoc-ref %outputs "out"))
              (inputs (map cdr %build-inputs)))
-         (format #t "building profile '~a' with ~a packages...~%"
-                 output (length inputs))
          (union-build output inputs
                       #:log-port (%make-void-port "w"))
          (call-with-output-file (string-append output "/manifest")
diff --git a/guix/scripts/authenticate.scm b/guix/scripts/authenticate.scm
index c7a14f7a8b..27580dedff 100644
--- a/guix/scripts/authenticate.scm
+++ b/guix/scripts/authenticate.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -72,23 +72,21 @@
      ;; Read the signature as produced above, check whether its public key is
      ;; authorized, and verify the signature, and print the signed data to
      ;; stdout upon success.
-     (let* ((sig+data   (read-canonical-sexp signature-file))
-            (public-key (find-sexp-token sig+data 'public-key))
-            (data       (find-sexp-token sig+data 'data))
-            (signature  (find-sexp-token sig+data 'sig-val)))
-       (if (and data signature)
-           (if (authorized-key? public-key)
-               (if (verify signature data public-key)
-                   (begin
-                     (display (bytevector->base16-string
-                               (hash-data->bytevector data)))
+     (let* ((signature (read-canonical-sexp signature-file))
+            (subject   (signature-subject signature))
+            (data      (signature-signed-data signature)))
+       (if (and data subject)
+           (if (authorized-key? subject)
+               (if (valid-signature? signature)
+                   (let ((hash (hash-data->bytevector data)))
+                     (display (bytevector->base16-string hash))
                      #t)                          ; success
                    (leave (_ "error: invalid signature: ~a~%")
                           (canonical-sexp->string signature)))
                (leave (_ "error: unauthorized public key: ~a~%")
-                      (canonical-sexp->string public-key)))
+                      (canonical-sexp->string subject)))
            (leave (_ "error: corrupt signature data: ~a~%")
-                  (canonical-sexp->string sig+data)))))
+                  (canonical-sexp->string signature)))))
     (("--help")
      (display (_ "Usage: guix authenticate OPTION...
 Sign or verify the signature on the given file.  This tool is meant to
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
new file mode 100644
index 0000000000..d919ede3c7
--- /dev/null
+++ b/guix/scripts/offload.scm
@@ -0,0 +1,380 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix scripts offload)
+  #:use-module (guix config)
+  #:use-module (guix records)
+  #:use-module (guix store)
+  #:use-module (guix derivations)
+  #:use-module (guix nar)
+  #:use-module (guix utils)
+  #:use-module ((guix build utils) #:select (which))
+  #:use-module (guix ui)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 format)
+  #:use-module (rnrs io ports)
+  #:export (build-machine
+            build-requirements
+            guix-offload))
+
+;;; Commentary:
+;;;
+;;; Attempt to offload builds to the machines listed in
+;;; /etc/guix/machines.scm, transferring missing dependencies over SSH, and
+;;; retrieving the build output(s) over SSH upon success.
+;;;
+;;; This command should not be used directly; instead, it is called on-demand
+;;; by the daemon, unless it was started with '--no-build-hook' or a client
+;;; inhibited build hooks.
+;;;
+;;; Code:
+
+
+(define-record-type* <build-machine>
+  build-machine make-build-machine
+  build-machine?
+  (name            build-machine-name)            ; string
+  (system          build-machine-system)          ; string
+  (user            build-machine-user)            ; string
+  (private-key     build-machine-private-key      ; file name
+                   (default (user-lsh-private-key)))
+  (parallel-builds build-machine-parallel-builds  ; number
+                   (default 1))
+  (speed           build-machine-speed            ; inexact real
+                   (default 1.0))
+  (features        build-machine-features         ; list of strings
+                   (default '())))
+
+(define-record-type* <build-requirements>
+  build-requirements make-build-requirements
+  build-requirements?
+  (system          build-requirements-system)     ; string
+  (features        build-requirements-features    ; list of strings
+                   (default '())))
+
+(define %machine-file
+  ;; File that lists machines available as build slaves.
+  (string-append %config-directory "/machines.scm"))
+
+(define %lsh-command
+  "lsh")
+
+(define %lshg-command
+  ;; FIXME: 'lshg' fails to pass large amounts of data, see
+  ;; <http://lists.lysator.liu.se/pipermail/lsh-bugs/2014q1/000639.html>.
+  "lsh")
+
+(define (user-lsh-private-key)
+  "Return the user's default lsh private key, or #f if it could not be
+determined."
+  (and=> (getenv "HOME")
+         (cut string-append <> "/.lsh/identity")))
+
+(define %user-module
+  ;; Module in which the machine description file is loaded.
+  (let ((module (make-fresh-user-module)))
+    (module-use! module (resolve-interface '(guix scripts offload)))
+    module))
+
+(define* (build-machines #:optional (file %machine-file))
+  "Read the list of build machines from FILE and return it."
+  (catch #t
+    (lambda ()
+      ;; Avoid ABI incompatibility with the <build-machine> record.
+      (set! %fresh-auto-compile #t)
+
+      (save-module-excursion
+       (lambda ()
+         (set-current-module %user-module)
+         (primitive-load %machine-file))))
+    (lambda args
+      (match args
+        (('system-error . _)
+         (let ((err (system-error-errno args)))
+           ;; Silently ignore missing file since this is a common case.
+           (if (= ENOENT err)
+               '()
+               (leave (_ "failed to open machine file '~a': ~a~%")
+                      %machine-file (strerror err)))))
+        (_
+         (leave (_ "failed to load machine file '~a': ~s~%")
+                %machine-file args))))))
+
+(define (open-ssh-gateway machine)
+  "Initiate an SSH connection gateway to MACHINE, and return the PID of the
+running lsh gateway upon success, or #f on failure."
+  (catch 'system-error
+    (lambda ()
+      (let* ((port   (open-pipe* OPEN_READ %lsh-command
+                                 "-l" (build-machine-user machine)
+                                 "-i" (build-machine-private-key machine)
+                                 ;; XXX: With lsh 2.1, passing '--write-pid'
+                                 ;; last causes the PID not to be printed.
+                                 "--write-pid" "--gateway" "--background" "-z"
+                                 (build-machine-name machine)))
+             (line   (read-line port))
+             (status (close-pipe port)))
+       (if (zero? status)
+           (let ((pid (string->number line)))
+             (if (integer? pid)
+                 pid
+                 (begin
+                   (warning (_ "'~a' did not write its PID on stdout: ~s~%")
+                            %lsh-command line)
+                   #f)))
+           (begin
+             (warning (_ "failed to initiate SSH connection to '~a':\
+ '~a' exited with ~a~%")
+                      (build-machine-name machine)
+                      %lsh-command
+                      (status:exit-val status))
+             #f))))
+    (lambda args
+      (leave (_ "failed to execute '~a': ~a~%")
+             %lsh-command (strerror (system-error-errno args))))))
+
+(define (remote-pipe machine mode command)
+  "Run COMMAND on MACHINE, assuming an lsh gateway has been set up."
+  (catch 'system-error
+    (lambda ()
+      (apply open-pipe* mode %lshg-command
+             "-l" (build-machine-user machine) "-z"
+             (build-machine-name machine)
+             command))
+    (lambda args
+      (warning (_ "failed to execute '~a': ~a~%")
+               %lshg-command (strerror (system-error-errno args)))
+      #f)))
+
+(define* (offload drv machine
+                  #:key print-build-trace? (max-silent-time 3600)
+                  (build-timeout 7200))
+  "Perform DRV on MACHINE, assuming DRV and its prerequisites are available
+there.  Return a read pipe from where to read the build log."
+  (format (current-error-port) "offloading '~a' to '~a'...~%"
+          (derivation-file-name drv) (build-machine-name machine))
+  (format (current-error-port) "@ build-remote ~a ~a~%"
+          (derivation-file-name drv) (build-machine-name machine))
+
+  ;; FIXME: Protect DRV from garbage collection on MACHINE.
+  (let ((pipe (remote-pipe machine OPEN_READ
+                           `("guix" "build"
+                             ;; FIXME: more options
+                             ,(format #f "--max-silent-time=~a"
+                                      max-silent-time)
+                             ,(derivation-file-name drv)))))
+    pipe))
+
+(define (send-files files machine)
+  "Send the subset of FILES that's missing to MACHINE's store.  Return #t on
+success, #f otherwise."
+  (define (missing-files files)
+    ;; Return the subset of FILES not already on MACHINE.
+    (let* ((files   (format #f "~{~a~%~}" files))
+           (missing (filtered-port
+                     (list (which %lshg-command)
+                           "-l" (build-machine-user machine)
+                           "-i" (build-machine-private-key machine)
+                           (build-machine-name machine)
+                           "guix" "archive" "--missing")
+                     (open-input-string files))))
+      (string-tokenize (get-string-all missing))))
+
+  (with-store store
+    (guard (c ((nix-protocol-error? c)
+               (warning (_ "failed to export files for '~a': ~s~%")
+                        (build-machine-name machine)
+                        c)
+               (false-if-exception (close-pipe pipe))
+               #f))
+
+      ;; Compute the subset of FILES missing on MACHINE, and send them in
+      ;; topologically sorted order so that they can actually be imported.
+      (let ((files (missing-files (topologically-sorted store files)))
+            (pipe  (remote-pipe machine OPEN_WRITE
+                                '("guix" "archive" "--import"))))
+        (format #t (_ "sending ~a store files to '~a'...~%")
+                (length files) (build-machine-name machine))
+        (catch 'system-error
+          (lambda ()
+            (export-paths store files pipe))
+          (lambda args
+            (warning (_ "failed while exporting files to '~a': ~a~%")
+                     (build-machine-name machine)
+                     (strerror (system-error-errno args)))))
+        (zero? (close-pipe pipe))))))
+
+(define (retrieve-files files machine)
+  "Retrieve FILES from MACHINE's store, and import them."
+  (define host
+    (build-machine-name machine))
+
+  (let ((pipe (remote-pipe machine OPEN_READ
+                           `("guix" "archive" "--export" ,@files))))
+    (and pipe
+         (with-store store
+           (guard (c ((nix-protocol-error? c)
+                      (warning (_ "failed to import files from '~a': ~s~%")
+                               host c)
+                      #f))
+             (format (current-error-port) "retrieving ~a files from '~a'...~%"
+                     (length files) host)
+
+             ;; We cannot use the 'import-paths' RPC here because we already
+             ;; hold the locks for FILES.
+             (restore-file-set pipe
+                               #:log-port (current-error-port)
+                               #:lock? #f)
+
+             (zero? (close-pipe pipe)))))))
+
+(define (machine-matches? machine requirements)
+  "Return #t if MACHINE matches REQUIREMENTS."
+  (and (string=? (build-requirements-system requirements)
+                 (build-machine-system machine))
+       (lset<= string=?
+               (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 (choose-build-machine requirements machines)
+  "Return the best machine among MACHINES fulfilling REQUIREMENTS, or #f."
+  ;; FIXME: Take machine load into account, and/or shuffle MACHINES.
+  (let ((machines (sort (filter (cut machine-matches? <> requirements)
+                                machines)
+                        machine-faster?)))
+    (match machines
+      ((head . _)
+       head)
+      (_ #f))))
+
+(define* (process-request wants-local? system drv features
+                          #:key
+                          print-build-trace? (max-silent-time 3600)
+                          (build-timeout 7200))
+  "Process a request to build DRV."
+  (let* ((local?  (and wants-local? (string=? system (%current-system))))
+         (reqs    (build-requirements
+                   (system system)
+                   (features features)))
+         (machine (choose-build-machine reqs (build-machines))))
+    (if machine
+        (match (open-ssh-gateway machine)
+          ((? integer? pid)
+           (display "# accept\n")
+           (let ((inputs  (string-tokenize (read-line)))
+                 (outputs (string-tokenize (read-line))))
+             (when (send-files (cons (derivation-file-name drv) inputs)
+                               machine)
+               (let ((log (offload drv machine
+                                   #:print-build-trace? print-build-trace?
+                                   #:max-silent-time max-silent-time
+                                   #:build-timeout build-timeout)))
+                 (let loop ((line (read-line log)))
+                   (if (eof-object? line)
+                       (close-pipe log)
+                       (begin
+                         (display line) (newline)
+                         (loop (read-line log))))))
+               (retrieve-files outputs machine)))
+           (format (current-error-port) "done with offloaded '~a'~%"
+                   (derivation-file-name drv))
+           (kill pid SIGTERM))
+          (#f
+           (display "# decline\n")))
+        (display "# decline\n"))))
+
+(define-syntax-rule (with-nar-error-handling body ...)
+  "Execute BODY with any &nar-error suitably reported to the user."
+  (guard (c ((nar-error? c)
+             (let ((file (nar-error-file c)))
+               (if (condition-has-type? c &message)
+                   (leave (_ "while importing file '~a': ~a~%")
+                          file (gettext (condition-message c)))
+                   (leave (_ "failed to import file '~a'~%")
+                          file)))))
+    body ...))
+
+
+;;;
+;;; Entry point.
+;;;
+
+(define (guix-offload . args)
+  (define request-line-rx
+    ;; The request format.  See 'tryBuildHook' method in build.cc.
+    (make-regexp "([01]) ([a-z0-9_-]+) (/[[:graph:]]+.drv) ([[:graph:]]*)"))
+
+  (define not-coma
+    (char-set-complement (char-set #\,)))
+
+  ;; Make sure $HOME really corresponds to the current user.  This is
+  ;; necessary since lsh uses that to determine the location of the yarrow
+  ;; seed file, and fails if it's owned by someone else.
+  (and=> (passwd:dir (getpw (getuid)))
+         (cut setenv "HOME" <>))
+
+  (match args
+    ((system max-silent-time print-build-trace? build-timeout)
+     (let ((max-silent-time    (string->number max-silent-time))
+           (build-timeout      (string->number build-timeout))
+           (print-build-trace? (string=? print-build-trace? "1")))
+       (parameterize ((%current-system system))
+         (let loop ((line (read-line)))
+           (unless (eof-object? line)
+             (cond ((regexp-exec request-line-rx line)
+                    =>
+                    (lambda (match)
+                      (with-nar-error-handling
+                       (process-request (equal? (match:substring match 1) "1")
+                                        (match:substring match 2) ; system
+                                        (call-with-input-file
+                                            (match:substring match 3)
+                                          read-derivation)
+                                        (string-tokenize
+                                         (match:substring match 4) not-coma)
+                                        #:print-build-trace? print-build-trace?
+                                        #:max-silent-time max-silent-time
+                                        #:build-timeout build-timeout))))
+                   (else
+                    (leave (_ "invalid request line: ~s~%") line)))
+             (loop (read-line)))))))
+    (("--version")
+     (show-version-and-exit "guix offload"))
+    (("--help")
+     (format #t (_ "Usage: guix offload SYSTEM PRINT-BUILD-TRACE
+Process build offload requests written on the standard input, possibly
+offloading builds to the machines listed in '~a'.~%")
+             %machine-file)
+     (display (_ "
+This tool is meant to be used internally by 'guix-daemon'.\n"))
+     (show-bug-report-information))
+    (x
+     (leave (_ "invalid arguments: ~{~s ~}~%") x))))
+
+;;; offload.scm ends here
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 04393abc9a..d41a83de8a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -1032,8 +1032,9 @@ more information.~%"))
 
         (('search regexp)
          (let ((regexp (make-regexp regexp regexp/icase)))
-           (for-each (cute package->recutils <> (current-output-port))
-                     (find-packages-by-description regexp))
+           (leave-on-EPIPE
+            (for-each (cute package->recutils <> (current-output-port))
+                      (find-packages-by-description regexp)))
            #t))
 
         (('search-paths)
diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm
index 901b3fb064..3aaa1c4284 100755
--- a/guix/scripts/substitute-binary.scm
+++ b/guix/scripts/substitute-binary.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -486,6 +486,29 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
   "Implement the build daemon's substituter protocol."
   (mkdir-p %narinfo-cache-directory)
   (maybe-remove-expired-cached-narinfo)
+
+  ;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
+  ;; when we know we cannot substitute, but we must emit a newline on stdout
+  ;; when everything is alright.
+  (let ((uri (string->uri %cache-url)))
+    (case (uri-scheme uri)
+      ((http)
+       ;; Exit gracefully if there's no network access.
+       (let ((host (uri-host uri)))
+         (catch 'getaddrinfo-error
+           (lambda ()
+             (getaddrinfo host))
+           (lambda (key error)
+             (warning (_ "failed to look up host '~a' (~a), \
+substituter disabled~%")
+                      host (gai-strerror error))
+             (exit 0)))))
+      (else #t)))
+
+  ;; Say hello (see above.)
+  (newline)
+  (force-output (current-output-port))
+
   (with-networking
    (match args
      (("--query")
diff --git a/guix/store.scm b/guix/store.scm
index 1012480b39..eca0de7d97 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -33,6 +33,7 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 vlist)
+  #:use-module (ice-9 popen)
   #:export (%daemon-socket-file
 
             nix-server?
@@ -52,6 +53,7 @@
 
             open-connection
             close-connection
+            with-store
             set-build-options
             valid-path?
             query-path-hash
@@ -74,6 +76,7 @@
             references
             requisites
             referrers
+            topologically-sorted
             valid-derivers
             query-derivation-outputs
             live-paths
@@ -85,6 +88,8 @@
 
             current-build-output-port
 
+            register-path
+
             %store-prefix
             store-path?
             direct-store-path?
@@ -320,6 +325,17 @@ operate, should the disk become full.  Return a server object."
   "Close the connection to SERVER."
   (close (nix-server-socket server)))
 
+(define-syntax-rule (with-store store exp ...)
+  "Bind STORE to an open connection to the store and evaluate EXPs;
+automatically close the store when the dynamic extent of EXP is left."
+  (let ((store (open-connection)))
+    (dynamic-wind
+      (const #f)
+      (lambda ()
+        exp ...)
+      (lambda ()
+        (false-if-exception (close-connection store))))))
+
 (define current-build-output-port
   ;; The port where build output is sent.
   (make-parameter (current-error-port)))
@@ -360,11 +376,11 @@ encoding conversion errors."
     (nix-server-socket server))
 
   ;; magic cookies from worker-protocol.hh
-  (define %stderr-next  #x6f6c6d67)
-  (define %stderr-read  #x64617461)               ; data needed from source
-  (define %stderr-write #x64617416)               ; data for sink
-  (define %stderr-last  #x616c7473)
-  (define %stderr-error #x63787470)
+  (define %stderr-next  #x6f6c6d67)          ; "olmg", build log
+  (define %stderr-read  #x64617461)          ; "data", data needed from source
+  (define %stderr-write #x64617416)          ; "dat\x16", data for sink
+  (define %stderr-last  #x616c7473)          ; "alts", we're done
+  (define %stderr-error #x63787470)          ; "cxtp", error reporting
 
   (let ((k (read-int p)))
     (cond ((= k %stderr-write)
@@ -574,6 +590,40 @@ SEED."
 references, recursively)."
   (fold-path store cons '() path))
 
+(define (topologically-sorted store paths)
+  "Return a list containing PATHS and all their references sorted in
+topological order."
+  (define (traverse)
+    ;; Do a simple depth-first traversal of all of PATHS.
+    (let loop ((paths   paths)
+               (visited vlist-null)
+               (result  '()))
+      (define (visit n)
+        (vhash-cons n #t visited))
+
+      (define (visited? n)
+        (vhash-assoc n visited))
+
+      (match paths
+        ((head tail ...)
+         (if (visited? head)
+             (loop tail visited result)
+             (call-with-values
+                 (lambda ()
+                   (loop (references store head)
+                         (visit head)
+                         result))
+               (lambda (visited result)
+                 (loop tail
+                       visited
+                       (cons head result))))))
+        (()
+         (values visited result)))))
+
+  (call-with-values traverse
+    (lambda (_ result)
+      (reverse result))))
+
 (define referrers
   (operation (query-referrers (store-path path))
              "Return the list of path that refer to PATH."
@@ -694,6 +744,28 @@ is true."
          (and (export-path server head port #:sign? sign?)
               (loop tail)))))))
 
+(define* (register-path path
+                        #:key (references '()) deriver)
+  "Register PATH as a valid store file, with REFERENCES as its list of
+references, and DERIVER as its deriver (.drv that led to it.)  Return #t on
+success.
+
+Use with care as it directly modifies the store!  This is primarily meant to
+be used internally by the daemon's build hook."
+  ;; Currently this is implemented by calling out to the fine C++ blob.
+  (catch 'system-error
+    (lambda ()
+      (let ((pipe (open-pipe* OPEN_WRITE %guix-register-program)))
+        (and pipe
+             (begin
+               (format pipe "~a~%~a~%~a~%"
+                       path (or deriver "") (length references))
+               (for-each (cut format pipe "~a~%" <>) references)
+               (zero? (close-pipe pipe))))))
+    (lambda args
+      ;; Failed to run %GUIX-REGISTER-PROGRAM.
+      #f)))
+
 
 ;;;
 ;;; Store paths.
diff --git a/guix/ui.scm b/guix/ui.scm
index f15419f7a8..d6058f806b 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;;
@@ -138,7 +138,7 @@ messages."
   "Display version information for COMMAND and `(exit 0)'."
   (simple-format #t "~a (~a) ~a~%"
                  command %guix-package-name %guix-version)
-  (display (_ "Copyright (C) 2013 the Guix authors
+  (display (_ "Copyright (C) 2014 the Guix authors
 License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
 This is free software: you are free to change and redistribute it.
 There is NO WARRANTY, to the extent permitted by law.
@@ -404,7 +404,11 @@ WIDTH columns."
   (format port "location: ~a~%"
           (or (and=> (package-location p) location->string)
               (_ "unknown")))
-  (format port "home-page: ~a~%" (package-home-page p))
+
+  ;; Note: Starting from version 1.6 or recutils, hyphens are not allowed in
+  ;; field identifiers.
+  (format port "homepage: ~a~%" (package-home-page p))
+
   (format port "license: ~a~%"
           (match (package-license p)
             (((? license? licenses) ...)
@@ -554,13 +558,17 @@ reporting."
        (command-files)))
 
 (define (show-guix-help)
+  (define (internal? command)
+    (member command '("substitute-binary" "authenticate" "offload")))
+
   (format #t (_ "Usage: guix COMMAND ARGS...
 Run COMMAND with ARGS.\n"))
   (newline)
   (format #t (_ "COMMAND must be one of the sub-commands listed below:\n"))
   (newline)
   ;; TODO: Display a synopsis of each command.
-  (format #t "~{   ~a~%~}" (sort (commands) string<?))
+  (format #t "~{   ~a~%~}" (sort (remove internal? (commands))
+                                 string<?))
   (show-bug-report-information))
 
 (define program-name
diff --git a/guix/utils.scm b/guix/utils.scm
index 04a74ee29a..5fda2116de 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -34,7 +34,7 @@
   #:use-module (ice-9 regex)
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
-  #:autoload   (system foreign) (pointer->procedure)
+  #:use-module (system foreign)
   #:export (bytevector->base16-string
             base16-string->bytevector
 
@@ -43,6 +43,7 @@
             nixpkgs-derivation*
 
             compile-time-value
+            fcntl-flock
             memoize
             default-keyword-arguments
             substitute-keyword-arguments
@@ -224,6 +225,67 @@ buffered data is lost."
 
 
 ;;;
+;;; Advisory file locking.
+;;;
+
+(define %struct-flock
+  ;; 'struct flock' from <fcntl.h>.
+  (list short                                     ; l_type
+        short                                     ; l_whence
+        size_t                                    ; l_start
+        size_t                                    ; l_len
+        int))                                     ; l_pid
+
+(define F_SETLKW
+  ;; On Linux-based systems, this is usually 7, but not always
+  ;; (exceptions include SPARC.)  On GNU/Hurd, it's 9.
+  (compile-time-value
+   (cond ((string-contains %host-type "sparc") 9) ; sparc-*-linux-gnu
+         ((string-contains %host-type "linux") 7) ; *-linux-gnu
+         (else 9))))                              ; *-gnu*
+
+(define F_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)
+      "Perform locking OPERATION on the file beneath FD-OR-PORT.  OPERATION
+must be a symbol, one of 'read-lock, 'write-lock, or 'unlock."
+      (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
+                       F_SETLKW                   ; lock & wait
+                       (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 fd))))))
+
+
+;;;
 ;;; Miscellaneous.
 ;;;