Merge branch 'master' into core-updates

3 files changed, 336 insertions, 114 deletions

diff --git a/guix/build-system/minify.scm b/guix/build-system/minify.scm
new file mode 100644
index 0000000000..af90a32f59
--- /dev/null
+++ b/guix/build-system/minify.scm
@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 build-system minify)
+  #:use-module (guix store)
+  #:use-module (guix utils)
+  #:use-module (guix packages)
+  #:use-module (guix derivations)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-26)
+  #:export (%minify-build-system-modules
+            minify-build
+            minify-build-system))
+
+;; Commentary:
+;;
+;; Standard minification procedure for JavaScript files.
+;;
+;; Code:
+
+(define %minify-build-system-modules
+  ;; Build-side modules imported by default.
+  `((guix build minify-build-system)
+    (ice-9 popen)
+    ,@%gnu-build-system-modules))
+
+(define (default-uglify-js)
+  "Return the default package to minify JavaScript source files."
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((lisp-mod (resolve-interface '(gnu packages lisp))))
+    (module-ref lisp-mod 'uglify-js)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system
+                (uglify-js (default-uglify-js))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:source #:target #:inputs #:native-inputs))
+
+  (bag
+    (name name)
+    (system system)
+    (host-inputs `(,@(if source
+                         `(("source" ,source))
+                         '())
+                   ,@inputs
+                   ,@(standard-packages)))
+    (build-inputs `(("uglify-js" ,uglify-js)
+                    ,@native-inputs))
+    (outputs outputs)
+    (build minify-build)
+    (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define* (minify-build store name inputs
+                       #:key
+                       (javascript-files #f)
+                       (phases '(@ (guix build minify-build-system)
+                                   %standard-phases))
+                       (outputs '("out"))
+                       (system (%current-system))
+                       search-paths
+                       (guile #f)
+                       (imported-modules %minify-build-system-modules)
+                       (modules '((guix build minify-build-system)
+                                  (guix build utils))))
+  "Build SOURCE with INPUTS."
+  (define builder
+    `(begin
+       (use-modules ,@modules)
+       (minify-build #:name ,name
+                     #:source ,(match (assoc-ref inputs "source")
+                                 (((? derivation? source))
+                                  (derivation->output-path source))
+                                 ((source)
+                                  source)
+                                 (source
+                                  source))
+                     #:javascript-files ,javascript-files
+                     #:phases ,phases
+                     #:outputs %outputs
+                     #:search-paths ',(map search-path-specification->sexp
+                                           search-paths)
+                     #:inputs %build-inputs)))
+
+  (define guile-for-build
+    (match guile
+      ((? package?)
+       (package-derivation store guile system #:graft? #f))
+      (#f                               ; the default
+       (let* ((distro (resolve-interface '(gnu packages commencement)))
+              (guile  (module-ref distro 'guile-final)))
+         (package-derivation store guile system #:graft? #f)))))
+
+  (build-expression->derivation store name builder
+                                #:inputs inputs
+                                #:system system
+                                #:modules imported-modules
+                                #:outputs outputs
+                                #:guile-for-build guile-for-build))
+
+(define minify-build-system
+  (build-system
+    (name 'minify)
+    (description "The trivial JavaScript minification build system")
+    (lower lower)))
+
+;;; minify.scm ends here
diff --git a/guix/build/minify-build-system.scm b/guix/build/minify-build-system.scm
new file mode 100644
index 0000000000..3580deda07
--- /dev/null
+++ b/guix/build/minify-build-system.scm
@@ -0,0 +1,73 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 build minify-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module ((guix build minify-build-system) #:prefix minify:)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 popen)
+  #:export (%standard-phases
+            minify-build
+            minify))
+
+;; Commentary:
+;;
+;; Builder-side code of the standard minification procedure for JavaScript
+;; files.
+;;
+;; Code:
+
+(define* (minify file #:key target (directory ""))
+  (format #t "minifying ~a\n" file)
+  (let* ((base (basename file ".js"))
+         (installed (or target (string-append directory base ".min.js")))
+         (minified (open-pipe* OPEN_READ "uglify-js" file)))
+    (call-with-output-file installed
+      (cut dump-port minified <>))
+    #t))
+
+(define* (build #:key javascript-files
+                #:allow-other-keys)
+  (let ((files (or javascript-files
+                   (find-files "src" "\\.js$"))))
+    (mkdir-p "guix/build")
+    (every (cut minify <> #:directory "guix/build/") files)))
+
+(define* (install #:key outputs #:allow-other-keys)
+  (let* ((out (assoc-ref outputs "out"))
+         (js  (string-append out "/share/javascript/")))
+    (mkdir-p js)
+    (for-each (cut install-file <> js)
+              (find-files "guix/build" "\\.min\\.js$")))
+  #t)
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (delete 'configure)
+    (replace 'build build)
+    (delete 'check)
+    (replace 'install install)))
+
+(define* (minify-build #:key inputs (phases %standard-phases)
+                       #:allow-other-keys #:rest args)
+  "Build the given JavaScript package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))
+
+;;; minify-build-system.scm ends here
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58b87d4df4..a1deec8040 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -27,6 +27,7 @@
   #:use-module (guix derivations)
   #:use-module (guix download)
   #:use-module (guix gexp)
+  #:use-module (guix grafts)
   #:use-module (guix monads)
   #:use-module (guix scripts build)
   #:use-module ((guix build utils)
@@ -41,6 +42,7 @@
   #:use-module (gnu packages compression)
   #:use-module (gnu packages gnupg)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
@@ -48,23 +50,39 @@
   #:use-module (ice-9 match)
   #:export (guix-pull))
 
-(define %snapshot-url
-  ;; "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
-  "https://git.savannah.gnu.org/cgit/guix.git/snapshot/master.tar.gz"
-  )
+(module-autoload! (resolve-module '(guix scripts pull))
+                  '(git) '(git-error? set-tls-certificate-locations!)
+                  '(guix git) '(latest-repository-commit))
 
-(define-syntax-rule (with-environment-variable variable value body ...)
-  (let ((original (getenv variable)))
-    (dynamic-wind
-      (lambda ()
-        (setenv variable value))
-      (lambda ()
-        body ...)
-      (lambda ()
-        (setenv variable original)))))
+(define (ensure-guile-git!)
+  ;; Previously Guile-Git was not a prerequisite.  Thus, someone running 'guix
+  ;; pull' on an old installation may be lacking Guile-Git.  To address this,
+  ;; we autoload things that depend on Guile-Git and check in the entry point
+  ;; whether Guile-Git is available.
+  ;;
+  ;; TODO: Remove this hack when Guile-Git is widespread or enforced.
 
-(define-syntax-rule (with-PATH value body ...)
-  (with-environment-variable "PATH" value body ...))
+  (unless (false-if-exception (resolve-interface '(git)))
+    (leave (G_ "Guile-Git is missing but it is now required by 'guix pull'.
+Install it by running:
+
+  guix package -i ~a
+  export GUILE_LOAD_PATH=$HOME/.guix-profile/share/guile/site/~a:$GUILE_LOAD_PATH
+  export GUILE_LOAD_COMPILED_PATH=$HOME/.guix-profile/lib/guile/~a/site-ccache:$GUILE_LOAD_COMPILED_PATH
+\n")
+           (match (effective-version)
+             ("2.0" "guile2.0-git")
+             (_     "guile-git"))
+           (effective-version)
+           (effective-version)))
+
+  ;; XXX: For unclear reasons this is needed for
+  ;; 'set-tls-certificate-locations!'.
+  (module-use! (resolve-module '(guix scripts pull))
+               (resolve-interface '(git))))
+
+(define %repository-url
+  "https://git.savannah.gnu.org/git/guix.git")
 
 
 ;;;
@@ -73,7 +91,8 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((tarball-url . ,%snapshot-url)
+  `((repository-url . ,%repository-url)
+    (ref . (branch . "origin/master"))
     (system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
@@ -86,7 +105,11 @@ Download and deploy the latest version of Guix.\n"))
   (display (G_ "
       --verbose          produce verbose output"))
   (display (G_ "
-      --url=URL          download the Guix tarball from URL"))
+      --url=URL          download from the Git repository at URL"))
+  (display (G_ "
+      --commit=COMMIT    download the specified COMMIT"))
+  (display (G_ "
+      --branch=BRANCH    download the tip of the specified BRANCH"))
   (display (G_ "
       --bootstrap        use the bootstrap Guile to build the new Guix"))
   (newline)
@@ -105,8 +128,15 @@ Download and deploy the latest version of Guix.\n"))
                    (alist-cons 'verbose? #t result)))
          (option '("url") #t #f
                  (lambda (opt name arg result)
-                   (alist-cons 'tarball-url arg
-                               (alist-delete 'tarball-url result))))
+                   (alist-cons 'repository-url arg
+                               (alist-delete 'repository-url result))))
+         (option '("commit") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(commit . ,arg) result)))
+         (option '("branch") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'ref `(branch . ,(string-append "origin/" arg))
+                               result)))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
@@ -129,81 +159,30 @@ Download and deploy the latest version of Guix.\n"))
 (define indirect-root-added
   (store-lift add-indirect-root))
 
-(define (temporary-directory)
-  "Make a temporary directory and return its name."
-  (let ((name (tmpnam)))
-    (mkdir name)
-    (chmod name #o700)
-    name))
-
-(define (first-directory directory)
-  "Return a the name of the first file found under DIRECTORY."
-  (match (scandir directory
-                  (lambda (name)
-                    (and (not (member name '("." "..")))
-                         (file-is-directory? name))))
-    ((directory)
-     directory)
-    (x
-     (raise (condition
-             (&message
-              (message "tarball did not produce a single source directory")))))))
-
-(define (interned-then-deleted directory name)
-  "Add DIRECTORY to the store under NAME, and delete it.  Return the resulting
-store file name."
-  (mlet %store-monad ((result (interned-file directory name
-                                             #:recursive? #t)))
-    (delete-file-recursively directory)
-    (return result)))
-
-(define (unpack tarball)
-  "Return the name of the directory where TARBALL has been unpacked."
-  (mlet* %store-monad ((format -> (lift format %store-monad))
-                       (tar  (package->derivation tar))
-                       (gzip (package->derivation gzip)))
-    (mbegin %store-monad
-      (what-to-build (list tar gzip))
-      (built-derivations (list tar gzip))
-      (format #t (G_ "unpacking '~a'...~%") tarball)
-
-      (let ((source (temporary-directory)))
-        (with-directory-excursion source
-          (with-PATH (string-append (derivation->output-path gzip) "/bin")
-            (unless (zero? (system* (string-append (derivation->output-path tar)
-                                                   "/bin/tar")
-                                    "xf" tarball))
-              (raise (condition
-                      (&message (message "failed to unpack source code"))))))
-
-          (interned-then-deleted (string-append source "/"
-                                                (first-directory source))
-                                 "guix-source"))))))
-
 (define %self-build-file
   ;; The file containing code to build Guix.  This serves the same purpose as
   ;; a makefile, and, similarly, is intended to always keep this name.
   "build-aux/build-self.scm")
 
-(define* (build-from-source tarball #:key verbose?)
-  "Return a derivation to build Guix from TARBALL, using the self-build script
-contained therein."
+(define* (build-from-source source
+                            #:key verbose? commit)
+  "Return a derivation to build Guix from SOURCE, using the self-build script
+contained therein.  Use COMMIT as the version string."
   ;; Running the self-build script makes it easier to update the build
   ;; procedure: the self-build script of the Guix-to-be-installed contains the
   ;; right dependencies, build procedure, etc., which the Guix-in-use may not
   ;; be know.
-  (mlet* %store-monad ((source (unpack tarball))
-                       (script -> (string-append source "/"
-                                                 %self-build-file))
-                       (build -> (primitive-load script)))
+  (let* ((script (string-append source "/" %self-build-file))
+         (build  (primitive-load script)))
     ;; BUILD must be a monadic procedure of at least one argument: the source
     ;; tree.
-    (build source #:verbose? verbose?)))
+    (build source #:verbose? verbose? #:version commit)))
 
-(define* (build-and-install tarball config-dir
-                            #:key verbose?)
-  "Build the tool from TARBALL, and install it in CONFIG-DIR."
-  (mlet* %store-monad ((source        (build-from-source tarball
+(define* (build-and-install source config-dir
+                            #:key verbose? commit)
+  "Build the tool from SOURCE, and install it in CONFIG-DIR."
+  (mlet* %store-monad ((source        (build-from-source source
+                                                         #:commit commit
                                                          #:verbose? verbose?))
                        (source-dir -> (derivation->output-path source))
                        (to-do?        (what-to-build (list source)))
@@ -227,44 +206,87 @@ contained therein."
                 (return #t))))
         (leave (G_ "failed to update Guix, check the build log~%")))))
 
+(define (honor-lets-encrypt-certificates! store)
+  "Tell Guile-Git to use the Let's Encrypt certificates."
+  (let* ((drv   (package-derivation store le-certs))
+         (certs (string-append (derivation->output-path drv)
+                               "/etc/ssl/certs")))
+    (build-derivations store (list drv))
+
+    ;; In the past Guile-Git would not provide this procedure.
+    (if (module-defined? (resolve-interface '(git))
+                         'set-tls-certificate-locations!)
+        (set-tls-certificate-locations! certs)
+        (begin
+          ;; In this case we end up using whichever certificates OpenSSL
+          ;; chooses to use: $SSL_CERT_FILE, $SSL_CERT_DIR, or /etc/ssl/certs.
+          (warning (G_ "cannot enforce use of the Let's Encrypt \
+certificates~%"))
+          (warning (G_ "please upgrade Guile-Git~%"))))))
+
+(define (report-git-error error)
+  "Report the given Guile-Git error."
+  ;; Prior to Guile-Git commit b6b2760c2fd6dfaa5c0fedb43eeaff06166b3134,
+  ;; errors would be represented by integers.
+  (match error
+    ((? integer? error)                           ;old Guile-Git
+     (leave (G_ "Git error ~a~%") error))
+    ((? git-error? error)                         ;new Guile-Git
+     (leave (G_ "Git error: ~a~%") (git-error-message error)))))
+
+(define-syntax-rule (with-git-error-handling body ...)
+  (catch 'git-error
+    (lambda ()
+      body ...)
+    (lambda (key err)
+      (report-git-error err))))
+
 
 (define (guix-pull . args)
   (define (use-le-certs? url)
     (string-prefix? "https://git.savannah.gnu.org/" url))
 
-  (define (fetch-tarball store url)
-    (download-to-store store url "guix-latest.tar.gz"))
-
   (with-error-handling
-    (let* ((opts  (parse-command-line args %options
-                                      (list %default-options)))
-           (url   (assoc-ref opts 'tarball-url)))
-      (unless (assoc-ref opts 'dry-run?)          ;XXX: not very useful
-        (with-store store
-          (set-build-options-from-command-line store opts)
-          (let ((tarball
-                 (if (use-le-certs? url)
-                     (let* ((drv (package-derivation store le-certs))
-                            (certs (string-append (derivation->output-path drv)
-                                                  "/etc/ssl/certs")))
-                       (build-derivations store (list drv))
-                       (parameterize ((%x509-certificate-directory certs))
-                         (fetch-tarball store url)))
-                     (fetch-tarball store url))))
-            (unless tarball
-              (leave (G_ "failed to download up-to-date source, exiting\n")))
-            (parameterize ((%guile-for-build
-                            (package-derivation store
-                                                (if (assoc-ref opts 'bootstrap?)
-                                                    %bootstrap-guile
-                                                    (canonical-package guile-2.0)))))
-              (run-with-store store
-                (build-and-install tarball (config-directory)
-                                   #:verbose? (assoc-ref opts 'verbose?))))))))))
+    (with-git-error-handling
+     (let* ((opts  (parse-command-line args %options
+                                       (list %default-options)))
+            (url   (assoc-ref opts 'repository-url))
+            (ref   (assoc-ref opts 'ref))
+            (cache (string-append (cache-directory) "/pull")))
+       (ensure-guile-git!)
+
+       (unless (assoc-ref opts 'dry-run?)         ;XXX: not very useful
+         (with-store store
+           (parameterize ((%graft? (assoc-ref opts 'graft?)))
+             (set-build-options-from-command-line store opts)
+
+             ;; For reproducibility, always refer to the LE certificates when we
+             ;; know we're talking to Savannah.
+             (when (use-le-certs? url)
+               (honor-lets-encrypt-certificates! store))
+
+             (format (current-error-port)
+                     (G_ "Updating from Git repository at '~a'...~%")
+                     url)
+
+             (let-values (((checkout commit)
+                           (latest-repository-commit store url
+                                                     #:ref ref
+                                                     #:cache-directory cache)))
 
-;; Local Variables:
-;; eval: (put 'with-PATH 'scheme-indent-function 1)
-;; eval: (put 'with-temporary-directory 'scheme-indent-function 1)
-;; End:
+               (format (current-error-port)
+                       (G_ "Building from Git commit ~a...~%")
+                       commit)
+               (parameterize ((%guile-for-build
+                               (package-derivation
+                                store
+                                (if (assoc-ref opts 'bootstrap?)
+                                    %bootstrap-guile
+                                    (canonical-package guile-2.0)))))
+                 (run-with-store store
+                   (build-and-install checkout (config-directory)
+                                      #:commit commit
+                                      #:verbose?
+                                      (assoc-ref opts 'verbose?))))))))))))
 
 ;;; pull.scm ends here