pull: Rewrite using gexps.
* guix/scripts/pull.scm (unpack): Remove 'store' parameter. Rewrite using 'gexp->derivation'. (what-to-build, indirect-root-added, build-and-install): New procedures. (guix-pull): Use it.
This commit is contained in:
parent
2f7a10db6d
commit
cb823dd279
|
@ -23,6 +23,8 @@
|
||||||
#:use-module (guix packages)
|
#:use-module (guix packages)
|
||||||
#:use-module (guix derivations)
|
#:use-module (guix derivations)
|
||||||
#:use-module (guix download)
|
#:use-module (guix download)
|
||||||
|
#:use-module (guix gexp)
|
||||||
|
#:use-module (guix monads)
|
||||||
#:use-module (gnu packages base)
|
#:use-module (gnu packages base)
|
||||||
#:use-module (gnu packages guile)
|
#:use-module (gnu packages guile)
|
||||||
#:use-module ((gnu packages bootstrap)
|
#:use-module ((gnu packages bootstrap)
|
||||||
|
@ -38,34 +40,27 @@
|
||||||
"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
|
"http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz"
|
||||||
)
|
)
|
||||||
|
|
||||||
(define* (unpack store tarball #:key verbose?)
|
(define* (unpack tarball #:key verbose?)
|
||||||
"Return a derivation that unpacks TARBALL into STORE and compiles Scheme
|
"Return a derivation that unpacks TARBALL into STORE and compiles Scheme
|
||||||
files."
|
files."
|
||||||
(define builder
|
(define builder
|
||||||
`(begin
|
#~(begin
|
||||||
(use-modules (guix build pull))
|
(use-modules (guix build pull))
|
||||||
|
|
||||||
(build-guix (assoc-ref %outputs "out")
|
(build-guix #$output #$tarball
|
||||||
(assoc-ref %build-inputs "tarball")
|
|
||||||
|
|
||||||
;; XXX: This is not perfect, enabling VERBOSE? means
|
;; XXX: This is not perfect, enabling VERBOSE? means
|
||||||
;; building a different derivation.
|
;; building a different derivation.
|
||||||
#:debug-port (if ',verbose?
|
#:debug-port (if #$verbose?
|
||||||
(current-error-port)
|
(current-error-port)
|
||||||
(%make-void-port "w"))
|
(%make-void-port "w"))
|
||||||
#:tar (assoc-ref %build-inputs "tar")
|
#:tar #$tar
|
||||||
#:gzip (assoc-ref %build-inputs "gzip")
|
#:gzip #$gzip
|
||||||
#:gcrypt (assoc-ref %build-inputs "gcrypt"))))
|
#:gcrypt #$libgcrypt)))
|
||||||
|
|
||||||
(build-expression->derivation store "guix-latest" builder
|
(gexp->derivation "guix-latest" builder
|
||||||
#:inputs
|
#:modules '((guix build pull)
|
||||||
`(("tar" ,(package-derivation store tar))
|
(guix build utils))))
|
||||||
("gzip" ,(package-derivation store gzip))
|
|
||||||
("gcrypt" ,(package-derivation store
|
|
||||||
libgcrypt))
|
|
||||||
("tarball" ,tarball))
|
|
||||||
#:modules '((guix build pull)
|
|
||||||
(guix build utils))))
|
|
||||||
|
|
||||||
|
|
||||||
;;;
|
;;;
|
||||||
|
@ -114,6 +109,33 @@ Download and deploy the latest version of Guix.\n"))
|
||||||
(lambda args
|
(lambda args
|
||||||
(show-version-and-exit "guix pull")))))
|
(show-version-and-exit "guix pull")))))
|
||||||
|
|
||||||
|
(define what-to-build
|
||||||
|
(store-lift show-what-to-build))
|
||||||
|
(define indirect-root-added
|
||||||
|
(store-lift add-indirect-root))
|
||||||
|
|
||||||
|
(define* (build-and-install tarball config-dir
|
||||||
|
#:key verbose?)
|
||||||
|
"Build the tool from TARBALL, and install it in CONFIG-DIR."
|
||||||
|
(mlet* %store-monad ((source (unpack tarball #:verbose? verbose?))
|
||||||
|
(source-dir -> (derivation->output-path source))
|
||||||
|
(to-do? (what-to-build (list source))))
|
||||||
|
(if to-do?
|
||||||
|
(mlet* %store-monad ((built? (built-derivations (list source))))
|
||||||
|
(if built?
|
||||||
|
(mlet* %store-monad
|
||||||
|
((latest -> (string-append config-dir "/latest"))
|
||||||
|
(done (indirect-root-added latest)))
|
||||||
|
(switch-symlinks latest source-dir)
|
||||||
|
(format #t
|
||||||
|
(_ "updated ~a successfully deployed under `~a'~%")
|
||||||
|
%guix-package-name latest)
|
||||||
|
(return #t))
|
||||||
|
(leave (_ "failed to update Guix, check the build log~%"))))
|
||||||
|
(begin
|
||||||
|
(display (_ "Guix already up to date\n"))
|
||||||
|
(return #t)))))
|
||||||
|
|
||||||
(define (guix-pull . args)
|
(define (guix-pull . args)
|
||||||
(define (parse-options)
|
(define (parse-options)
|
||||||
;; Return the alist of option values.
|
;; Return the alist of option values.
|
||||||
|
@ -136,20 +158,6 @@ Download and deploy the latest version of Guix.\n"))
|
||||||
(if (assoc-ref opts 'bootstrap?)
|
(if (assoc-ref opts 'bootstrap?)
|
||||||
%bootstrap-guile
|
%bootstrap-guile
|
||||||
(canonical-package guile-2.0)))))
|
(canonical-package guile-2.0)))))
|
||||||
(let* ((config-dir (config-directory))
|
(run-with-store store
|
||||||
(source (unpack store tarball
|
(build-and-install tarball (config-directory)
|
||||||
#:verbose? (assoc-ref opts 'verbose?)))
|
#:verbose? (assoc-ref opts 'verbose?))))))))
|
||||||
(source-dir (derivation->output-path source)))
|
|
||||||
(if (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)
|
|
||||||
(leave (_ "failed to update Guix, check the build log~%")))
|
|
||||||
(begin
|
|
||||||
(display (_ "Guix already up to date\n"))
|
|
||||||
#t))))))))
|
|
||||||
|
|
Loading…
Reference in New Issue