diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/build-system/ruby.scm | 32 | ||||
| -rw-r--r-- | guix/build/ruby-build-system.scm | 18 | ||||
| -rw-r--r-- | guix/http-client.scm | 81 | ||||
| -rw-r--r-- | guix/profiles.scm | 91 |
4 files changed, 152 insertions, 70 deletions
diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm index d2dd6a48cc..08301ec609 100644 --- a/guix/build-system/ruby.scm +++ b/guix/build-system/ruby.scm @@ -43,22 +43,24 @@ (define private-keywords '(#:source #:target #:ruby #:inputs #:native-inputs)) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs + (let ((version-control (resolve-interface '(gnu packages version-control)))) + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("ruby" ,ruby) - ,@native-inputs)) - (outputs outputs) - (build ruby-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("ruby" ,ruby) + ("git" ,(module-ref version-control 'git)) + ,@native-inputs)) + (outputs outputs) + (build ruby-build) + (arguments (strip-keyword-arguments private-keywords arguments)))))) (define* (ruby-build store name inputs #:key diff --git a/guix/build/ruby-build-system.scm b/guix/build/ruby-build-system.scm index 40aa974dee..1310c4a0b3 100644 --- a/guix/build/ruby-build-system.scm +++ b/guix/build/ruby-build-system.scm @@ -39,6 +39,14 @@ directory." ((file-name . _) file-name) (() (error "No files matching pattern: " pattern)))) +;; Most gemspecs assume that builds are taking place within a git repository +;; by include calls to 'git ls-files'. In order for these gemspecs to work +;; as-is, every file in the source tree is added to the staging area. +(define gitify + (lambda _ + (and (zero? (system* "git" "init")) + (zero? (system* "git" "add" "."))))) + (define build (lambda _ (zero? (system* "gem" "build" (first-matching-file "\\.gemspec$"))))) @@ -53,17 +61,19 @@ directory." (match:substring (string-match "ruby-(.*)$" (assoc-ref inputs "ruby")) 1)) - (gem-home (string-append (assoc-ref outputs "out") - "/lib/ruby/gems/" - ruby-version))) + (out (assoc-ref outputs "out")) + (gem-home (string-append out "/lib/ruby/gems/" ruby-version))) (setenv "GEM_HOME" gem-home) (mkdir-p gem-home) (zero? (system* "gem" "install" "--local" - (first-matching-file "\\.gem$"))))) + (first-matching-file "\\.gem$") + ;; Executables should go into /bin, not /lib/ruby/gems. + "--bindir" (string-append out "/bin"))))) (define %standard-phases (modify-phases gnu:%standard-phases (delete configure) + (add-after unpack gitify gitify) (replace build build) (replace install install) (replace check check))) diff --git a/guix/http-client.scm b/guix/http-client.scm index aad7656e19..051fceecb5 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> -;;; Copyright © 2012 Free Software Foundation, Inc. +;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. ;;; @@ -55,7 +55,7 @@ (reason http-get-error-reason)) ; string -(define-syntax when-guile<=2.0.5 +(define-syntax when-guile<=2.0.5-or-otherwise-broken (lambda (s) (syntax-case s () ((_ body ...) @@ -64,12 +64,15 @@ ;; when using "guix pull". #'(begin body ...))))) -(when-guile<=2.0.5 - ;; Backport of Guile commit 312e79f8 ("Add HTTP Chunked Encoding support to - ;; web modules."). +(when-guile<=2.0.5-or-otherwise-broken + ;; Backport of Guile commits 312e79f8 ("Add HTTP Chunked Encoding support to + ;; web modules.") and 00d3ecf2 ("http: Do not buffer HTTP chunks.") (use-modules (ice-9 rdelim)) + (define %web-http + (resolve-module '(web http))) + ;; Chunked Responses (define (read-chunk-header port) (let* ((str (read-line port)) @@ -81,55 +84,57 @@ 16))) size)) - (define (read-chunk port) - (let ((size (read-chunk-header port))) - (read-chunk-body port size))) - - (define (read-chunk-body port size) - (let ((bv (get-bytevector-n port size))) - (get-u8 port) ; CR - (get-u8 port) ; LF - bv)) - (define* (make-chunked-input-port port #:key (keep-alive? #f)) "Returns a new port which translates HTTP chunked transfer encoded data from PORT into a non-encoded format. Returns eof when it has read the final chunk from PORT. This does not necessarily mean that there is no more data on PORT. When the returned port is closed it will also close PORT, unless the KEEP-ALIVE? is true." - (define (next-chunk) - (read-chunk port)) - (define finished? #f) (define (close) (unless keep-alive? (close-port port))) - (define buffer #vu8()) - (define buffer-size 0) - (define buffer-pointer 0) + + (define chunk-size 0) ;size of the current chunk + (define remaining 0) ;number of bytes left from the current chunk + (define finished? #f) ;did we get all the chunks? + (define (read! bv idx to-read) (define (loop to-read num-read) (cond ((or finished? (zero? to-read)) num-read) - ((<= to-read (- buffer-size buffer-pointer)) - (bytevector-copy! buffer buffer-pointer - bv (+ idx num-read) - to-read) - (set! buffer-pointer (+ buffer-pointer to-read)) - (loop 0 (+ num-read to-read))) - (else - (let ((n (- buffer-size buffer-pointer))) - (bytevector-copy! buffer buffer-pointer - bv (+ idx num-read) - n) - (set! buffer (next-chunk)) - (set! buffer-pointer 0) - (set! buffer-size (bytevector-length buffer)) - (set! finished? (= buffer-size 0)) - (loop (- to-read n) - (+ num-read n)))))) + ((zero? remaining) ;get a new chunk + (let ((size (read-chunk-header port))) + (set! chunk-size size) + (set! remaining size) + (if (zero? size) + (begin + (set! finished? #t) + num-read) + (loop to-read num-read)))) + (else ;read from the current chunk + (let* ((ask-for (min to-read remaining)) + (read (get-bytevector-n! port bv (+ idx num-read) + ask-for))) + (if (eof-object? read) + (begin ;premature termination + (set! finished? #t) + num-read) + (let ((left (- remaining read))) + (set! remaining left) + (when (zero? left) + ;; We're done with this chunk; read CR and LF. + (get-u8 port) (get-u8 port)) + (loop (- to-read read) + (+ num-read read)))))))) (loop to-read 0)) + (make-custom-binary-input-port "chunked input port" read! #f #f close)) + ;; Chunked encoding support in Guile <= 2.0.11 would load whole chunks in + ;; memory---see <http://bugs.gnu.org/19939>. + (when (module-variable %web-http 'read-chunk-body) + (module-set! %web-http 'make-chunked-input-port make-chunked-input-port)) + (define (read-response-body* r) "Reads the response body from @var{r}, as a bytevector. Returns @code{#f} if there was no response body." diff --git a/guix/profiles.scm b/guix/profiles.scm index a0a259bd4e..5ceba25def 100644 --- a/guix/profiles.scm +++ b/guix/profiles.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> ;;; Copyright © 2014 Alex Kost <alezost@gmail.com> +;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -413,23 +414,87 @@ MANIFEST." (gexp->derivation "info-dir" build #:modules '((guix build utils))))) -(define* (profile-derivation manifest #:key (info-dir? #t)) +(define (ca-certificate-bundle manifest) + "Return a derivation that builds a single-file bundle containing the CA +certificates in the /etc/ssl/certs sub-directories of the packages in +MANIFEST. Single-file bundles are required by programs such as Git and Lynx." + ;; See <http://lists.gnu.org/archive/html/guix-devel/2015-02/msg00429.html> + ;; for a discussion. + + (define glibc-utf8-locales ;lazy reference + (module-ref (resolve-interface '(gnu packages base)) 'glibc-utf8-locales)) + + (define build + #~(begin + (use-modules (guix build utils) + (rnrs io ports) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 ftw)) + + (define (pem-file? file) + (string-suffix? ".pem" file)) + + (define (ca-files top) + (let ((cert-dir (string-append top "/etc/ssl/certs"))) + (map (cut string-append cert-dir "/" <>) + (or (scandir cert-dir pem-file?) '())))) + + (define (concatenate-files files result) + "Make RESULT the concatenation of all of FILES." + (define (dump file port) + (display (call-with-input-file file get-string-all) + port) + (newline port)) ;required, see <https://bugs.debian.org/635570> + + (call-with-output-file result + (lambda (port) + (for-each (cut dump <> port) files)))) + + ;; Some file names in the NSS certificates are UTF-8 encoded so + ;; install a UTF-8 locale. + (setenv "LOCPATH" (string-append #+glibc-utf8-locales "/lib/locale")) + (setlocale LC_ALL "en_US.UTF-8") + + (let ((ca-files (append-map ca-files + '#$(manifest-inputs manifest))) + (result (string-append #$output "/etc/ssl/certs"))) + (mkdir-p result) + (concatenate-files ca-files + (string-append result + "/ca-certificates.crt"))))) + + (gexp->derivation "ca-certificate-bundle" build + #:modules '((guix build utils)) + #:local-build? #t)) + +(define* (profile-derivation manifest + #:key + (info-dir? #t) + (ca-certificate-bundle? #t)) "Return a derivation that builds a profile (aka. 'user environment') with -the given MANIFEST. The profile includes a top-level Info 'dir' file, unless -INFO-DIR? is #f." +the given MANIFEST. The profile includes a top-level Info 'dir' file unless +INFO-DIR? is #f, and a single-file CA certificate bundle unless +CA-CERTIFICATE-BUNDLE? is #f." (mlet %store-monad ((info-dir (if info-dir? (info-dir-file manifest) - (return #f)))) + (return #f))) + (ca-cert-bundle (if ca-certificate-bundle? + (ca-certificate-bundle manifest) + (return #f)))) (define inputs - (if info-dir - ;; XXX: Here we use the tuple (INFO-DIR "out") just so that the list - ;; is unambiguous for the gexp code when MANIFEST has a single input - ;; denoted as a string (the pattern (DRV STRING) is normally - ;; interpreted in a gexp as "the STRING output of DRV".). See - ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>. - (cons (list info-dir "out") - (manifest-inputs manifest)) - (manifest-inputs manifest))) + ;; XXX: Here we use tuples of the form (DIR "out") just so that the list + ;; is unambiguous for the gexp code when MANIFEST has a single input + ;; denoted as a string (the pattern (DRV STRING) is normally + ;; interpreted in a gexp as "the STRING output of DRV".). See + ;; <http://lists.gnu.org/archive/html/guix-devel/2014-12/msg00292.html>. + (append (if info-dir + `((,info-dir "out")) + '()) + (if ca-cert-bundle + `((,ca-cert-bundle "out")) + '()) + (manifest-inputs manifest))) (define builder #~(begin |