Merge remote-tracking branch 'origin/master' into core-updates
This commit is contained in:
commit
0371b345e8
|
@ -1,6 +1,6 @@
|
|||
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
|
||||
|
||||
(define script-version "2016-04-03.12") ;UTC
|
||||
(define script-version "2017-03-22.13") ;UTC
|
||||
|
||||
;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
|
||||
;;;
|
||||
|
@ -59,7 +59,7 @@ The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
|
|||
(begin
|
||||
(format port "~A:~%" field)
|
||||
(pretty-print value port #:per-line-prefix "+ "))
|
||||
(format port "~A: ~A~%" field value)))
|
||||
(format port "~A: ~S~%" field value)))
|
||||
|
||||
(define* (result->string symbol #:key colorize?)
|
||||
"Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
|
||||
|
@ -85,10 +85,10 @@ current output port is supposed to be redirected to a '.log' file."
|
|||
;; Procedure called at the start of an individual test case, before the
|
||||
;; test expression (and expected value) are evaluated.
|
||||
(let ((result (cute assq-ref (test-result-alist runner) <>)))
|
||||
(test-display "test-name" (result 'test-name))
|
||||
(test-display "location"
|
||||
(string-append (result 'source-file) ":"
|
||||
(number->string (result 'source-line))))
|
||||
(format #t "test-name: ~A~%" (result 'test-name))
|
||||
(format #t "location: ~A~%"
|
||||
(string-append (result 'source-file) ":"
|
||||
(number->string (result 'source-line))))
|
||||
(test-display "source" (result 'source-form) #:pretty? #t)))
|
||||
|
||||
(define (test-on-test-end-gnu runner)
|
||||
|
@ -99,10 +99,9 @@ current output port is supposed to be redirected to a '.log' file."
|
|||
(result (cut assq-ref results <>)))
|
||||
(unless brief?
|
||||
;; Display the result of each test case on the console.
|
||||
(test-display
|
||||
(result->string (test-result-kind runner) #:colorize? color?)
|
||||
(string-append test-name " - " (test-runner-test-name runner))
|
||||
out-port))
|
||||
(format out-port "~A: ~A - ~A~%"
|
||||
(result->string (test-result-kind runner) #:colorize? color?)
|
||||
test-name (test-runner-test-name runner)))
|
||||
(when (result? 'expected-value)
|
||||
(test-display "expected-value" (result 'expected-value)))
|
||||
(when (result? 'expected-error)
|
||||
|
@ -111,12 +110,11 @@ current output port is supposed to be redirected to a '.log' file."
|
|||
(test-display "actual-value" (result 'actual-value)))
|
||||
(when (result? 'actual-error)
|
||||
(test-display "actual-error" (result 'actual-error) #:pretty? #t))
|
||||
(test-display "result" (result->string (result 'result-kind)))
|
||||
(format #t "result: ~a~%" (result->string (result 'result-kind)))
|
||||
(newline)
|
||||
(test-display ":test-result"
|
||||
(string-append (result->string (test-result-kind runner))
|
||||
" " (test-runner-test-name runner))
|
||||
trs-port)))
|
||||
(format trs-port ":test-result: ~A ~A~%"
|
||||
(result->string (test-result-kind runner))
|
||||
(test-runner-test-name runner))))
|
||||
|
||||
(define (test-on-group-end-gnu runner)
|
||||
;; Procedure called by a 'test-end', including at the end of a test-group.
|
||||
|
@ -125,21 +123,18 @@ current output port is supposed to be redirected to a '.log' file."
|
|||
(skip (or (positive? (test-runner-skip-count runner))
|
||||
(positive? (test-runner-xfail-count runner)))))
|
||||
;; XXX: The global results need some refinements for XPASS.
|
||||
(test-display ":global-test-result"
|
||||
(if fail "FAIL" (if skip "SKIP" "PASS"))
|
||||
trs-port)
|
||||
(test-display ":recheck"
|
||||
(if fail "yes" "no")
|
||||
trs-port)
|
||||
(test-display ":copy-in-global-log"
|
||||
(if (or fail skip) "yes" "no")
|
||||
trs-port)
|
||||
(format trs-port ":global-test-result: ~A~%"
|
||||
(if fail "FAIL" (if skip "SKIP" "PASS")))
|
||||
(format trs-port ":recheck: ~A~%"
|
||||
(if fail "yes" "no"))
|
||||
(format trs-port ":copy-in-global-log: ~A~%"
|
||||
(if (or fail skip) "yes" "no"))
|
||||
(when brief?
|
||||
;; Display the global test group result on the console.
|
||||
(test-display (result->string (if fail 'fail (if skip 'skip 'pass))
|
||||
#:colorize? color?)
|
||||
test-name
|
||||
out-port))
|
||||
(format out-port "~A: ~A~%"
|
||||
(result->string (if fail 'fail (if skip 'skip 'pass))
|
||||
#:colorize? color?)
|
||||
test-name))
|
||||
#f))
|
||||
|
||||
(let ((runner (test-runner-null)))
|
||||
|
|
|
@ -6523,6 +6523,26 @@ This allows the user's Guix to keep substitute information in cache for
|
|||
guarantee that the store items it provides will indeed remain available
|
||||
for as long as @var{ttl}.
|
||||
|
||||
@item --nar-path=@var{path}
|
||||
Use @var{path} as the prefix for the URLs of ``nar'' files
|
||||
(@pxref{Invoking guix archive, normalized archives}).
|
||||
|
||||
By default, nars are served at a URL such as
|
||||
@code{/nar/gzip/@dots{}-coreutils-8.25}. This option allows you to
|
||||
change the @code{/nar} part to @var{path}.
|
||||
|
||||
@item --public-key=@var{file}
|
||||
@itemx --private-key=@var{file}
|
||||
Use the specific @var{file}s as the public/private key pair used to sign
|
||||
the store items being published.
|
||||
|
||||
The files must correspond to the same key pair (the private key is used
|
||||
for signing and the public key is merely advertised in the signature
|
||||
metadata). They must contain keys in the canonical s-expression format
|
||||
as produced by @command{guix archive --generate-key} (@pxref{Invoking
|
||||
guix archive}). By default, @file{/etc/guix/signing-key.pub} and
|
||||
@file{/etc/guix/signing-key.sec} are used.
|
||||
|
||||
@item --repl[=@var{port}]
|
||||
@itemx -r [@var{port}]
|
||||
Spawn a Guile REPL server (@pxref{REPL Servers,,, guile, GNU Guile
|
||||
|
|
|
@ -506,7 +506,7 @@ dist_patch_DATA = \
|
|||
%D%/packages/patches/calibre-drop-unrar.patch \
|
||||
%D%/packages/patches/calibre-no-updates-dialog.patch \
|
||||
%D%/packages/patches/cdparanoia-fpic.patch \
|
||||
%D%/packages/patches/chicken-CVE-2016-6830+CVE-2016-6831.patch \
|
||||
%D%/packages/patches/chicken-CVE-2017-6949.patch \
|
||||
%D%/packages/patches/chmlib-inttypes.patch \
|
||||
%D%/packages/patches/clang-libc-search-path.patch \
|
||||
%D%/packages/patches/clang-3.8-libc-search-path.patch \
|
||||
|
|
|
@ -165,7 +165,7 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
|
|||
(define-public autoconf-archive
|
||||
(package
|
||||
(name "autoconf-archive")
|
||||
(version "2016.09.16")
|
||||
(version "2017.03.21")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -173,7 +173,7 @@ exec ~a --no-auto-compile \"$0\" \"$@\"
|
|||
version ".tar.xz"))
|
||||
(sha256
|
||||
(base32
|
||||
"10mxz9hfnfz66m1l9s28sbyfb9a04akz92wkyv9blhpq6p9fzwp8"))))
|
||||
"0rfpapadka2023qhy8294ca5awxpb8d4904js6kv7piby5ax8siq"))))
|
||||
(build-system gnu-build-system)
|
||||
(home-page "https://www.gnu.org/software/autoconf-archive")
|
||||
(synopsis "Collection of freely reusable Autoconf macros")
|
||||
|
|
|
@ -5051,7 +5051,7 @@ application of SortMeRNA is filtering rRNA from metatranscriptomic data.")
|
|||
(define-public star
|
||||
(package
|
||||
(name "star")
|
||||
(version "2.5.2b")
|
||||
(version "2.5.3a")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "https://github.com/alexdobin/STAR/archive/"
|
||||
|
@ -5059,7 +5059,7 @@ application of SortMeRNA is filtering rRNA from metatranscriptomic data.")
|
|||
(file-name (string-append name "-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1na6np880r1zaamiy00hy8bid5anpy0kgf63587v2yl080krk2zq"))
|
||||
"013wirlz8lllgjyagl48l75n1isxyabqb3sj7qlsl0x1rmvqw99a"))
|
||||
(modules '((guix build utils)))
|
||||
(snippet
|
||||
'(begin
|
||||
|
|
|
@ -596,7 +596,7 @@ decompression of some loosely related file formats used by Microsoft.")
|
|||
(define-public perl-compress-raw-bzip2
|
||||
(package
|
||||
(name "perl-compress-raw-bzip2")
|
||||
(version "2.068")
|
||||
(version "2.074")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -604,7 +604,7 @@ decompression of some loosely related file formats used by Microsoft.")
|
|||
"Compress-Raw-Bzip2-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"16hl58xppckldz05zdyid1l5gpaykzwvkq682h3rc3nilbhgjqqg"))))
|
||||
"0b5jwqf15zr787acnx8sfyy2zavdd7gfkd98n1dgy8fs6r8yb8a4"))))
|
||||
(build-system perl-build-system)
|
||||
;; TODO: Use our bzip2 package.
|
||||
(home-page "http://search.cpan.org/dist/Compress-Raw-Bzip2")
|
||||
|
@ -616,7 +616,7 @@ compression library.")
|
|||
(define-public perl-compress-raw-zlib
|
||||
(package
|
||||
(name "perl-compress-raw-zlib")
|
||||
(version "2.068")
|
||||
(version "2.074")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -624,7 +624,7 @@ compression library.")
|
|||
"Compress-Raw-Zlib-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"06q7n87g26nn5gv4z2p31ca32f6zk124hqxc25rfgkjd3qi5798i"))))
|
||||
"08bpx9v6i40n54rdcj6invlj294z20amrl8wvwf9b83aldwdwsd3"))))
|
||||
(build-system perl-build-system)
|
||||
(inputs
|
||||
`(("zlib" ,zlib)))
|
||||
|
@ -651,7 +651,7 @@ compression library.")
|
|||
(define-public perl-io-compress
|
||||
(package
|
||||
(name "perl-io-compress")
|
||||
(version "2.068")
|
||||
(version "2.074")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -659,11 +659,11 @@ compression library.")
|
|||
"IO-Compress-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"0dy0apjp7j9dfkzfjspjd3z9gh26srx5vac72g59bkkz1jf8s1gs"))))
|
||||
"1wlpy2026djfmq0bjync531yq6s695jf7bcnpvjphrasi776igdl"))))
|
||||
(build-system perl-build-system)
|
||||
(propagated-inputs
|
||||
`(("perl-compress-raw-zlib" ,perl-compress-raw-zlib) ; >=2.068
|
||||
("perl-compress-raw-bzip2" ,perl-compress-raw-bzip2))) ; >=2.068
|
||||
`(("perl-compress-raw-zlib" ,perl-compress-raw-zlib) ; >=2.074
|
||||
("perl-compress-raw-bzip2" ,perl-compress-raw-bzip2))) ; >=2.074
|
||||
(home-page "http://search.cpan.org/dist/IO-Compress")
|
||||
(synopsis "IO Interface to compressed files/buffers")
|
||||
(description "IO-Compress provides a Perl interface to allow reading and
|
||||
|
|
|
@ -732,6 +732,7 @@ simulator.")
|
|||
(uri (git-reference
|
||||
(url "https://github.com/puppeh/binutils-vc4.git")
|
||||
(commit commit)))
|
||||
(file-name (string-append name "-" version "-checkout"))
|
||||
(sha256
|
||||
(base32
|
||||
"1kdrz6fki55lm15rwwamn74fnqpy0zlafsida2zymk76n3656c63"))))
|
||||
|
|
|
@ -247,6 +247,9 @@ without requiring the source code to be rewritten.")
|
|||
(files '("lib/guile/2.2/site-ccache"
|
||||
"share/guile/site/2.2")))))))
|
||||
|
||||
(define-public guile-next
|
||||
(deprecated-package "guile-next" guile-2.2))
|
||||
|
||||
(define (guile-variant-package-name prefix)
|
||||
(lambda (name)
|
||||
"Return NAME with PREFIX instead of \"guile-\", when applicable."
|
||||
|
|
|
@ -9,6 +9,7 @@
|
|||
;;; Copyright © 2015, 2016, 2017 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;; Copyright © 2016, 2017 David Craven <david@craven.ch>
|
||||
;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
|
||||
;;; Copyright © 2017 Peter Mikkelsen <petermikkelsen10@gmail.com>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -562,6 +563,27 @@ package.")
|
|||
package.")
|
||||
(license license:bsd-3)))
|
||||
|
||||
(define-public ghc-code-page
|
||||
(package
|
||||
(name "ghc-code-page")
|
||||
(version "0.1.3")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (string-append
|
||||
"https://hackage.haskell.org/package/code-page/code-page-"
|
||||
version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1491frk4jx6dlhifky9dvcxbsbcfssrz979a5hp5zn061rh8cp76"))))
|
||||
(build-system haskell-build-system)
|
||||
(home-page "https://github.com/RyanGlScott/code-page")
|
||||
(synopsis "Windows code page library for Haskell")
|
||||
(description "A cross-platform library with functions for adjusting
|
||||
code pages on Windows. On all other operating systems, the library does
|
||||
nothing.")
|
||||
(license license:bsd-3)))
|
||||
|
||||
(define-public ghc-haddock-library
|
||||
(package
|
||||
(name "ghc-haddock-library")
|
||||
|
|
|
@ -31,7 +31,7 @@
|
|||
(define-public idris
|
||||
(package
|
||||
(name "idris")
|
||||
(version "0.99")
|
||||
(version "0.99.1")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append
|
||||
|
@ -39,7 +39,7 @@
|
|||
"idris-" version "/idris-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1sd4vy5rx0mp32xj99qijhknkgw4d2rxvz6wiy3pym6kaqmc497i"))))
|
||||
"12kw452arnl5ldip2x749j5np3l40bv7asqdv9w0f60j45hii40r"))))
|
||||
(build-system haskell-build-system)
|
||||
(inputs
|
||||
`(("gmp" ,gmp)
|
||||
|
@ -53,6 +53,7 @@
|
|||
("ghc-blaze-html" ,ghc-blaze-html)
|
||||
("ghc-blaze-markup" ,ghc-blaze-markup)
|
||||
("ghc-cheapskate" ,ghc-cheapskate)
|
||||
("ghc-code-page" ,ghc-code-page)
|
||||
("ghc-fingertree" ,ghc-fingertree)
|
||||
("ghc-fsnotify" ,ghc-fsnotify)
|
||||
("ghc-ieee754" ,ghc-ieee754)
|
||||
|
|
|
@ -36,6 +36,7 @@
|
|||
":pserver:anonymous@cvs.savannah.gnu.org:/sources/libffcall")
|
||||
(module "ffcall")
|
||||
(revision "2015-01-15")))
|
||||
(file-name (string-append name "-" version "-checkout"))
|
||||
(sha256
|
||||
(base32
|
||||
"1lwdskc2w4rr98x9flr2726lmj4190l16r0izg7gqxy50801wwgd"))))
|
||||
|
|
|
@ -1080,7 +1080,7 @@ facilities for checking incoming mail.")
|
|||
(define-public dovecot
|
||||
(package
|
||||
(name "dovecot")
|
||||
(version "2.2.27")
|
||||
(version "2.2.28")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -1088,7 +1088,7 @@ facilities for checking incoming mail.")
|
|||
(version-major+minor version) "/"
|
||||
name "-" version ".tar.gz"))
|
||||
(sha256 (base32
|
||||
"1s8qvr6fa9d0n179kdwgpsi72zkvpbh9q57q8fr2fjysgjl94zw9"))))
|
||||
"098zpkmkk93372qnv6drgbfg8hp5mynspzc1735qgar6wdcqya70"))))
|
||||
(build-system gnu-build-system)
|
||||
(native-inputs
|
||||
`(("pkg-config" ,pkg-config)))
|
||||
|
|
|
@ -214,9 +214,9 @@ the Nix package manager.")
|
|||
;;
|
||||
;; Note: use a very short commit id; with a longer one, the limit on
|
||||
;; hash-bang lines would be exceeded while running the tests.
|
||||
(let ((commit "1162418ee88f155f6b14fd8926479c2176e40e76"))
|
||||
(let ((commit "73a46451af333c77d2e79aa8764f51be8c34d1ae"))
|
||||
(package (inherit guix-0.12.0)
|
||||
(version (string-append "0.12.0-5." (string-take commit 4)))
|
||||
(version (string-append "0.12.0-6." (string-take commit 4)))
|
||||
(source (origin
|
||||
(method git-fetch)
|
||||
(uri (git-reference
|
||||
|
@ -226,7 +226,7 @@ the Nix package manager.")
|
|||
(commit commit)))
|
||||
(sha256
|
||||
(base32
|
||||
"16pxqbywhayazdgg9l19frigncmyq20j5fvaq4zgvm0iidndhfja"))
|
||||
"1zfa6c1vf52rg7ba1nrz4hzgdwl16brc4iylcdnhl9mnkjg2fbr5"))
|
||||
(file-name (string-append "guix-" version "-checkout"))))
|
||||
(arguments
|
||||
(substitute-keyword-arguments (package-arguments guix-0.12.0)
|
||||
|
|
|
@ -1,81 +0,0 @@
|
|||
diff -ur a/irregex-core.scm b/irregex-core.scm
|
||||
--- a/irregex-core.scm 2016-09-11 19:03:00.000000000 -0400
|
||||
+++ b/irregex-core.scm 2017-01-01 22:24:08.000000000 -0500
|
||||
@@ -30,6 +30,8 @@
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;;; History
|
||||
+;; 0.9.6: 2016/12/05 - fixed exponential memory use of + in compilation
|
||||
+;; of backtracking matcher.
|
||||
;; 0.9.5: 2016/09/10 - fixed a bug in irregex-fold handling of bow
|
||||
;; 0.9.4: 2015/12/14 - performance improvement for {n,m} matches
|
||||
;; 0.9.3: 2014/07/01 - R7RS library
|
||||
@@ -3170,16 +3172,7 @@
|
||||
((sre-empty? (sre-sequence (cdr sre)))
|
||||
(error "invalid sre: empty *" sre))
|
||||
(else
|
||||
- (letrec
|
||||
- ((body
|
||||
- (lp (sre-sequence (cdr sre))
|
||||
- n
|
||||
- flags
|
||||
- (lambda (cnk init src str i end matches fail)
|
||||
- (body cnk init src str i end matches
|
||||
- (lambda ()
|
||||
- (next cnk init src str i end matches fail)
|
||||
- ))))))
|
||||
+ (let ((body (rec (list '+ (sre-sequence (cdr sre))))))
|
||||
(lambda (cnk init src str i end matches fail)
|
||||
(body cnk init src str i end matches
|
||||
(lambda ()
|
||||
@@ -3204,10 +3197,21 @@
|
||||
(lambda ()
|
||||
(body cnk init src str i end matches fail))))))))
|
||||
((+)
|
||||
- (lp (sre-sequence (cdr sre))
|
||||
- n
|
||||
- flags
|
||||
- (rec (list '* (sre-sequence (cdr sre))))))
|
||||
+ (cond
|
||||
+ ((sre-empty? (sre-sequence (cdr sre)))
|
||||
+ (error "invalid sre: empty +" sre))
|
||||
+ (else
|
||||
+ (letrec
|
||||
+ ((body
|
||||
+ (lp (sre-sequence (cdr sre))
|
||||
+ n
|
||||
+ flags
|
||||
+ (lambda (cnk init src str i end matches fail)
|
||||
+ (body cnk init src str i end matches
|
||||
+ (lambda ()
|
||||
+ (next cnk init src str i end matches fail)
|
||||
+ ))))))
|
||||
+ body))))
|
||||
((=)
|
||||
(rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
|
||||
((>=)
|
||||
diff -ur a/irregex-utils.scm b/irregex-utils.scm
|
||||
--- a/irregex-utils.scm 2016-09-11 19:03:00.000000000 -0400
|
||||
+++ b/irregex-utils.scm 2017-01-01 22:25:25.000000000 -0500
|
||||
@@ -89,7 +89,7 @@
|
||||
(case (car x)
|
||||
((: seq)
|
||||
(cond
|
||||
- ((and (pair? (cddr x)) (pair? (cddr x)) (not (eq? x obj)))
|
||||
+ ((and (pair? (cdr x)) (pair? (cddr x)) (not (eq? x obj)))
|
||||
(display "(?:" out) (for-each lp (cdr x)) (display ")" out))
|
||||
(else (for-each lp (cdr x)))))
|
||||
((submatch)
|
||||
diff -ur "a/manual-html/Unit irregex.html" "b/manual-html/Unit irregex.html"
|
||||
--- "a/manual-html/Unit irregex.html" 2016-09-11 19:10:47.000000000 -0400
|
||||
+++ "b/manual-html/Unit irregex.html" 2017-01-01 22:26:05.000000000 -0500
|
||||
@@ -353,6 +353,6 @@
|
||||
<dd class="defsig"><p>Returns an optimized SRE matching any of the literal strings in the list, like Emacs' <tt>regexp-opt</tt>. Note this optimization doesn't help when irregex is able to build a DFA.</p></dd>
|
||||
</dl>
|
||||
<h5 id="sec:sre-.3estring"><a href="#sec:sre-.3estring">sre->string</a></h5><dl class="defsig"><dt class="defsig" id="def:sre-.3estring"><span class="sig"><tt>(sre->string <sre>)</tt></span> <span class="type">procedure</span></dt>
|
||||
-<dd class="defsig"><p>Convert an SRE to a POSIX-style regular expression string, if possible.</p></dd>
|
||||
+<dd class="defsig"><p>Convert an SRE to a PCRE-style regular expression string, if possible.</p></dd>
|
||||
</dl>
|
||||
-<hr /><p>Previous: <a href="Unit%20extras.html">Unit extras</a></p><p>Next: <a href="Unit%20srfi-1.html">Unit srfi-1</a></p></div></div></body>
|
||||
\ No newline at end of file
|
||||
+<hr /><p>Previous: <a href="Unit%20extras.html">Unit extras</a></p><p>Next: <a href="Unit%20srfi-1.html">Unit srfi-1</a></p></div></div></body>
|
|
@ -0,0 +1,132 @@
|
|||
From: LemonBoy <thatlemon@gmail.com>
|
||||
Date: Fri, 10 Mar 2017 16:29:47 +0100
|
||||
Subject: [PATCH] Add bound checking to all srfi-4 vector allocations.
|
||||
|
||||
Do what C_allocate_vector already does and prevent the creation of a
|
||||
vector that's too big or too small.
|
||||
We should be very careful to avoid the latter case because the
|
||||
allocation size is directly fed into `malloc' as 'x + sizeof(C_header)'
|
||||
thus making possible to successfully allocate a vector smaller than the
|
||||
C_header structure and get C_block_header_init to write over
|
||||
uninitialized memory.
|
||||
|
||||
To reduce code duplication, type checking is moved from each of the
|
||||
make-*vector procedures to the common "alloc" helper procedure.
|
||||
|
||||
Signed-off-by: Peter Bex <peter@more-magic.net>
|
||||
Signed-off-by: Kooda <kooda@upyum.com>
|
||||
---
|
||||
srfi-4.scm | 34 +++++++++++++++-------------------
|
||||
1 file changed, 15 insertions(+), 19 deletions(-)
|
||||
|
||||
diff --git a/srfi-4.scm b/srfi-4.scm
|
||||
index 7f5412b..69f58ba 100644
|
||||
--- a/srfi-4.scm
|
||||
+++ b/srfi-4.scm
|
||||
@@ -255,24 +255,28 @@ EOF
|
||||
|
||||
;;; Basic constructors:
|
||||
|
||||
-(let* ([ext-alloc
|
||||
- (foreign-lambda* scheme-object ([int bytes])
|
||||
- "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
|
||||
+(let* ((ext-alloc
|
||||
+ (foreign-lambda* scheme-object ((size_t bytes))
|
||||
+ "C_word *buf;"
|
||||
+ "if (bytes > C_HEADER_SIZE_MASK) C_return(C_SCHEME_FALSE);"
|
||||
+ "buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
|
||||
"if(buf == NULL) C_return(C_SCHEME_FALSE);"
|
||||
"C_block_header_init(buf, C_make_header(C_BYTEVECTOR_TYPE, bytes));"
|
||||
- "C_return(buf);") ]
|
||||
- [ext-free
|
||||
- (foreign-lambda* void ([scheme-object bv])
|
||||
- "C_free((void *)C_block_item(bv, 1));") ]
|
||||
- [alloc
|
||||
+ "C_return(buf);") )
|
||||
+ (ext-free
|
||||
+ (foreign-lambda* void ((scheme-object bv))
|
||||
+ "C_free((void *)C_block_item(bv, 1));") )
|
||||
+ (alloc
|
||||
(lambda (loc len ext?)
|
||||
+ (##sys#check-exact len loc)
|
||||
+ (when (fx< len 0) (##sys#error loc "size is negative" len))
|
||||
(if ext?
|
||||
- (let ([bv (ext-alloc len)])
|
||||
+ (let ((bv (ext-alloc len)))
|
||||
(or bv
|
||||
(##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
|
||||
- (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better...
|
||||
+ (let ((bv (##sys#allocate-vector len #t #f #t))) ; this could be made better...
|
||||
(##core#inline "C_string_to_bytevector" bv)
|
||||
- bv) ) ) ] )
|
||||
+ bv) ) ) ) )
|
||||
|
||||
(set! release-number-vector
|
||||
(lambda (v)
|
||||
@@ -282,7 +286,6 @@ EOF
|
||||
|
||||
(set! make-u8vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-u8vector)
|
||||
(let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -295,7 +298,6 @@ EOF
|
||||
|
||||
(set! make-s8vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-s8vector)
|
||||
(let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -308,7 +310,6 @@ EOF
|
||||
|
||||
(set! make-u16vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-u16vector)
|
||||
(let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -321,7 +322,6 @@ EOF
|
||||
|
||||
(set! make-s16vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-s16vector)
|
||||
(let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -334,7 +334,6 @@ EOF
|
||||
|
||||
(set! make-u32vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-u32vector)
|
||||
(let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -347,7 +346,6 @@ EOF
|
||||
|
||||
(set! make-s32vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-s32vector)
|
||||
(let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -360,7 +358,6 @@ EOF
|
||||
|
||||
(set! make-f32vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-f32vector)
|
||||
(let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
|
||||
(when (and ext? fin?) (set-finalizer! v ext-free))
|
||||
(if (not init)
|
||||
@@ -375,7 +372,6 @@ EOF
|
||||
|
||||
(set! make-f64vector
|
||||
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
|
||||
- (##sys#check-exact len 'make-f64vector)
|
||||
(let ((v (##sys#make-structure
|
||||
'f64vector
|
||||
(alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
|
||||
--
|
||||
2.1.4
|
||||
|
|
@ -26,7 +26,7 @@
|
|||
(define-public perl-mojolicious
|
||||
(package
|
||||
(name "perl-mojolicious")
|
||||
(version "7.10")
|
||||
(version "7.29")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -34,7 +34,7 @@
|
|||
version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"0811f3wajgf71y02dr2khqnaswjh582pcvhv93k101qpg61syihn"))))
|
||||
"1kmyb9axqbklyvr3l4d6mxnb0r97s9hzn7jpzksgckklp1ic8sqh"))))
|
||||
(build-system perl-build-system)
|
||||
(home-page "http://mojolicious.org/")
|
||||
(synopsis "Real-time web framework")
|
||||
|
|
|
@ -1725,14 +1725,14 @@ standard library.")
|
|||
(define-public python-pafy
|
||||
(package
|
||||
(name "python-pafy")
|
||||
(version "0.5.2")
|
||||
(version "0.5.3.1")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "pafy" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1ckvrypyvb7jbqlgwdz0y337ajagjv7dgxyns326nqwypn1wpq0i"))))
|
||||
"1a7dxi95m1043rxx1r5x3ngb66nwlq6aqcasyqqjzmmmjps4zrim"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
`(#:tests? #f)) ; Currently pafy can not find itself in the tests
|
||||
|
@ -4372,14 +4372,14 @@ both of which are installed automatically if you install this library.")
|
|||
(define-public python-sqlalchemy-utils
|
||||
(package
|
||||
(name "python-sqlalchemy-utils")
|
||||
(version "0.32.11")
|
||||
(version "0.32.13")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "SQLAlchemy-Utils" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1wghyvk73cmq3iqyg3fczw128fv2pan2v76m0xg1bw05h8fhvnk3"))))
|
||||
"0vsib7gidjamzsz6w4s5pdhxzxsrkghjnm4sqwk94igjrl3i5ixj"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
'(#:tests? #f)) ; FIXME: Many tests require a running database server.
|
||||
|
@ -4796,7 +4796,7 @@ etc. The core of this module is a decorator factory.")
|
|||
(define-public python-drmaa
|
||||
(package
|
||||
(name "python-drmaa")
|
||||
(version "0.7.6")
|
||||
(version "0.7.7")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -4804,7 +4804,7 @@ etc. The core of this module is a decorator factory.")
|
|||
"https://pypi.python.org/packages/source/d/drmaa/drmaa-"
|
||||
version ".tar.gz"))
|
||||
(sha256
|
||||
(base32 "0bzl9f9g34dlhwf09i3fdv7dqqzf2iq0w7d6c2bafx1nlap8qfbh"))))
|
||||
(base32 "0xzqriqyvk5b8hszbavsyxd29wm3sxirm8zvvdm73rs2iq7w4hkx"))))
|
||||
(build-system python-build-system)
|
||||
;; The test suite requires libdrmaa which is provided by the cluster
|
||||
;; environment. At runtime the environment variable DRMAA_LIBRARY_PATH
|
||||
|
@ -5666,14 +5666,14 @@ libxml2 and libxslt.")
|
|||
(define-public python-beautifulsoup4
|
||||
(package
|
||||
(name "python-beautifulsoup4")
|
||||
(version "4.5.1")
|
||||
(version "4.5.3")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "beautifulsoup4" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1qgmhw65ncsgccjhslgkkszif47q6gvxwqv4mim17agxd81p951w"))))
|
||||
"0glaw1vyxnbp03fni7h5496n6iib0n5iim4gax1n0ngscs9s075j"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
`(#:phases
|
||||
|
@ -6742,7 +6742,7 @@ provided that can be used to do various manipulations with LilyPond files.")
|
|||
(define-public python-appdirs
|
||||
(package
|
||||
(name "python-appdirs")
|
||||
(version "1.4.0")
|
||||
(version "1.4.3")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
|
@ -6752,7 +6752,7 @@ provided that can be used to do various manipulations with LilyPond files.")
|
|||
".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1iddva7v3fq0aqzsahkazxr7vpw28mqcrsy818z4wyiqnkplbhlg"))))
|
||||
"14id6wxi12lgyw0mg3bcfnf888ad07jz9yj46gfzhn186z8rcn4y"))))
|
||||
(build-system python-build-system)
|
||||
(home-page "http://github.com/ActiveState/appdirs")
|
||||
(synopsis
|
||||
|
@ -7126,13 +7126,13 @@ implementations of ASN.1-based codecs and protocols.")
|
|||
(define-public python-ipaddress
|
||||
(package
|
||||
(name "python-ipaddress")
|
||||
(version "1.0.16")
|
||||
(version "1.0.18")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "ipaddress" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1c3imabdrw8nfksgjjflzg7h4ynjckqacb188rf541m74arq4cas"))))
|
||||
"1q8klj9d84cmxgz66073x1j35cplr3r77vx1znhxiwl5w74391ax"))))
|
||||
(build-system python-build-system)
|
||||
(home-page "https://github.com/phihag/ipaddress")
|
||||
(synopsis "IP address manipulation library")
|
||||
|
@ -8994,14 +8994,14 @@ Python at your fingertips, in Lisp form.")
|
|||
(define-public python-rauth
|
||||
(package
|
||||
(name "python-rauth")
|
||||
(version "0.7.2")
|
||||
(version "0.7.3")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "rauth" version))
|
||||
(sha256
|
||||
(base32
|
||||
"00pq7zw429hhza9c0qzxiqp77m653jv09z92nralnmzwdf6pzicf"))))
|
||||
"02kv8w8l98ky223avyq7vw7x1f2ya9chrm59r77ylq45qb0xnk2j"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
`(#:test-target "check"))
|
||||
|
@ -9090,14 +9090,14 @@ otherwise matches 3.2’s API.")
|
|||
(define-public python2-futures
|
||||
(package
|
||||
(name "python2-futures")
|
||||
(version "3.0.3")
|
||||
(version "3.0.5")
|
||||
(source
|
||||
(origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "futures" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1vcb34dqhzkhbq1957vdjszhhm5y3j9ba88dgwhqx2zynhmk9qig"))))
|
||||
"1pw1z4329xvlabdpwqa6b7v2fxf7hl64m4cgr22ckbym8m8m4hh5"))))
|
||||
(build-system python-build-system)
|
||||
(arguments `(#:python ,python-2))
|
||||
(home-page "https://github.com/agronholm/pythonfutures")
|
||||
|
@ -12294,13 +12294,13 @@ failures.")
|
|||
(define-public python-natsort
|
||||
(package
|
||||
(name "python-natsort")
|
||||
(version "5.0.1")
|
||||
(version "5.0.2")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (pypi-uri "natsort" version))
|
||||
(sha256
|
||||
(base32
|
||||
"1abld5p4a6n5zjnyw5mi2pv37gqalcybv2brjr2y6l9l2p8v9mja"))))
|
||||
"0bh6j0l8iapjnsgg3bs6q075cnzjl6zw1vlgqyv3qrygm2cxypkn"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
`(#:phases
|
||||
|
|
|
@ -229,18 +229,21 @@ rustc-bootstrap and cargo-bootstrap packages.")
|
|||
(("/usr/bin/env") (which "env")))
|
||||
;; Avoid curl as a build dependency.
|
||||
(substitute* "configure"
|
||||
(("probe_need CFG_CURL curl") ""))))
|
||||
(("probe_need CFG_CURL curl") ""))
|
||||
#t))
|
||||
(add-after 'unpack 'set-env
|
||||
(lambda _
|
||||
(setenv "SHELL" (which "sh"))
|
||||
(setenv "CONFIG_SHELL" (which "sh"))))
|
||||
(setenv "CONFIG_SHELL" (which "sh"))
|
||||
#t))
|
||||
(add-after 'unpack 'patch-tests
|
||||
(lambda* (#:key inputs #:allow-other-keys)
|
||||
(substitute* "src/tools/tidy/src/main.rs"
|
||||
(("^.*cargo.*::check.*$") ""))
|
||||
(substitute* "src/libstd/process.rs"
|
||||
(("\"/bin/sh\"") (string-append "\"" (assoc-ref inputs "bash") "/bin/sh\"")))
|
||||
#t))
|
||||
(let ((bash (assoc-ref inputs "bash")))
|
||||
(substitute* "src/tools/tidy/src/main.rs"
|
||||
(("^.*cargo.*::check.*$") ""))
|
||||
(substitute* "src/libstd/process.rs"
|
||||
(("\"/bin/sh\"") (string-append "\"" bash "/bin/sh\"")))
|
||||
#t)))
|
||||
(replace 'configure
|
||||
(lambda* (#:key inputs outputs #:allow-other-keys)
|
||||
(let* ((out (assoc-ref outputs "out"))
|
||||
|
@ -275,7 +278,8 @@ rustc-bootstrap and cargo-bootstrap packages.")
|
|||
;; Let gcc find ld and libc startup files.
|
||||
(wrap-program (string-append out "/bin/rustc")
|
||||
`("PATH" ":" prefix (,(string-append ld-wrapper "/bin")))
|
||||
`("LIBRARY_PATH" ":" suffix (,(string-append libc "/lib"))))))))))
|
||||
`("LIBRARY_PATH" ":" suffix (,(string-append libc "/lib"))))
|
||||
#t))))))
|
||||
;; rustc invokes gcc, so we need to set its search paths accordingly.
|
||||
(native-search-paths (package-native-search-paths gcc))
|
||||
(synopsis "Compiler for the Rust progamming language")
|
||||
|
|
|
@ -325,18 +325,16 @@ mashups, office (web agendas, mail clients, ...), etc.")
|
|||
(define-public chicken
|
||||
(package
|
||||
(name "chicken")
|
||||
(version "4.11.1")
|
||||
(version "4.12.0")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "http://code.call-cc.org/releases/"
|
||||
(uri (string-append "https://code.call-cc.org/releases/"
|
||||
version "/chicken-" version ".tar.gz"))
|
||||
(uri (string-append "http://code.call-cc.org/dev-snapshots/"
|
||||
"2016/09/12/chicken-" version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"1rwymbbmnwdyhdzilv9w75an989xw9kjf3x52iqdng3nphpflcga"))
|
||||
"12b9gaa9lqh39lj1v4wm48f6z8ww3jdkvc5bh9gqqvn6kd2wwnk0"))
|
||||
(patches
|
||||
(search-patches "chicken-CVE-2016-6830+CVE-2016-6831.patch"))))
|
||||
(search-patches "chicken-CVE-2017-6949.patch"))))
|
||||
(build-system gnu-build-system)
|
||||
(arguments
|
||||
`(#:modules ((guix build gnu-build-system)
|
||||
|
@ -359,12 +357,6 @@ mashups, office (web agendas, mail clients, ...), etc.")
|
|||
|
||||
;; Parallel builds are not supported, as noted in README.
|
||||
#:parallel-build? #f))
|
||||
;; One of the tests ("testing direct invocation can detect calls of too
|
||||
;; many arguments...") times out when building with a more recent GCC.
|
||||
;; The problem was reported here:
|
||||
;; https://lists.gnu.org/archive/html/chicken-hackers/2015-04/msg00059.html
|
||||
(native-inputs
|
||||
`(("gcc" ,gcc-4.8)))
|
||||
(home-page "http://www.call-cc.org/")
|
||||
(synopsis "R5RS Scheme implementation that compiles native code via C")
|
||||
(description
|
||||
|
|
|
@ -984,7 +984,7 @@ access to mpv's powerful playback capabilities.")
|
|||
(define-public youtube-dl
|
||||
(package
|
||||
(name "youtube-dl")
|
||||
(version "2017.03.16")
|
||||
(version "2017.03.22")
|
||||
(source (origin
|
||||
(method url-fetch)
|
||||
(uri (string-append "https://yt-dl.org/downloads/"
|
||||
|
@ -992,7 +992,7 @@ access to mpv's powerful playback capabilities.")
|
|||
version ".tar.gz"))
|
||||
(sha256
|
||||
(base32
|
||||
"14nlgl0kh4mwl7sx58vd7nxr5iklxi00612lmydy91ngm6ykrpsm"))))
|
||||
"1zz97g23diggcnqg2hjq9grijskly8ag727f1i509hl7z0lxkh69"))))
|
||||
(build-system python-build-system)
|
||||
(arguments
|
||||
;; The problem here is that the directory for the man page and completion
|
||||
|
|
|
@ -23,11 +23,13 @@
|
|||
#:use-module (system foreign)
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 rdelim)
|
||||
#:export (canonical-sexp?
|
||||
error-source
|
||||
error-string
|
||||
string->canonical-sexp
|
||||
canonical-sexp->string
|
||||
read-file-sexp
|
||||
number->canonical-sexp
|
||||
canonical-sexp-car
|
||||
canonical-sexp-cdr
|
||||
|
@ -143,6 +145,12 @@ thrown along with 'gcry-error'."
|
|||
(loop (* len 2))
|
||||
(pointer->string buf size "ISO-8859-1")))))))
|
||||
|
||||
(define (read-file-sexp file)
|
||||
"Return the canonical sexp read from FILE."
|
||||
(call-with-input-file file
|
||||
(compose string->canonical-sexp
|
||||
read-string)))
|
||||
|
||||
(define canonical-sexp-car
|
||||
(let* ((ptr (libgcrypt-func "gcry_sexp_car"))
|
||||
(proc (pointer->procedure '* ptr '(*))))
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2015 David Thompson <davet@gnu.org>
|
||||
;;; Copyright © 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
@ -52,7 +52,10 @@
|
|||
#:use-module (guix scripts)
|
||||
#:use-module ((guix utils) #:select (compressed-file?))
|
||||
#:use-module ((guix build utils) #:select (dump-port))
|
||||
#:export (guix-publish))
|
||||
#:export (%public-key
|
||||
%private-key
|
||||
|
||||
guix-publish))
|
||||
|
||||
(define (show-help)
|
||||
(format #t (_ "Usage: guix publish [OPTION]...
|
||||
|
@ -68,6 +71,12 @@ Publish ~a over HTTP.\n") %store-directory)
|
|||
compress archives at LEVEL"))
|
||||
(display (_ "
|
||||
--ttl=TTL announce narinfos can be cached for TTL seconds"))
|
||||
(display (_ "
|
||||
--nar-path=PATH use PATH as the prefix for nar URLs"))
|
||||
(display (_ "
|
||||
--public-key=FILE use FILE as the public key for signatures"))
|
||||
(display (_ "
|
||||
--private-key=FILE use FILE as the private key for signatures"))
|
||||
(display (_ "
|
||||
-r, --repl[=PORT] spawn REPL server on PORT"))
|
||||
(newline)
|
||||
|
@ -145,6 +154,15 @@ compression disabled~%"))
|
|||
(leave (_ "~a: invalid duration~%") arg))
|
||||
(alist-cons 'narinfo-ttl (time-second duration)
|
||||
result))))
|
||||
(option '("nar-path") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'nar-path arg result)))
|
||||
(option '("public-key") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'public-key-file arg result)))
|
||||
(option '("private-key" "secret-key") #t #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'private-key-file arg result)))
|
||||
(option '(#\r "repl") #f #t
|
||||
(lambda (opt name arg result)
|
||||
;; If port unspecified, use default Guile REPL port.
|
||||
|
@ -154,6 +172,12 @@ compression disabled~%"))
|
|||
(define %default-options
|
||||
`((port . 8080)
|
||||
|
||||
;; By default, serve nars under "/nar".
|
||||
(nar-path . "nar")
|
||||
|
||||
(public-key-file . ,%public-key-file)
|
||||
(private-key-file . ,%private-key-file)
|
||||
|
||||
;; Default to fast & low compression.
|
||||
(compression . ,(if (zlib-available?)
|
||||
%default-gzip-compression
|
||||
|
@ -162,18 +186,11 @@ compression disabled~%"))
|
|||
(address . ,(make-socket-address AF_INET INADDR_ANY 0))
|
||||
(repl . #f)))
|
||||
|
||||
(define (lazy-read-file-sexp file)
|
||||
"Return a promise to read the canonical sexp from FILE."
|
||||
(delay
|
||||
(call-with-input-file file
|
||||
(compose string->canonical-sexp
|
||||
read-string))))
|
||||
|
||||
;; The key pair used to sign narinfos.
|
||||
(define %private-key
|
||||
(lazy-read-file-sexp %private-key-file))
|
||||
|
||||
(make-parameter #f))
|
||||
(define %public-key
|
||||
(lazy-read-file-sexp %public-key-file))
|
||||
(make-parameter #f))
|
||||
|
||||
(define %nix-cache-info
|
||||
`(("StoreDir" . ,%store-directory)
|
||||
|
@ -186,25 +203,26 @@ compression disabled~%"))
|
|||
|
||||
(define (signed-string s)
|
||||
"Sign the hash of the string S with the daemon's key."
|
||||
(let* ((public-key (force %public-key))
|
||||
(let* ((public-key (%public-key))
|
||||
(hash (bytevector->hash-data (sha256 (string->utf8 s))
|
||||
#:key-type (key-type public-key))))
|
||||
(signature-sexp hash (force %private-key) public-key)))
|
||||
(signature-sexp hash (%private-key) public-key)))
|
||||
|
||||
(define base64-encode-string
|
||||
(compose base64-encode string->utf8))
|
||||
|
||||
(define* (narinfo-string store store-path key
|
||||
#:key (compression %no-compression))
|
||||
#:key (compression %no-compression)
|
||||
(nar-path "nar"))
|
||||
"Generate a narinfo key/value string for STORE-PATH; an exception is raised
|
||||
if STORE-PATH is invalid. Produce a URL that corresponds to COMPRESSION. The
|
||||
narinfo is signed with KEY."
|
||||
narinfo is signed with KEY. NAR-PATH specifies the prefix for nar URLs."
|
||||
(let* ((path-info (query-path-info store store-path))
|
||||
(compression (if (compressed-file? store-path)
|
||||
%no-compression
|
||||
compression))
|
||||
(url (encode-and-join-uri-path
|
||||
`("nar"
|
||||
`(,@(split-and-decode-uri-path nar-path)
|
||||
,@(match compression
|
||||
(($ <compression> 'none)
|
||||
'())
|
||||
|
@ -266,11 +284,12 @@ References: ~a~%"
|
|||
%nix-cache-info))))
|
||||
|
||||
(define* (render-narinfo store request hash
|
||||
#:key ttl (compression %no-compression))
|
||||
#:key ttl (compression %no-compression)
|
||||
(nar-path "nar"))
|
||||
"Render metadata for the store path corresponding to HASH. If TTL is true,
|
||||
advertise it as the maximum validity period (in seconds) via the
|
||||
'Cache-Control' header. This allows 'guix substitute' to cache it for an
|
||||
appropriate duration."
|
||||
appropriate duration. NAR-PATH specifies the prefix for nar URLs."
|
||||
(let ((store-path (hash-part->path store hash)))
|
||||
(if (string-null? store-path)
|
||||
(not-found request)
|
||||
|
@ -279,7 +298,8 @@ appropriate duration."
|
|||
`((cache-control (max-age . ,ttl)))
|
||||
'()))
|
||||
(cut display
|
||||
(narinfo-string store store-path (force %private-key)
|
||||
(narinfo-string store store-path (%private-key)
|
||||
#:nar-path nar-path
|
||||
#:compression compression)
|
||||
<>)))))
|
||||
|
||||
|
@ -469,7 +489,12 @@ blocking."
|
|||
(define* (make-request-handler store
|
||||
#:key
|
||||
narinfo-ttl
|
||||
(nar-path "nar")
|
||||
(compression %no-compression))
|
||||
(define nar-path?
|
||||
(let ((expected (split-and-decode-uri-path nar-path)))
|
||||
(cut equal? expected <>)))
|
||||
|
||||
(lambda (request body)
|
||||
(format #t "~a ~a~%"
|
||||
(request-method request)
|
||||
|
@ -485,19 +510,23 @@ blocking."
|
|||
;; NARINFO-TTL.
|
||||
(render-narinfo store request hash
|
||||
#:ttl narinfo-ttl
|
||||
#:nar-path nar-path
|
||||
#:compression compression))
|
||||
;; /nar/file/NAME/sha256/HASH
|
||||
(("file" name "sha256" hash)
|
||||
(guard (c ((invalid-base32-character? c)
|
||||
(not-found request)))
|
||||
(let ((hash (nix-base32-string->bytevector hash)))
|
||||
(render-content-addressed-file store request
|
||||
name 'sha256 hash))))
|
||||
|
||||
;; Use different URLs depending on the compression type. This
|
||||
;; guarantees that /nar URLs remain valid even when 'guix publish'
|
||||
;; is restarted with different compression parameters.
|
||||
|
||||
;; /nar/<store-item>
|
||||
(("nar" store-item)
|
||||
(render-nar store request store-item
|
||||
#:compression %no-compression))
|
||||
;; /nar/gzip/<store-item>
|
||||
(("nar" "gzip" store-item)
|
||||
(if (zlib-available?)
|
||||
((components ... "gzip" store-item)
|
||||
(if (and (nar-path? components) (zlib-available?))
|
||||
(render-nar store request store-item
|
||||
#:compression
|
||||
(match compression
|
||||
|
@ -507,19 +536,21 @@ blocking."
|
|||
%default-gzip-compression)))
|
||||
(not-found request)))
|
||||
|
||||
;; /nar/file/NAME/sha256/HASH
|
||||
(("file" name "sha256" hash)
|
||||
(guard (c ((invalid-base32-character? c)
|
||||
(not-found request)))
|
||||
(let ((hash (nix-base32-string->bytevector hash)))
|
||||
(render-content-addressed-file store request
|
||||
name 'sha256 hash))))
|
||||
(_ (not-found request)))
|
||||
;; /nar/<store-item>
|
||||
((components ... store-item)
|
||||
(if (nar-path? components)
|
||||
(render-nar store request store-item
|
||||
#:compression %no-compression)
|
||||
(not-found request)))
|
||||
|
||||
(x (not-found request)))
|
||||
(not-found request))))
|
||||
|
||||
(define* (run-publish-server socket store
|
||||
#:key (compression %no-compression) narinfo-ttl)
|
||||
#:key (compression %no-compression)
|
||||
(nar-path "nar") narinfo-ttl)
|
||||
(run-server (make-request-handler store
|
||||
#:nar-path nar-path
|
||||
#:narinfo-ttl narinfo-ttl
|
||||
#:compression compression)
|
||||
concurrent-http-server
|
||||
|
@ -566,11 +597,13 @@ blocking."
|
|||
(sockaddr:addr addr)
|
||||
port)))
|
||||
(socket (open-server-socket address))
|
||||
(repl-port (assoc-ref opts 'repl)))
|
||||
;; Read the key right away so that (1) we fail early on if we can't
|
||||
;; access them, and (2) we can then drop privileges.
|
||||
(force %private-key)
|
||||
(force %public-key)
|
||||
(nar-path (assoc-ref opts 'nar-path))
|
||||
(repl-port (assoc-ref opts 'repl))
|
||||
|
||||
;; Read the key right away so that (1) we fail early on if we can't
|
||||
;; access them, and (2) we can then drop privileges.
|
||||
(public-key (read-file-sexp (assoc-ref opts 'public-key-file)))
|
||||
(private-key (read-file-sexp (assoc-ref opts 'private-key-file))))
|
||||
|
||||
(when user
|
||||
;; Now that we've read the key material and opened the socket, we can
|
||||
|
@ -580,13 +613,17 @@ blocking."
|
|||
(when (zero? (getuid))
|
||||
(warning (_ "server running as root; \
|
||||
consider using the '--user' option!~%")))
|
||||
(format #t (_ "publishing ~a on ~a, port ~d~%")
|
||||
%store-directory
|
||||
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
|
||||
(sockaddr:port address))
|
||||
(when repl-port
|
||||
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
|
||||
(with-store store
|
||||
(run-publish-server socket store
|
||||
#:compression compression
|
||||
#:narinfo-ttl ttl)))))
|
||||
|
||||
(parameterize ((%public-key public-key)
|
||||
(%private-key private-key))
|
||||
(format #t (_ "publishing ~a on ~a, port ~d~%")
|
||||
%store-directory
|
||||
(inet-ntop (sockaddr:fam address) (sockaddr:addr address))
|
||||
(sockaddr:port address))
|
||||
(when repl-port
|
||||
(repl:spawn-server (repl:make-tcp-server-socket #:port repl-port)))
|
||||
(with-store store
|
||||
(run-publish-server socket store
|
||||
#:nar-path nar-path
|
||||
#:compression compression
|
||||
#:narinfo-ttl ttl))))))
|
||||
|
|
|
@ -50,6 +50,7 @@
|
|||
|
||||
(test-begin "pack")
|
||||
|
||||
(unless (network-reachable?) (test-skip 1))
|
||||
(test-assertm "self-contained-tarball"
|
||||
(mlet* %store-monad
|
||||
((profile (profile-derivation (packages->manifest
|
||||
|
|
|
@ -33,6 +33,7 @@
|
|||
#:use-module ((guix records) #:select (recutils->alist))
|
||||
#:use-module ((guix serialization) #:select (restore-file))
|
||||
#:use-module (guix pk-crypto)
|
||||
#:use-module ((guix pki) #:select (%public-key-file %private-key-file))
|
||||
#:use-module (guix zlib)
|
||||
#:use-module (web uri)
|
||||
#:use-module (web client)
|
||||
|
@ -100,6 +101,10 @@
|
|||
;; Wait until the two servers are ready.
|
||||
(wait-until-ready 6789)
|
||||
|
||||
;; Initialize the public/private key SRFI-39 parameters.
|
||||
(%public-key (read-file-sexp %public-key-file))
|
||||
(%private-key (read-file-sexp %private-key-file))
|
||||
|
||||
|
||||
(test-begin "publish")
|
||||
|
||||
|
@ -227,6 +232,36 @@ References: ~%"
|
|||
(list (assoc-ref info "Compression")
|
||||
(dirname (assoc-ref info "URL")))))
|
||||
|
||||
(test-equal "custom nar path"
|
||||
;; Serve nars at /foo/bar/chbouib instead of /nar.
|
||||
(list `(("StorePath" . ,%item)
|
||||
("URL" . ,(string-append "foo/bar/chbouib/" (basename %item)))
|
||||
("Compression" . "none"))
|
||||
200
|
||||
404)
|
||||
(let ((thread (with-separate-output-ports
|
||||
(call-with-new-thread
|
||||
(lambda ()
|
||||
(guix-publish "--port=6798" "-C0"
|
||||
"--nar-path=///foo/bar//chbouib/"))))))
|
||||
(wait-until-ready 6798)
|
||||
(let* ((base "http://localhost:6798/")
|
||||
(part (store-path-hash-part %item))
|
||||
(url (string-append base part ".narinfo"))
|
||||
(nar-url (string-append base "foo/bar/chbouib/"
|
||||
(basename %item)))
|
||||
(body (http-get-port url)))
|
||||
(list (filter (lambda (item)
|
||||
(match item
|
||||
(("Compression" . _) #t)
|
||||
(("StorePath" . _) #t)
|
||||
(("URL" . _) #t)
|
||||
(_ #f)))
|
||||
(recutils->alist body))
|
||||
(response-code (http-get nar-url))
|
||||
(response-code
|
||||
(http-get (string-append base "nar/" (basename %item))))))))
|
||||
|
||||
(test-equal "/nar/ with properly encoded '+' sign"
|
||||
"Congrats!"
|
||||
(let ((item (add-text-to-store %store "fake-gtk+" "Congrats!")))
|
||||
|
|
|
@ -384,8 +384,8 @@
|
|||
(guard (c ((nix-protocol-error? c) #t))
|
||||
(build-derivations %store (list d))))))))
|
||||
(cond-expand
|
||||
(guile-2.0 "garbage: ?lambda: λ")
|
||||
(else "garbage: <EFBFBD>lambda: λ"))))
|
||||
(guile-2.2 "garbage: <20>lambda: λ")
|
||||
(else "garbage: ?lambda: λ"))))
|
||||
|
||||
(test-assert "log-file, derivation"
|
||||
(let* ((b (add-text-to-store %store "build" "echo $foo > $out" '()))
|
||||
|
|
Loading…
Reference in New Issue