diff --git a/guix/build/git.scm b/guix/build/git.scm index c1af545a7..223e79227 100644 --- a/guix/build/git.scm +++ b/guix/build/git.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2016 Ludovic Courtès +;;; Copyright © 2014, 2016, 2017 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,14 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build git) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (guix serialization) #:use-module (guix build utils) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 match) #:export (git-fetch)) ;;; Commentary: @@ -27,6 +34,37 @@ ;;; ;;; Code: +(define (urls-for-item item) + "Return the fallback nar URL for ITEM--e.g., \"cabbag3…-foo-1.2-checkout\"." + ;; TODO: Use the /gzip URLs, make it configurable, and use TLS. + (list (string-append "http://mirror.hydra.gnu.org/guix/nar/" item) + (string-append "http://berlin.guixsd.org/nar/" item))) + +(define (download-nar item directory) + "Download Git checkout ITEM to DIRECTORY as a nar." + (setvbuf (current-output-port) _IONBF) + (setvbuf (current-error-port) _IONBF) + + (let loop ((urls (urls-for-item item))) + (match urls + ((url rest ...) + (format #t "Trying content-addressed mirror at ~a...~%" + (uri-host (string->uri url))) + (let-values (((response port) + (http-get url #:streaming? #t))) + (if (= 200 (response-code response)) + (let ((size (response-content-length response))) + (if size + (format #t "Downloading from ~a (~,2h MiB)...~%" + url (/ size (expt 2 20.))) + (format #t "Downloading from ~a...~%" url)) + (restore-file port directory) + (close-port port) + #t) + (loop rest)))) + (() + #f)))) + (define* (git-fetch url commit directory #:key (git-command "git") recursive?) "Fetch COMMIT from URL into DIRECTORY. COMMIT must be a valid Git commit @@ -39,26 +77,27 @@ recursively. Return #t on success, #f otherwise." ;; We cannot use "git clone --recursive" since the following "git checkout" ;; effectively removes sub-module checkouts as of Git 2.6.3. - (and (zero? (system* git-command "clone" url directory)) - (with-directory-excursion directory - (system* git-command "tag" "-l") - (and (zero? (system* git-command "checkout" commit)) - (begin - (when recursive? - ;; Now is the time to fetch sub-modules. - (unless (zero? (system* git-command "submodule" "update" - "--init" "--recursive")) - (error "failed to fetch sub-modules" url)) + (if (zero? (system* git-command "clone" url directory)) + (with-directory-excursion directory + (system* git-command "tag" "-l") + (and (zero? (system* git-command "checkout" commit)) + (begin + (when recursive? + ;; Now is the time to fetch sub-modules. + (unless (zero? (system* git-command "submodule" "update" + "--init" "--recursive")) + (error "failed to fetch sub-modules" url)) - ;; In sub-modules, '.git' is a flat file, not a directory, - ;; so we can use 'find-files' here. - (for-each delete-file-recursively - (find-files directory "^\\.git$"))) + ;; In sub-modules, '.git' is a flat file, not a directory, + ;; so we can use 'find-files' here. + (for-each delete-file-recursively + (find-files directory "^\\.git$"))) - ;; The contents of '.git' vary as a function of the current - ;; status of the Git repo. Since we want a fixed output, this - ;; directory needs to be taken out. - (delete-file-recursively ".git") - #t))))) + ;; The contents of '.git' vary as a function of the current + ;; status of the Git repo. Since we want a fixed output, this + ;; directory needs to be taken out. + (delete-file-recursively ".git") + #t))) + (download-nar (basename directory) directory))) ;;; git.scm ends here diff --git a/guix/git-download.scm b/guix/git-download.scm index 7397cbe7f..ffae8fcc3 100644 --- a/guix/git-download.scm +++ b/guix/git-download.scm @@ -25,6 +25,7 @@ #:use-module (guix monads) #:use-module (guix records) #:use-module (guix packages) + #:use-module (guix modules) #:autoload (guix build-system gnu) (standard-packages) #:use-module (ice-9 match) #:use-module (ice-9 popen) @@ -78,8 +79,8 @@ HASH-ALGO (a symbol). Use NAME as the file name, or a generic name if #f." '())) (define build - (with-imported-modules '((guix build git) - (guix build utils)) + (with-imported-modules (source-module-closure + '((guix build git))) #~(begin (use-modules (guix build git) (guix build utils)