[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/04: pull: Fetch source code from Git.
|
From: |
Ludovic Courtès |
|
Subject: |
02/04: pull: Fetch source code from Git. |
|
Date: |
Tue, 1 Aug 2017 18:06:06 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 59a16275189f55ddd692b0ea5b415c706fa1fd69
Author: Ludovic Courtès <address@hidden>
Date: Fri Jul 28 17:38:19 2017 +0200
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'.
---
build-aux/build-self.scm | 17 ++++
doc/guix.texi | 25 ++---
guix/scripts/pull.scm | 237 +++++++++++++++++++++++++----------------------
3 files changed, 153 insertions(+), 126 deletions(-)
diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 8fb9af2..4933e02 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -224,6 +224,23 @@ files."
(current-error-port)
(%make-void-port "w")))))
+ (unless guile-git
+ ;; XXX: Guix before February 2017 lacks a 'guile-git' package altogether.
+ ;; If we try to upgrade anyway, the logic in (guix scripts pull) will not
+ ;; build (guix git), which will leave us with an unusable 'guix pull'. To
+ ;; avoid that, fail early.
+ (format (current-error-port)
+ "\
+Your installation is too old and lacks a '~a' package.
+Please upgrade to an intermediate version first, for instance with:
+
+ guix pull
--url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.13.0.tar.gz
+\n"
+ (match (effective-version)
+ ("2.0" "guile2.0-git")
+ (_ "guile-git")))
+ (exit 1))
+
(mlet %store-monad ((guile (guile-for-build)))
(gexp->derivation "guix-latest" builder
#:modules '((guix build pull)
diff --git a/doc/guix.texi b/doc/guix.texi
index 7957565..0ea6773 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2477,7 +2477,8 @@ Packages are installed or upgraded to the latest version
available in
the distribution currently available on your local machine. To update
that distribution, along with the Guix tools, you must run @command{guix
pull}: the command downloads the latest Guix source code and package
-descriptions, and deploys it.
+descriptions, and deploys it. Source code is downloaded from a
address@hidden://git-scm.com, Git} repository.
On completion, @command{guix package} will use packages and package
versions from this just-retrieved copy of Guix. Not only that, but all
@@ -2503,24 +2504,18 @@ but it supports the following options:
Produce verbose output, writing build logs to the standard error output.
@item address@hidden
-Download the source tarball of Guix from @var{url}.
+Download Guix from the Git repository at @var{url}.
-By default, the tarball is taken from its canonical address at
+By default, the source is taken from its canonical Git repository at
@code{gnu.org}, for the stable branch of Guix.
-With some Git servers, this can be used to deploy any version of Guix.
-For example, to download and deploy version 0.12.0 of Guix from the
-canonical Git repo:
-
address@hidden
-guix pull
--url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.12.0.tar.gz
address@hidden example
-
-It can also be used to deploy arbitrary Git revisions:
address@hidden address@hidden
+Deploy @var{commit}, a valid Git commit ID represented as a hexadecimal
+string.
address@hidden
-guix pull
--url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/74d862e8a.tar.gz
address@hidden example
address@hidden address@hidden
+Deploy the tip of @var{branch}, the name of a Git branch available on
+the repository at @var{url}.
@item --bootstrap
Use the bootstrap Guile to build the latest Guix. This option is only
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm
index 58b87d4..e3b07e0 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