substitute: 'http-multiple-get' follows 'fold' style.
* guix/scripts/substitute.scm (http-multiple-get): Add 'seed' parameter. Call PROC in 'fold' style. (fetch-narinfos)[handle-narinfo-response]: Adjust accordingly. Update 'http-multiple-get' call accordingly.
This commit is contained in:
parent
58301666dd
commit
f151298fa0
|
@ -474,12 +474,13 @@ may be #f, in which case it indicates that PATH is unavailable at CACHE-URL."
|
||||||
".narinfo")))
|
".narinfo")))
|
||||||
(build-request (string->uri url) #:method 'GET)))
|
(build-request (string->uri url) #:method 'GET)))
|
||||||
|
|
||||||
(define (http-multiple-get base-url requests proc)
|
(define (http-multiple-get base-url proc seed requests)
|
||||||
"Send all of REQUESTS to the server at BASE-URL. Call PROC for each
|
"Send all of REQUESTS to the server at BASE-URL. Call PROC for each
|
||||||
response, passing it the request object, the response, and a port from which
|
response, passing it the request object, the response, a port from which to
|
||||||
to read the response body. Return the list of results."
|
read the response body, and the previous result, starting with SEED, à la
|
||||||
|
'fold'. Return the final result."
|
||||||
(let connect ((requests requests)
|
(let connect ((requests requests)
|
||||||
(result '()))
|
(result seed))
|
||||||
;; (format (current-error-port) "connecting (~a requests left)..."
|
;; (format (current-error-port) "connecting (~a requests left)..."
|
||||||
;; (length requests))
|
;; (length requests))
|
||||||
(let ((p (open-socket-for-uri base-url)))
|
(let ((p (open-socket-for-uri base-url)))
|
||||||
|
@ -497,7 +498,7 @@ to read the response body. Return the list of results."
|
||||||
((head tail ...)
|
((head tail ...)
|
||||||
(let* ((resp (read-response p))
|
(let* ((resp (read-response p))
|
||||||
(body (response-body-port resp))
|
(body (response-body-port resp))
|
||||||
(result (cons (proc head resp body) result)))
|
(result (proc head resp body result)))
|
||||||
;; The server can choose to stop responding at any time, in which
|
;; The server can choose to stop responding at any time, in which
|
||||||
;; case we have to try again. Check whether that is the case.
|
;; case we have to try again. Check whether that is the case.
|
||||||
;; Note that even upon "Connection: close", we can read from BODY.
|
;; Note that even upon "Connection: close", we can read from BODY.
|
||||||
|
@ -536,7 +537,7 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
url (* 100. (/ done (length paths))))
|
url (* 100. (/ done (length paths))))
|
||||||
(set! done (+ 1 done)))))
|
(set! done (+ 1 done)))))
|
||||||
|
|
||||||
(define (handle-narinfo-response request response port)
|
(define (handle-narinfo-response request response port result)
|
||||||
(let ((len (response-content-length response)))
|
(let ((len (response-content-length response)))
|
||||||
;; Make sure to read no more than LEN bytes since subsequent bytes may
|
;; Make sure to read no more than LEN bytes since subsequent bytes may
|
||||||
;; belong to the next response.
|
;; belong to the next response.
|
||||||
|
@ -545,7 +546,7 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
(let ((narinfo (read-narinfo port url #:size len)))
|
(let ((narinfo (read-narinfo port url #:size len)))
|
||||||
(cache-narinfo! url (narinfo-path narinfo) narinfo)
|
(cache-narinfo! url (narinfo-path narinfo) narinfo)
|
||||||
(update-progress!)
|
(update-progress!)
|
||||||
narinfo))
|
(cons narinfo result)))
|
||||||
((404) ; failure
|
((404) ; failure
|
||||||
(let* ((path (uri-path (request-uri request)))
|
(let* ((path (uri-path (request-uri request)))
|
||||||
(hash-part (string-drop-right path 8))) ; drop ".narinfo"
|
(hash-part (string-drop-right path 8))) ; drop ".narinfo"
|
||||||
|
@ -555,13 +556,13 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
(cache-narinfo! url
|
(cache-narinfo! url
|
||||||
(find (cut string-contains <> hash-part) paths)
|
(find (cut string-contains <> hash-part) paths)
|
||||||
#f)
|
#f)
|
||||||
(update-progress!))
|
(update-progress!)
|
||||||
#f)
|
result))
|
||||||
(else ; transient failure
|
(else ; transient failure
|
||||||
(if len
|
(if len
|
||||||
(get-bytevector-n port len)
|
(get-bytevector-n port len)
|
||||||
(read-to-eof port))
|
(read-to-eof port))
|
||||||
#f))))
|
result))))
|
||||||
|
|
||||||
(define cache-info
|
(define cache-info
|
||||||
(download-cache-info url))
|
(download-cache-info url))
|
||||||
|
@ -574,8 +575,9 @@ if file doesn't exist, and the narinfo otherwise."
|
||||||
((http)
|
((http)
|
||||||
(let ((requests (map (cut narinfo-request url <>) paths)))
|
(let ((requests (map (cut narinfo-request url <>) paths)))
|
||||||
(update-progress!)
|
(update-progress!)
|
||||||
(let ((result (http-multiple-get url requests
|
(let ((result (http-multiple-get url
|
||||||
handle-narinfo-response)))
|
handle-narinfo-response '()
|
||||||
|
requests)))
|
||||||
(newline (current-error-port))
|
(newline (current-error-port))
|
||||||
result)))
|
result)))
|
||||||
((file #f)
|
((file #f)
|
||||||
|
|
Loading…
Reference in New Issue