Merge branch 'master' into core-updates

6 files changed, 155 insertions, 45 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index b47ab93759..4d11434e3a 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -451,13 +451,13 @@ that form."
   ;; This procedure is called frequently, so memoize it.
   (memoize
    (lambda* (path #:optional (output "out"))
-     "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
+     "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the store
 path of its output OUTPUT."
      (derivation->output-path (call-with-input-file path read-derivation)
                               output))))
 
 (define (derivation-path->output-paths path)
-  "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the
+  "Read the derivation from PATH (`/gnu/store/xxx.drv'), and return the
 list of name/path pairs of its outputs."
   (derivation->output-paths (call-with-input-file path read-derivation)))
 
diff --git a/guix/download.scm b/guix/download.scm
index 0889928d3a..2cb0740897 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -255,8 +255,9 @@ omitted.  Write progress reports to LOG."
   (define uri
     (string->uri url))
 
-  (if (memq (uri-scheme uri) '(file #f))
-      (add-to-store store name #f "sha256" (uri-path uri))
+  (if (or (not uri) (memq (uri-scheme uri) '(file #f)))
+      (add-to-store store name #f "sha256"
+                    (if uri (uri-path uri) url))
       (call-with-temporary-output-file
        (lambda (temp port)
          (let ((result
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 8280a821c5..0ab7686585 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -23,6 +23,7 @@
   #:use-module (guix store)
   #:use-module (guix packages)
   #:use-module (guix derivations)
+  #:use-module (guix monads)
   #:use-module (guix ui)
   #:use-module (guix pki)
   #:use-module (guix pk-crypto)
@@ -143,6 +144,24 @@ Export/import one or more packages from/to the store.\n"))
 
          %standard-build-options))
 
+(define (derivation-from-expression store str package-derivation
+                                    system source?)
+  "Read/eval STR and return the corresponding derivation path for SYSTEM.
+When SOURCE? is true and STR evaluates to a package, return the derivation of
+the package source; otherwise, use PACKAGE-DERIVATION to compute the
+derivation of a package."
+  (match (read/eval str)
+    ((? package? p)
+     (if source?
+         (let ((source (package-source p)))
+           (if source
+               (package-source-derivation store source)
+               (leave (_ "package `~a' has no source~%")
+                      (package-name p))))
+         (package-derivation store p system)))
+    ((? procedure? proc)
+     (run-with-store store (proc) #:system system))))
+
 (define (options->derivations+files store opts)
   "Given OPTS, the result of 'args-fold', return a list of derivations to
 build and a list of store files to transfer."
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 618015e9ba..35b10a0ec2 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -33,32 +33,13 @@
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-37)
   #:autoload   (gnu packages) (find-best-packages-by-name)
-  #:export (derivation-from-expression
-
-            %standard-build-options
+  #:autoload   (guix download) (download-to-store)
+  #:export (%standard-build-options
             set-build-options-from-command-line
             show-build-options-help
 
             guix-build))
 
-(define (derivation-from-expression store str package-derivation
-                                    system source?)
-  "Read/eval STR and return the corresponding derivation path for SYSTEM.
-When SOURCE? is true and STR evaluates to a package, return the derivation of
-the package source; otherwise, use PACKAGE-DERIVATION to compute the
-derivation of a package."
-  (match (read/eval str)
-    ((? package? p)
-     (if source?
-         (let ((source (package-source p)))
-           (if source
-               (package-source-derivation store source)
-               (leave (_ "package `~a' has no source~%")
-                      (package-name p))))
-         (package-derivation store p system)))
-    ((? procedure? proc)
-     (run-with-store store (proc) #:system system))))
-
 (define (specification->package spec)
   "Return a package matching SPEC.  SPEC may be a package name, or a package
 name followed by a hyphen and a version number.  If the version number is not
@@ -104,6 +85,31 @@ present, return the preferred newest version."
         (leave (_ "failed to create GC root `~a': ~a~%")
                root (strerror (system-error-errno args)))))))
 
+(define (package-with-source store p uri)
+  "Return a package based on P but with its source taken from URI.  Extract
+the new package's version number from URI."
+  (define (numeric-extension? file-name)
+    ;; Return true if FILE-NAME ends with digits.
+    (string-every char-set:hex-digit (file-extension file-name)))
+
+  (define (tarball-base-name file-name)
+    ;; Return the "base" of FILE-NAME, removing '.tar.gz' or similar
+    ;; extensions.
+    ;; TODO: Factorize.
+    (cond ((numeric-extension? file-name)
+           file-name)
+          ((string=? (file-extension file-name) "tar")
+           (file-sans-extension file-name))
+          (else
+           (tarball-base-name (file-sans-extension file-name)))))
+
+  (let ((base (tarball-base-name (basename uri))))
+    (let-values (((name version)
+                  (package-name->name+version base)))
+      (package (inherit p)
+               (version (or version (package-version p)))
+               (source (download-to-store store uri))))))
+
 
 ;;;
 ;;; Standard command-line build options.
@@ -222,6 +228,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (display (_ "
       --target=TRIPLET   cross-build for TRIPLET--e.g., \"armel-linux-gnu\""))
   (display (_ "
+      --with-source=SOURCE
+                         use SOURCE when building the corresponding package"))
+  (display (_ "
   -d, --derivations      return the derivation paths of the given packages"))
   (display (_ "
   -r, --root=FILE        make FILE a symlink to the result, and register it
@@ -274,6 +283,9 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '("log-file") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'log-file? #t result)))
+         (option '("with-source") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'with-source arg result)))
 
          %standard-build-options))
 
@@ -289,23 +301,80 @@ build."
   (define src? (assoc-ref opts 'source?))
   (define sys  (assoc-ref opts 'system))
 
-  (filter-map (match-lambda
-               (('expression . str)
-                (derivation-from-expression store str package->derivation
-                                            sys src?))
-               (('argument . (? derivation-path? drv))
-                (call-with-input-file drv read-derivation))
-               (('argument . (? store-path?))
-                ;; Nothing to do; maybe for --log-file.
-                #f)
-               (('argument . (? string? x))
-                (let ((p (specification->package x)))
+  (let ((opts (options/with-source store
+                                   (options/resolve-packages store opts))))
+    (filter-map (match-lambda
+                 (('argument . (? package? p))
                   (if src?
                       (let ((s (package-source p)))
                         (package-source-derivation store s))
-                      (package->derivation store p sys))))
-               (_ #f))
-              opts))
+                      (package->derivation store p sys)))
+                 (('argument . (? derivation? drv))
+                  drv)
+                 (('argument . (? derivation-path? drv))
+                  (call-with-input-file drv read-derivation))
+                 (('argument . (? store-path?))
+                  ;; Nothing to do; maybe for --log-file.
+                  #f)
+                 (_ #f))
+                opts)))
+
+(define (options/resolve-packages store opts)
+  "Return OPTS with package specification strings replaced by actual
+packages."
+  (define system
+    (or (assoc-ref opts 'system) (%current-system)))
+
+  (map (match-lambda
+        (('argument . (? string? spec))
+         (if (store-path? spec)
+             `(argument . ,spec)
+             `(argument . ,(specification->package spec))))
+        (('expression . str)
+         (match (read/eval str)
+           ((? package? p)
+            `(argument . ,p))
+           ((? procedure? proc)
+            (let ((drv (run-with-store store (proc) #:system system)))
+              `(argument . ,drv)))))
+        (opt opt))
+       opts))
+
+(define (options/with-source store opts)
+  "Process with 'with-source' options in OPTS, replacing the relevant package
+arguments with packages that use the specified source."
+  (define new-sources
+    (filter-map (match-lambda
+                 (('with-source . uri)
+                  (cons (package-name->name+version (basename uri))
+                        uri))
+                 (_ #f))
+                opts))
+
+  (let loop ((opts    opts)
+             (sources new-sources)
+             (result  '()))
+    (match opts
+      (()
+       (unless (null? sources)
+         (warning (_ "sources do not match any package:~{ ~a~}~%")
+                  (match sources
+                    (((name . uri) ...)
+                     uri))))
+       (reverse result))
+      ((('argument . (? package? p)) tail ...)
+       (let ((source (assoc-ref sources (package-name p))))
+         (loop tail
+               (alist-delete (package-name p) sources)
+               (alist-cons 'argument
+                           (if source
+                               (package-with-source store p source)
+                               p)
+                           result))))
+      ((('with-source . _) tail ...)
+       (loop tail sources result))
+      ((head tail ...)
+       (loop tail sources (cons head result))))))
 
 
 ;;;
diff --git a/guix/scripts/offload.scm b/guix/scripts/offload.scm
index 4d2f78f711..95e35088a1 100644
--- a/guix/scripts/offload.scm
+++ b/guix/scripts/offload.scm
@@ -56,6 +56,8 @@
   build-machine make-build-machine
   build-machine?
   (name            build-machine-name)            ; string
+  (port            build-machine-port             ; number
+                   (default 22))
   (system          build-machine-system)          ; string
   (user            build-machine-user)            ; string
   (private-key     build-machine-private-key      ; file name
@@ -161,8 +163,9 @@ determined."
   "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"
+      (apply open-pipe* mode %lshg-command "-z"
+             "-l" (build-machine-user machine)
+             "-p" (number->string (build-machine-port machine))
 
              ;; XXX: Remove '-i' when %LSHG-COMMAND really is lshg.
              "-i" (build-machine-private-key machine)
@@ -328,6 +331,7 @@ success, #f otherwise."
            (missing (filtered-port
                      (list (which %lshg-command)
                            "-l" (build-machine-user machine)
+                           "-p" (number->string (build-machine-port machine))
                            "-i" (build-machine-private-key machine)
                            (build-machine-name machine)
                            "guix" "archive" "--missing")
@@ -462,10 +466,14 @@ allowed on MACHINE."
                   machines))
 
     (define (undecorate pred)
-      (match-lambda
-       ((machine slot)
-        (and (pred machine)
-             (list machine slot)))))
+      (lambda (a b)
+        (match a
+          ((machine1 slot1)
+           (match b
+             ((machine2 slot2)
+              (if (pred machine1 machine2)
+                  (list machine1 slot1)
+                  (list machine2 slot2))))))))
 
     (let ((machines+slots (sort machines+slots
                                 (undecorate machine-less-loaded-or-faster?))))
diff --git a/guix/store.scm b/guix/store.scm
index 909ef195de..58f7e36762 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -57,6 +57,7 @@
             set-build-options
             valid-path?
             query-path-hash
+            hash-part->path
             add-text-to-store
             add-to-store
             build-derivations
@@ -501,6 +502,18 @@ encoding conversion errors."
   "Return the SHA256 hash of PATH as a bytevector."
   base16)
 
+(define hash-part->path
+  (let ((query-path-from-hash-part
+         (operation (query-path-from-hash-part (string hash))
+                    #f
+                    store-path)))
+   (lambda (server hash-part)
+     "Return the store path whose hash part is HASH-PART (a nix-base32
+string).  Raise an error if no such path exists."
+     ;; This RPC is primarily used by Hydra to reply to HTTP GETs of
+     ;; /HASH.narinfo.
+     (query-path-from-hash-part server hash-part))))
+
 (define add-text-to-store
   ;; A memoizing version of `add-to-store', to avoid repeated RPCs with
   ;; the very same arguments during a given session.