I've come up with a slight variant of the original script now, which for
me reliably causes Guile to crash. I've included some example output
below.
(use-modules (web uri)
(web request)
(web response)
(web client)
(web http)
(srfi srfi-1)
(ice-9 threads)
(ice-9 match)
(rnrs bytevectors)
(srfi srfi-11)
(srfi srfi-9)
(srfi srfi-9 gnu)
(srfi srfi-26)
(gnutls)
(ice-9 binary-ports)
((ice-9 ftw) #:select (scandir))
((rnrs io ports)
#:prefix rnrs-ports:))
(define* (call-with-streaming-http-request uri callback
#:key (headers '()))
(let* ((port (open-socket-for-uri uri))
(request
(build-request
uri
#:method 'PUT
#:version '(1 . 1)
#:headers `((connection close)
(Transfer-Encoding . "chunked")
(Content-Type . "application/octet-stream")
,@headers)
#:port port)))
(set-port-encoding! port "ISO-8859-1")
(let ((request (write-request request port)))
(let ((chunked-output-port
(make-chunked-output-port
port
#:buffering 128
#:keep-alive? #t)))
;; A SIGPIPE will kill Guile, so ignore it
(sigaction SIGPIPE
(lambda (arg)
(simple-format (current-error-port) "warning: SIGPIPE\n")))
(set-port-encoding! chunked-output-port "ISO-8859-1")
(callback chunked-output-port)
(retry-gnutls-resource-temporarily-unavailable
(lambda ()
(close-port chunked-output-port)))
(display "\r\n" port)
(force-output port))
(let ((response (read-response port)))
(let ((body (read-response-body response)))
(close-port port)
(values response
body))
(define (retry-gnutls-resource-temporarily-unavailable thunk)
(catch 'gnutls-error
thunk
(lambda (key err proc . rest)
(if (eq? error/again err)
(begin
(simple-format (current-error-port)
"error/again\n")
(sleep 1)
(thunk))
(throw key (cons* err proc rest))
(define (start-thread thread-index)
(call-with-new-thread
(lambda ()
(for-each
(lambda (request-index)
(with-throw-handler #t
(lambda ()
(call-with-streaming-http-request
;; The URL doesn't realy matter as the response to the
;; request doesn't matter.
(peek (string->uri (if (= thread-index 1)
"https://guix.cbaines.net/test";
"https://www.cbaines.net/test";)))
(lambda (port)
(simple-format (current-error-port)
"thread ~A making request\n"
thread-index)
(let* ((buffer-size 128)
(buffer (make-bytevector buffer-size)))
(for-each (lambda (index)
;; (usleep 10)
(retry-gnutls-resource-temporarily-unavailable
(lambda ()
(put-bytevector port buffer 0 buffer-size
(iota 2))
(lambda (key . args)
(simple-format #t "thread ~A: exception: ~A ~A\n"
thread-index key args)
(backtrace
(iota 1 1)
(define threads
(map start-thread
(iota 6 1)))
(for-each join-thread threads)
;;;
;;; ((
;;; ;;; ;;; (((#<#< scheme: : scheme: https
httpshttps : uhttpsnfouseri: erinfo :: #fuserinfo#f: # fh osth:
sthohost"guix.cbaii: n": e"wsww.wwn.wec.tbc"ab iapnorti:e n#sfe .spnath.:e
n"te/"t
tt "eport ssort :t#p aquer : erys: pathme"a: th#: / ht
"ttpst f//e;;; entu:t eris erinfo( :#fe>tf##fs )f""th
osti>"ost ::q uschem": hemequery: :htw#fwftps#f f wuffragment.ragment:
agment:: c #f##fbf>f >a)h
)iost
::n neewsw.wn.ectb"a iportn: esfs .pathn: e"t/"teesorts: t" queryquery#f:
papath : fragment": /#ft>e)s
t" query: #f fragment: #f>)
;;; (#< scheme: https userinfo: #f host: "www.cbaines.net" port: #f path:
"/test" query: #f fragment: #f>)
thread 4 making request
thread 3 making request
thread 6 making request
thread 5 making request
thread 2 making request
error/again
error/again
error/again
thread 1 making request
error/again
error/again
error/again
warning: SIGPIPE
thread 4: exception: gnutls-error ((# write_to_session_record_port))
Backtrace:
error/again
thread 6: exception: gnutls-error ((# write_to_session_record_port))
Backtrace:
IInnn srfi/srfi-1.scmsrfi/srfi-1.scmsrfi/srfi-1.scm::
634:9634:9 7 7 (for-each
