summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/pull.scm222
-rw-r--r--guix/ui.scm21
2 files changed, 243 insertions, 0 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
new file mode 100644
index 0000000000..f12133fff7
--- /dev/null
+++ b/guix/scripts/pull.scm
@@ -0,0 +1,222 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2013 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 pull)
+ #:use-module (guix ui)
+ #:use-module (guix store)
+ #:use-module (guix config)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix build download)
+ #:use-module (gnu packages base)
+ #:use-module ((gnu packages bootstrap)
+ #:select (%bootstrap-guile))
+ #:use-module (gnu packages compression)
+ #:use-module (gnu packages gnupg)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-37)
+ #:export (guix-pull))
+
+(define %snapshot-url
+ "http://hydra.gnu.org/job/guix/master/tarball/latest/download"
+ ;;"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
+ )
+
+(define (download-and-store store)
+ "Download the latest Guix tarball, add it to STORE, and return its store
+path."
+ ;; FIXME: Authenticate the downloaded file!
+ ;; FIXME: Optimize data transfers using rsync, Git, bsdiff, or GNUnet's DHT.
+ (call-with-temporary-output-file
+ (lambda (temp port)
+ (let ((result
+ (parameterize ((current-output-port (current-error-port)))
+ (url-fetch %snapshot-url temp))))
+ (close port)
+ (and result
+ (add-to-store store "guix-latest.tar.gz" #f "sha256" temp))))))
+
+(define (unpack store tarball)
+ "Return a derivation that unpacks TARBALL into STORE and compiles Scheme
+files."
+ (define builder
+ `(begin
+ (use-modules (guix build utils)
+ (system base compile)
+ (ice-9 ftw)
+ (ice-9 match))
+
+ (let ((out (assoc-ref %outputs "out"))
+ (tar (assoc-ref %build-inputs "tar"))
+ (gzip (assoc-ref %build-inputs "gzip"))
+ (gcrypt (assoc-ref %build-inputs "gcrypt"))
+ (tarball (assoc-ref %build-inputs "tarball")))
+ (setenv "PATH" (string-append tar "/bin:" gzip "/bin"))
+
+ (system* "tar" "xvf" tarball)
+ (match (scandir "." (lambda (name)
+ (and (not (member name '("." "..")))
+ (file-is-directory? name))))
+ ((dir)
+ (chdir dir))
+ (x
+ (error "tarball did not produce a single source directory" x)))
+
+ (format #t "copying and compiling Guix to `~a'...~%" out)
+
+ ;; Copy everything under guix/ and gnu/ plus guix.scm.
+ (file-system-fold (lambda (dir stat result) ; enter?
+ (or (string-prefix? "./guix" dir)
+ (string-prefix? "./gnu" dir)
+ (string=? "." dir)))
+ (lambda (file stat result) ; leaf
+ (when (or (not (string=? (dirname file) "."))
+ (string=? (basename file) "guix.scm"))
+ (let ((target (string-drop file 1)))
+ (copy-file file
+ (string-append out target)))))
+ (lambda (dir stat result) ; down
+ (mkdir (string-append out
+ (string-drop dir 1))))
+ (const #t) ; up
+ (const #t) ; skip
+ (lambda (file stat errno result)
+ (error "cannot access file"
+ file (strerror errno)))
+ #f
+ "."
+ lstat)
+
+ ;; Add a fake (guix config) module to allow the other modules to be
+ ;; compiled. The user's (guix config) is the one that will be used.
+ (copy-file "guix/config.scm.in"
+ (string-append out "/guix/config.scm"))
+ (substitute* (string-append out "/guix/config.scm")
+ (("@LIBGCRYPT@")
+ (string-append gcrypt "/lib/libgcrypt")))
+
+ ;; Augment the search path so Scheme code can be compiled.
+ (set! %load-path (cons out %load-path))
+ (set! %load-compiled-path (cons out %load-compiled-path))
+
+ ;; Compile the .scm files.
+ (for-each (lambda (file)
+ (when (string-suffix? ".scm" file)
+ (let ((go (string-append (string-drop-right file 4)
+ ".go")))
+ (compile-file file
+ #:output-file go
+ #:opts %auto-compilation-options))))
+ (find-files out "\\.scm"))
+
+ ;; Remove the "fake" (guix config).
+ (delete-file (string-append out "/guix/config.scm"))
+ (delete-file (string-append out "/guix/config.go")))))
+
+ (build-expression->derivation store "guix-latest" (%current-system)
+ builder
+ `(("tar" ,(package-derivation store tar))
+ ("gzip" ,(package-derivation store gzip))
+ ("gcrypt" ,(package-derivation store
+ libgcrypt))
+ ("tarball" ,tarball))
+ #:modules '((guix build utils))))
+
+
+;;;
+;;; Command-line options.
+;;;
+
+(define %default-options
+ ;; Alist of default option values.
+ '())
+
+(define (show-help)
+ (display (_ "Usage: guix pull [OPTION]...
+Download and deploy the latest version of Guix.\n"))
+ (display (_ "
+ --verbose produce verbose output"))
+ (display (_ "
+ --bootstrap use the bootstrap Guile to build the new Guix"))
+ (newline)
+ (display (_ "
+ -h, --help display this help and exit"))
+ (display (_ "
+ -V, --version display version information and exit"))
+ (newline)
+ (show-bug-report-information))
+
+(define %options
+ ;; Specifications of the command-line options.
+ (list (option '("verbose") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'verbose? #t result)))
+ (option '("bootstrap") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'bootstrap? #t result)))
+
+ (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (option '(#\V "version") #f #f
+ (lambda args
+ (show-version-and-exit "guix pull")))))
+
+(define (guix-pull . args)
+ (define (parse-options)
+ ;; Return the alist of option values.
+ (args-fold args %options
+ (lambda (opt name arg result)
+ (leave (_ "~A: unrecognized option~%") name))
+ (lambda (arg result)
+ (leave (_ "~A: unexpected argument~%") arg))
+ %default-options))
+
+ (let ((opts (parse-options))
+ (store (open-connection)))
+ (with-error-handling
+ (let ((tarball (download-and-store store)))
+ (unless tarball
+ (leave (_ "failed to download up-to-date source, exiting\n")))
+ (parameterize ((%guile-for-build
+ (package-derivation store
+ (if (assoc-ref opts 'bootstrap?)
+ %bootstrap-guile
+ guile-final)))
+ (current-build-output-port
+ (if (assoc-ref opts 'verbose?)
+ (current-error-port)
+ (%make-void-port "w"))))
+ (let*-values (((config-dir)
+ (config-directory))
+ ((source drv)
+ (unpack store tarball))
+ ((source-dir)
+ (derivation-output-path
+ (assoc-ref (derivation-outputs drv) "out"))))
+ (show-what-to-build store (list source))
+ (if (build-derivations store (list source))
+ (let ((latest (string-append config-dir "/latest")))
+ (add-indirect-root store latest)
+ (switch-symlinks latest source-dir)
+ (format #t
+ (_ "updated ~a successfully deployed under `~a'~%")
+ %guix-package-name latest)
+ #t))))))))
diff --git a/guix/ui.scm b/guix/ui.scm
index 2b75504573..7d1ea2bcbd 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -41,6 +41,7 @@
location->string
call-with-temporary-output-file
switch-symlinks
+ config-directory
fill-paragraph
string->recutils
package->recutils
@@ -178,6 +179,26 @@ both when LINK already exists and when it does not."
(symlink target pivot)
(rename-file pivot link)))
+(define (config-directory)
+ "Return the name of the configuration directory, after making sure that it
+exists. Honor the XDG specs,
+<http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html>."
+ (let ((dir (and=> (or (getenv "XDG_CONFIG_HOME")
+ (and=> (getenv "HOME")
+ (cut string-append <> "/.config")))
+ (cut string-append <> "/guix"))))
+ (catch 'system-error
+ (lambda ()
+ (mkdir dir)
+ dir)
+ (lambda args
+ (match (system-error-errno args)
+ ((or EEXIST 0)
+ dir)
+ (err
+ (leave (_ "failed to create configuration directory `~a': ~a~%")
+ dir (strerror err))))))))
+
(define* (fill-paragraph str width #:optional (column 0))
"Fill STR such that each line contains at most WIDTH characters, assuming
that the first character is at COLUMN.