[PATCH] gnu: patch Guile 2.0 to fix bug #14884.

[Cyril Roelandt <tipecaml@gmail.com>]

* gnu/packages/patches/guile-web.patch: New file.
* gnu-system.am: Add it
* gnu/packages/guile.scm (guile-2.0): Add the patch.
---
 gnu-system.am                        |  1 +
 gnu/packages/guile.scm               |  3 +-
 gnu/packages/patches/guile-web.patch | 78 ++++++++++++++++++++++++++++++++++++
 3 files changed, 81 insertions(+), 1 deletion(-)
 create mode 100644 gnu/packages/patches/guile-web.patch

diff --git a/gnu-system.am b/gnu-system.am
index a2377fd..88313e2 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -233,6 +233,7 @@ dist_patch_DATA =						\
   gnu/packages/patches/guile-default-utf8.patch			\
   gnu/packages/patches/guile-linux-syscalls.patch		\
   gnu/packages/patches/guile-relocatable.patch			\
+  gnu/packages/patches/guile-web.patch 				\
   gnu/packages/patches/hop-bigloo-4.0b.patch			\
   gnu/packages/patches/libevent-dns-tests.patch			\
   gnu/packages/patches/libtool-skip-tests.patch			\
diff --git a/gnu/packages/guile.scm b/gnu/packages/guile.scm
index 653d42c..867a646 100644
--- a/gnu/packages/guile.scm
+++ b/gnu/packages/guile.scm
@@ -113,7 +113,8 @@ without requiring the source code to be rewritten.")
                                 ".tar.xz"))
             (sha256
              (base32
-              "0nw9y8vjyz4r61v06p9msks5lm58pd91irmzg4k487vmv743h2pp"))))
+              "0nw9y8vjyz4r61v06p9msks5lm58pd91irmzg4k487vmv743h2pp"))
+            (patches (list (search-patch "guile-web.patch")))))
    (build-system gnu-build-system)
    (native-inputs `(("pkgconfig" ,pkg-config)))
    (inputs `(("libffi" ,libffi)
diff --git a/gnu/packages/patches/guile-web.patch b/gnu/packages/patches/guile-web.patch
new file mode 100644
index 0000000..3ac6497
--- /dev/null
+++ b/gnu/packages/patches/guile-web.patch
@@ -0,0 +1,78 @@
+From 802a25b1ed5c738aa5f9d3d01f33eb89b22afd1b Mon Sep 17 00:00:00 2001
+From: Ludovic Courtès <ludo@gnu.org>
+Date: Wed, 15 Jan 2014 22:41:23 +0000
+Subject: web: Don't throw if a response is longer than its Content-Length says.
+
+* module/web/response.scm (make-delimited-input-port): Read at most LEN
+  bytes from PORT, instead of trying to read more and returning an error
+  if more is available.  Try again when 'get-bytevector-n!' return zero.
+* test-suite/tests/web-response.test (example-1): Add garbage after the
+  body itself.
+---
+diff --git a/module/web/response.scm b/module/web/response.scm
+index 570a2d7..58e3f11 100644
+--- a/module/web/response.scm
++++ b/module/web/response.scm
+@@ -1,6 +1,6 @@
+ ;;; HTTP response objects
+ 
+-;; Copyright (C)  2010, 2011, 2012, 2013 Free Software Foundation, Inc.
++;; Copyright (C) 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc.
+ 
+ ;; This library is free software; you can redistribute it and/or
+ ;; modify it under the terms of the GNU Lesser General Public
+@@ -246,16 +246,21 @@ closes PORT, unless KEEP-ALIVE? is true."
+                   bytes-read len))
+ 
+   (define (read! bv start count)
+-    (let ((ret (get-bytevector-n! port bv start count)))
+-      (if (eof-object? ret)
+-          (if (= bytes-read len)
+-              0
+-              (fail))
+-          (begin
+-            (set! bytes-read (+ bytes-read ret))
+-            (if (> bytes-read len)
+-                (fail)
+-                ret)))))
++    ;; Read at most LEN bytes in total.  HTTP/1.1 doesn't say what to do
++    ;; when a server provides more than the Content-Length, but it seems
++    ;; wise to just stop reading at LEN.
++    (let ((count (min count (- len bytes-read))))
++      (let loop ((ret (get-bytevector-n! port bv start count)))
++        (cond ((eof-object? ret)
++               (if (= bytes-read len)
++                   0                              ; EOF
++                   (fail)))
++              ((and (zero? ret) (> count 0))
++               ;; Do not return zero since zero means EOF, so try again.
++               (loop (get-bytevector-n! port bv start count)))
++              (else
++               (set! bytes-read (+ bytes-read ret))
++               ret)))))
+ 
+   (define close
+     (and (not keep-alive?)
+diff --git a/test-suite/tests/web-response.test b/test-suite/tests/web-response.test
+index f9679f5..99b1293 100644
+--- a/test-suite/tests/web-response.test
++++ b/test-suite/tests/web-response.test
+@@ -1,6 +1,6 @@
+ ;;;; web-response.test --- HTTP responses       -*- mode: scheme; coding: utf-8; -*-
+ ;;;;
+-;;;;   Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
++;;;;   Copyright (C) 2010, 2011, 2012, 2014 Free Software Foundation, Inc.
+ ;;;;
+ ;;;; This library is free software; you can redistribute it and/or
+ ;;;; modify it under the terms of the GNU Lesser General Public
+@@ -39,7 +39,9 @@ Content-Encoding: gzip\r
+ Content-Length: 36\r
+ Content-Type: text/html; charset=utf-8\r
+ \r
+-abcdefghijklmnopqrstuvwxyz0123456789")
++abcdefghijklmnopqrstuvwxyz0123456789
++-> Here is trailing garbage that should be ignored because it is
++   beyond Content-Length.")
+ 
+ (define example-2
+   "HTTP/1.1 200 OK\r
-- 
1.8.4.rc3