me
/
guix
Archived
1
0
Fork 0
Code

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'.
master
Ludovic Courtès 2017-07-28 17:38:19 +02:00
parent 7441f1dbd7
commit 59a1627518
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 153 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
build-aux/build-self.scm
View File

@ -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)

25
doc/guix.texi
View File

@ -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
@uref{https://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 --url=@var{url}
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:
@item --commit=@var{commit}
Deploy @var{commit}, a valid Git commit ID represented as a hexadecimal
string.
@example
guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/v0.12.0.tar.gz
@end example
It can also be used to deploy arbitrary Git revisions:
@example
guix pull --url=https://git.savannah.gnu.org/cgit/guix.git/snapshot/74d862e8a.tar.gz
@end example
@item --branch=@var{branch}
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

217
guix/scripts/pull.scm
View File

@ -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
(with-git-error-handling
(let* ((opts (parse-command-line args %options
(list %default-options)))
(url (assoc-ref opts 'tarball-url)))
(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)
(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")))
;; 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)))
(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 tarball (config-directory)
#:verbose? (assoc-ref opts 'verbose?))))))))))
;; Local Variables:
;; eval: (put 'with-PATH 'scheme-indent-function 1)
;; eval: (put 'with-temporary-directory 'scheme-indent-function 1)
;; End:
(build-and-install checkout (config-directory)
#:verbose? (assoc-ref opts 'verbose?)))))))))))
;;; pull.scm ends here