packages: Add a 'snippet' field to <origin>.

* guix/packages.scm (<origin>): Add 'snippet', 'modules', and
  'imported-modules' fields.
  (patch-and-repack): Make 'inputs' a keyword parameter.  Add 'snippet',
  'modules', and 'imported-modules' parameters.  Accept SOURCE as a raw
  file name.  Insert SNIPPET in BUILDER.  Pass IMPORTED-MODULES to
  'build-expression->derivation'.
  (package-source-derivation): Pass the extra arguments to
  'patch-and-repack'.
* tests/packages.scm ("package-source-derivation, snippet"): New test.
* doc/guix.texi (Defining Packages): Mention the 'patches' and 'snippet'
  fields.
  (Invoking guix build): Tell that --source has patches and snippets
  applied.
  (Software Freedom): Mention packages that contain non-free code.

3 files changed, 140 insertions, 19 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index 43e7935b4c..4fb14063d0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -985,6 +985,11 @@ base32 representation of the hash.  You can obtain this information with
 @code{guix download} (@pxref{Invoking guix download}) and @code{guix
 hash} (@pxref{Invoking guix hash}).
 
+@cindex patches
+When needed, the @code{origin} form can also have a @code{patches} field
+listing patches to be applied, and a @code{snippet} field giving a
+Scheme expression to modify the source code.
+
 @item
 @cindex GNU Build System
 The @code{build-system} field is set to @var{gnu-build-system}.  The
@@ -1479,6 +1484,10 @@ themselves.
 For instance, @code{guix build -S gcc} returns something like
 @file{/nix/store/@dots{}-gcc-4.7.2.tar.bz2}, which is GCC's source tarball.
 
+The returned source tarball is the result of applying any patches and
+code snippets specified in the package's @code{origin} (@pxref{Defining
+Packages}).
+
 @item --system=@var{system}
 @itemx -s @var{system}
 Attempt to build for @var{system}---e.g., @code{i686-linux}---instead of
@@ -1878,6 +1887,14 @@ software distribution guidelines}.  Among other things, these guidelines
 reject non-free firmware, recommendations of non-free software, and
 discuss ways to deal with trademarks and patents.
 
+Some packages contain a small and optional subset that violates the
+above guidelines, for instance because this subset is itself non-free
+code.  When that happens, the offending items are removed with
+appropriate patches or code snippets in the package definition's
+@code{origin} form (@pxref{Defining Packages}).  That way, @code{guix
+build --source} returns the ``freed'' source rather than the unmodified
+upstream source.
+
 
 @node Package Naming
 @subsection Package Naming
diff --git a/guix/packages.scm b/guix/packages.scm
index 44f683f776..d4a295e3ac 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@
             origin-patch-flags
             origin-patch-inputs
             origin-patch-guile
+            origin-snippet
+            origin-modules
+            origin-imported-modules
             base32
 
             <search-path-specification>
@@ -107,10 +110,15 @@
   (sha256    origin-sha256)                       ; bytevector
   (file-name origin-file-name (default #f))       ; optional file name
   (patches   origin-patches (default '()))        ; list of file names
+  (snippet   origin-snippet (default #f))         ; sexp or #f
   (patch-flags  origin-patch-flags                ; list of strings
                 (default '("-p1")))
   (patch-inputs origin-patch-inputs               ; input list or #f
                 (default #f))
+  (modules      origin-modules                    ; list of module names
+                (default '()))
+  (imported-modules origin-imported-modules       ; list of module names
+                    (default '()))
   (patch-guile origin-patch-guile                 ; derivation or #f
                (default #f)))
 
@@ -270,26 +278,38 @@ corresponds to the arguments expected by `set-path-environment-variable'."
          (guile  (module-ref distro 'guile-final)))
     (package-derivation store guile system)))
 
-(define* (patch-and-repack store source patches inputs
+(define* (patch-and-repack store source patches
                            #:key
+                           (inputs '())
+                           (snippet #f)
                            (flags '("-p1"))
+                           (modules '())
+                           (imported-modules '())
                            (guile-for-build (%guile-for-build))
                            (system (%current-system)))
-  "Unpack SOURCE (a derivation), apply all of PATCHES, and repack the tarball
-using the tools listed in INPUTS."
+  "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
+repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
+it must be an s-expression that will run from within the directory where
+SOURCE was unpacked, after all of PATCHES have been applied.  MODULES and
+IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
+  (define source-file-name
+    ;; SOURCE is usually a derivation, but it could be a store file.
+    (if (derivation? source)
+        (derivation->output-path source)
+        source))
+
   (define decompression-type
-    (let ((out (derivation->output-path source)))
-      (cond ((string-suffix? "gz" out)  "gzip")
-            ((string-suffix? "bz2" out) "bzip2")
-            ((string-suffix? "lz" out)  "lzip")
-            (else "xz"))))
+    (cond ((string-suffix? "gz" source-file-name)  "gzip")
+          ((string-suffix? "bz2" source-file-name) "bzip2")
+          ((string-suffix? "lz" source-file-name)  "lzip")
+          (else "xz")))
 
   (define original-file-name
-    (let ((out (derivation->output-path source)))
-      ;; Remove the store prefix plus the slash, hash, and hyphen.
-      (let* ((sans (string-drop out (+ (string-length (%store-prefix)) 1)))
-             (dash (string-index sans #\-)))
-        (string-drop sans (+ 1 dash)))))
+    ;; Remove the store prefix plus the slash, hash, and hyphen.
+    (let* ((sans (string-drop source-file-name
+                              (+ (string-length (%store-prefix)) 1)))
+           (dash (string-index sans #\-)))
+      (string-drop sans (+ 1 dash))))
 
   (define patch-inputs
     (map (lambda (number patch)
@@ -329,7 +349,24 @@ using the tools listed in INPUTS."
                 (format (current-error-port)
                         "source is under '~a'~%" directory)
                 (chdir directory)
+
                 (and (every apply-patch ',(map car patch-inputs))
+
+                     ,@(if snippet
+                           `((let ((module (make-fresh-user-module)))
+                               (module-use-interfaces! module
+                                                       (map resolve-interface
+                                                            ',modules))
+                               (module-define! module '%build-inputs
+                                               %build-inputs)
+                               (module-define! module '%outputs %outputs)
+                               ((@ (system base compile) compile)
+                                ',snippet
+                                #:to 'value
+                                #:opts %auto-compilation-options
+                                #:env module)))
+                           '())
+
                      (begin (chdir "..") #t)
                      (zero? (system* tar "cvfa" out directory))))))))
 
@@ -349,24 +386,30 @@ using the tools listed in INPUTS."
                                  `(("source" ,source)
                                    ,@inputs
                                    ,@patch-inputs)
+                                 #:modules imported-modules
                                  #:guile-for-build guile-for-build)))
 
 (define* (package-source-derivation store source
                                     #:optional (system (%current-system)))
   "Return the derivation path for SOURCE, a package source, for SYSTEM."
   (match source
-    (($ <origin> uri method sha256 name ())
-     ;; No patches.
+    (($ <origin> uri method sha256 name () #f)
+     ;; No patches, no snippet: this is a fixed-output derivation.
      (method store uri 'sha256 sha256 name
              #:system system))
-    (($ <origin> uri method sha256 name (patches ...) (flags ...)
-        inputs guile-for-build)
-     ;; One or more patches.
+    (($ <origin> uri method sha256 name (patches ...) snippet
+        (flags ...) inputs (modules ...) (imported-modules ...)
+        guile-for-build)
+     ;; Patches and/or a snippet.
      (let ((source (method store uri 'sha256 sha256 name
                            #:system system)))
-       (patch-and-repack store source patches inputs
+       (patch-and-repack store source patches
+                         #:inputs inputs
+                         #:snippet snippet
                          #:flags flags
                          #:system system
+                         #:modules modules
+                         #:imported-modules modules
                          #:guile-for-build (or guile-for-build
                                                (%guile-for-build)
                                                (default-guile store system)))))
diff --git a/tests/packages.scm b/tests/packages.scm
index e0cf4ee001..7c5dd9f4e1 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -20,6 +20,7 @@
 (define-module (test-packages)
   #:use-module (guix store)
   #:use-module (guix utils)
+  #:use-module (guix hash)
   #:use-module (guix derivations)
   #:use-module (guix packages)
   #:use-module (guix build-system)
@@ -121,6 +122,66 @@
                                              (package-source package))))
     (string=? file source)))
 
+(test-equal "package-source-derivation, snippet"
+  "OK"
+  (let* ((file   (search-bootstrap-binary "guile-2.0.7.tar.xz"
+                                          (%current-system)))
+         (sha256 (call-with-input-file file port-sha256))
+         (fetch  (lambda* (store url hash-algo hash
+                           #:optional name #:key system)
+                   (pk 'fetch url hash-algo hash name system)
+                   (add-to-store store (basename url) #f "sha256" url)))
+         (source (bootstrap-origin
+                  (origin
+                    (method fetch)
+                    (uri file)
+                    (sha256 sha256)
+                    (patch-inputs
+                     `(("tar" ,%bootstrap-coreutils&co)
+                       ("xz" ,%bootstrap-coreutils&co)
+                       ("patch" ,%bootstrap-coreutils&co)))
+                    (patch-guile (package-derivation %store
+                                                     %bootstrap-guile))
+                    (modules '((guix build utils)))
+                    (imported-modules modules)
+                    (snippet '(begin
+                                ;; We end up in 'bin', because it's the first
+                                ;; directory, alphabetically.  Not a very good
+                                ;; example but hey.
+                                (chmod "." #o777)
+                                (symlink "guile" "guile-rocks")
+                                (copy-recursively "../share/guile/2.0/scripts"
+                                                  "scripts")
+
+                                ;; These variables must exist.
+                                (pk %build-inputs %outputs))))))
+         (package (package (inherit (dummy-package "with-snippet"))
+                    (source source)
+                    (build-system trivial-build-system)
+                    (inputs
+                     `(("tar" ,(search-bootstrap-binary "tar"
+                                                        (%current-system)))
+                       ("xz"  ,(search-bootstrap-binary "xz"
+                                                        (%current-system)))))
+                    (arguments
+                     `(#:guile ,%bootstrap-guile
+                       #:builder
+                       (let ((tar    (assoc-ref %build-inputs "tar"))
+                             (xz     (assoc-ref %build-inputs "xz"))
+                             (source (assoc-ref %build-inputs "source")))
+                         (and (zero? (system* tar "xvf" source
+                                              "--use-compress-program" xz))
+                              (string=? "guile" (readlink "bin/guile-rocks"))
+                              (file-exists? "bin/scripts/compile.scm")
+                              (let ((out (assoc-ref %outputs "out")))
+                                (call-with-output-file out
+                                  (lambda (p)
+                                    (display "OK" p))))))))))
+         (drv    (package-derivation %store package))
+         (out    (derivation->output-path drv)))
+    (and (build-derivations %store (list (pk 'snippet-drv drv)))
+         (call-with-input-file out get-string-all))))
+
 (test-assert "return value"
   (let ((drv (package-derivation %store (dummy-package "p"))))
     (and (derivation? drv)