diff options
Diffstat (limited to 'guix/scripts/pull.scm')
| -rw-r--r-- | guix/scripts/pull.scm | 122 |
1 files changed, 97 insertions, 25 deletions
diff --git a/guix/scripts/pull.scm b/guix/scripts/pull.scm index 919ef2d467..16805bad3f 100644 --- a/guix/scripts/pull.scm +++ b/guix/scripts/pull.scm @@ -25,6 +25,8 @@ #:use-module (guix download) #:use-module (guix gexp) #:use-module (guix monads) + #:use-module ((guix build utils) + #:select (with-directory-excursion delete-file-recursively)) #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module ((gnu packages bootstrap) @@ -32,7 +34,11 @@ #:use-module (gnu packages compression) #:use-module (gnu packages gnupg) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-37) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) #:export (guix-pull)) (define %snapshot-url @@ -40,31 +46,18 @@ "http://git.savannah.gnu.org/cgit/guix.git/snapshot/guix-master.tar.gz" ) -(define* (unpack tarball #:key verbose?) - "Return a derivation that unpacks TARBALL into STORE and compiles Scheme -files." - (define builder - #~(begin - (use-modules (guix build pull)) +(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))))) - (let ((json (string-append #$guile-json "/share/guile/site/2.0"))) - (set! %load-path (cons json %load-path)) - (set! %load-compiled-path (cons json %load-compiled-path))) - - (build-guix #$output #$tarball - - ;; XXX: This is not perfect, enabling VERBOSE? means - ;; building a different derivation. - #:debug-port (if #$verbose? - (current-error-port) - (%make-void-port "w")) - #:tar #$tar - #:gzip #$gzip - #:gcrypt #$libgcrypt))) - - (gexp->derivation "guix-latest" builder - #:modules '((guix build pull) - (guix build utils)))) +(define-syntax-rule (with-PATH value body ...) + (with-environment-variable "PATH" value body ...)) ;;; @@ -118,10 +111,82 @@ 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 (_ "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 +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))) + ;; 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 #:key verbose?) "Build the tool from TARBALL, and install it in CONFIG-DIR." - (mlet* %store-monad ((source (unpack tarball #:verbose? verbose?)) + (mlet* %store-monad ((source (build-from-source tarball + #:verbose? verbose?)) (source-dir -> (derivation->output-path source)) (to-do? (what-to-build (list source)))) (if to-do? @@ -165,3 +230,10 @@ Download and deploy the latest version of Guix.\n")) (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: + +;;; pull.scm ends here |