summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2017-07-28 17:38:19 +0200
committerLudovic Courtès <ludo@gnu.org>2017-08-02 00:04:00 +0200
commit59a16275189f55ddd692b0ea5b415c706fa1fd69 (patch)
treea4df38ed0673dc57da7cd168092b2f25feb7492f /guix
parent7441f1dbd77b09f6170858795bc7deea6280b972 (diff)
pull: Fetch source code from Git.
* guix/scripts/pull.scm (%snapshot-url, with-environment-variable) (with-PATH): Remove. (ensure-guile-git!): New procedure. (%repository-url): New variable. (%default-options): Add 'repository-url' and 'ref'. (show-help, %options): Add '--commit' and '--url'. (temporary-directory, first-directory, interned-then-deleted) (unpack): Remove. (build-from-source): Rename 'tarball' to 'source'. Remove call to 'unpack'. (build-and-install): Rename 'tarball' to 'source'. (honor-lets-encrypt-certificates!, report-git-error): New procedures. (with-git-error-handling): New macro. (guix-pull)[fetch-tarball]: Remove. Wrap body in 'with-git-error-handling'. Rewrite to use 'latest-repository-commit'. * build-aux/build-self.scm (build): Print an error message and exit when GUILE-GIT is #f. * doc/guix.texi (Invoking guix pull): Mention Git. Document '--commit' and '--branch'.
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/pull.scm237
1 files changed, 126 insertions, 111 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58b87d4df4..e3b07e08b1 100644
--- a/guix/scripts/pull.scm
+++ b/guix/scripts/pull.scm
@@ -41,6 +41,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 +49,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 +90,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 +104,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 +127,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 +158,28 @@ 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
+(define* (build-from-source source #:key verbose?)
+ "Return a derivation to build Guix from SOURCE, using the self-build script
contained therein."
;; 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?)))
-(define* (build-and-install tarball config-dir
+(define* (build-and-install source config-dir
#:key verbose?)
- "Build the tool from TARBALL, and install it in CONFIG-DIR."
- (mlet* %store-monad ((source (build-from-source tarball
+ "Build the tool from SOURCE, and install it in CONFIG-DIR."
+ (mlet* %store-monad ((source (build-from-source source
#:verbose? verbose?))
(source-dir -> (derivation->output-path source))
(to-do? (what-to-build (list source)))
@@ -227,44 +203,83 @@ 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
+ (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)
+ #:verbose? (assoc-ref opts 'verbose?)))))))))))
;;; pull.scm ends here