diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/git.scm | 68 | ||||
| -rw-r--r-- | guix/scripts/build.scm | 88 | ||||
| -rw-r--r-- | guix/scripts/repl.scm | 5 | ||||
| -rw-r--r-- | guix/self.scm | 8 |
4 files changed, 164 insertions, 5 deletions
diff --git a/guix/git.scm b/guix/git.scm index d007916662..0666f0c0a9 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -20,11 +20,14 @@ (define-module (guix git) #:use-module (git) #:use-module (git object) + #:use-module (guix i18n) #:use-module (guix base32) #:use-module (gcrypt hash) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module (guix store) #:use-module (guix utils) + #:use-module (guix records) + #:use-module (guix gexp) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) #:use-module (srfi srfi-1) @@ -33,7 +36,12 @@ #:use-module (srfi srfi-35) #:export (%repository-cache-directory update-cached-checkout - latest-repository-commit)) + latest-repository-commit + + git-checkout + git-checkout? + git-checkout-url + git-checkout-branch)) (define %repository-cache-directory (make-parameter (string-append (cache-directory #:ensure? #f) @@ -154,6 +162,7 @@ data, respectively [<branch name> | <sha1> | <tag name>]." (define* (latest-repository-commit store url #:key + (log-port (%make-void-port "w")) (cache-directory (%repository-cache-directory)) (ref '(branch . "master"))) @@ -164,11 +173,14 @@ REF is pair whose key is [branch | commit | tag] and value the associated data, respectively [<branch name> | <sha1> | <tag name>]. Git repositories are kept in the cache directory specified by -%repository-cache-directory parameter." +%repository-cache-directory parameter. + +Log progress and checkout info to LOG-PORT." (define (dot-git? file stat) (and (string=? (basename file) ".git") (eq? 'directory (stat:type stat)))) + (format log-port "updating checkout of '~a'...~%" url) (let*-values (((checkout commit) (update-cached-checkout url @@ -177,6 +189,58 @@ Git repositories are kept in the cache directory specified by (url-cache-directory url cache-directory))) ((name) (url+commit->name url commit))) + (format log-port "retrieved commit ~a~%" commit) (values (add-to-store store name #t "sha256" checkout #:select? (negate dot-git?)) commit))) + + +;;; +;;; Checkouts. +;;; + +;; Representation of the "latest" checkout of a branch or a specific commit. +(define-record-type* <git-checkout> + git-checkout make-git-checkout + git-checkout? + (url git-checkout-url) + (branch git-checkout-branch (default "master")) + (commit git-checkout-commit (default #f))) + +(define* (latest-repository-commit* url #:key ref log-port) + ;; Monadic variant of 'latest-repository-commit'. + (lambda (store) + ;; The caller--e.g., (guix scripts build)--may not handle 'git-error' so + ;; translate it into '&message' conditions that we know will be properly + ;; handled. + (catch 'git-error + (lambda () + (values (latest-repository-commit store url + #:ref ref #:log-port log-port) + store)) + (lambda (key error . _) + (raise (condition + (&message + (message + (match ref + (('commit . commit) + (format #f (G_ "cannot fetch commit ~a from ~a: ~a") + commit url (git-error-message error))) + (('branch . branch) + (format #f (G_ "cannot fetch branch '~a' from ~a: ~a") + branch url (git-error-message error))) + (_ + (format #f (G_ "Git failure while fetching ~a: ~a") + url (git-error-message error)))))))))))) + +(define-gexp-compiler (git-checkout-compiler (checkout <git-checkout>) + system target) + ;; "Compile" CHECKOUT by updating the local checkout and adding it to the + ;; store. + (match checkout + (($ <git-checkout> url branch commit) + (latest-repository-commit* url + #:ref (if commit + `(commit . ,commit) + `(branch . ,branch)) + #:log-port (current-error-port))))) diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 13978abb77..5532c65eb6 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -45,6 +45,8 @@ #:use-module (srfi srfi-37) #:autoload (gnu packages) (specification->package %package-module-path) #:autoload (guix download) (download-to-store) + #:autoload (guix git-download) (git-reference?) + #:autoload (guix git) (git-checkout?) #:use-module (guix status) #:use-module ((guix progress) #:select (current-terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns)) @@ -270,6 +272,74 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (rewrite obj) obj)))) +(define (evaluate-git-replacement-specs specs proc) + "Parse SPECS, a list of strings like \"guile=stable-2.2\", and return a list +of package pairs, where (PROC PACKAGE URL BRANCH-OR-COMMIT) returns the +replacement package. Raise an error if an element of SPECS uses invalid +syntax, or if a package it refers to could not be found." + (define not-equal + (char-set-complement (char-set #\=))) + + (map (lambda (spec) + (match (string-tokenize spec not-equal) + ((name branch-or-commit) + (let* ((old (specification->package name)) + (source (package-source old)) + (url (cond ((and (origin? source) + (git-reference? (origin-uri source))) + (git-reference-url (origin-uri source))) + ((git-checkout? source) + (git-checkout-url source)) + (else + (leave (G_ "the source of ~a is not a Git \ +reference~%") + (package-full-name old)))))) + (cons old (proc old url branch-or-commit)))) + (x + (leave (G_ "invalid replacement specification: ~s~%") spec)))) + specs)) + +(define (transform-package-source-branch replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=stable-3.0\" meaning that packages are built using +'guile-next' from the latest commit on its 'stable-3.0' branch." + (define (replace old url branch) + (package + (inherit old) + (version (string-append "git." branch)) + (source (git-checkout (url url) (branch branch))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + +(define (transform-package-source-commit replacement-specs) + "Return a procedure that, when passed a package, replaces its direct +dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of +strings like \"guile-next=cabba9e\" meaning that packages are built using +'guile-next' from commit 'cabba9e'." + (define (replace old url commit) + (package + (inherit old) + (version (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7)))) + (source (git-checkout (url url) (commit commit))))) + + (let* ((replacements (evaluate-git-replacement-specs replacement-specs + replace)) + (rewrite (package-input-rewriting replacements))) + (lambda (store obj) + (if (package? obj) + (rewrite obj) + obj)))) + (define %transformations ;; Transformations that can be applied to things to build. The car is the ;; key used in the option alist, and the cdr is the transformation @@ -277,7 +347,9 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." ;; things to build. `((with-source . ,transform-package-source) (with-input . ,transform-package-inputs) - (with-graft . ,transform-package-inputs/graft))) + (with-graft . ,transform-package-inputs/graft) + (with-branch . ,transform-package-source-branch) + (with-commit . ,transform-package-source-commit))) (define %transformation-options ;; The command-line interface to the above transformations. @@ -291,7 +363,11 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." (option '("with-input") #t #f (parser 'with-input)) (option '("with-graft") #t #f - (parser 'with-graft))))) + (parser 'with-graft)) + (option '("with-branch") #t #f + (parser 'with-branch)) + (option '("with-commit") #t #f + (parser 'with-commit))))) (define (show-transformation-options-help) (display (G_ " @@ -302,7 +378,13 @@ current 'gnutls' package, after which version 3.5.4 is grafted onto them." replace dependency PACKAGE by REPLACEMENT")) (display (G_ " --with-graft=PACKAGE=REPLACEMENT - graft REPLACEMENT on packages that refer to PACKAGE"))) + graft REPLACEMENT on packages that refer to PACKAGE")) + (display (G_ " + --with-branch=PACKAGE=BRANCH + build PACKAGE from the latest commit of BRANCH")) + (display (G_ " + --with-commit=PACKAGE=COMMIT + build PACKAGE from COMMIT"))) (define (options->transformation opts) diff --git a/guix/scripts/repl.scm b/guix/scripts/repl.scm index 1a105f51ee..02169e8004 100644 --- a/guix/scripts/repl.scm +++ b/guix/scripts/repl.scm @@ -188,6 +188,11 @@ call THUNK." (save-module-excursion (lambda () (set-current-module user-module) + (and=> (getenv "HOME") + (lambda (home) + (let ((guile (string-append home "/.guile"))) + (when (file-exists? guile) + (load guile))))) ;; Do not exit repl on SIGINT. ((@@ (ice-9 top-repl) call-with-sigint) (lambda () diff --git a/guix/self.scm b/guix/self.scm index ddbe0b3669..8476c422ec 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -273,6 +273,10 @@ DOMAIN, a gettext domain." (module-ref (resolve-interface '(gnu packages graphviz)) 'graphviz)) + (define glibc-utf8-locales + (module-ref (resolve-interface '(gnu packages base)) + 'glibc-utf8-locales)) + (define documentation (file-append* source "doc")) @@ -336,6 +340,10 @@ DOMAIN, a gettext domain." (delete-file-recursively "images") (symlink (string-append #$output "/images") "images") + ;; Provide UTF-8 locales needed by the 'xspara.c' code in makeinfo. + (setenv "GUIX_LOCPATH" + #+(file-append glibc-utf8-locales "/lib/locale")) + (for-each (lambda (texi) (unless (string=? "guix.texi" texi) ;; Create 'version-LL.texi'. |