From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp1 ([2001:41d0:2:4a6f::]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) by ms0.migadu.com with LMTPS id oJtdOS1uXGDz9gAAgWs5BA (envelope-from ) for ; Thu, 25 Mar 2021 12:04:13 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp1 with LMTPS id CNTQNC1uXGDIQgAAbx9fmQ (envelope-from ) for ; Thu, 25 Mar 2021 11:04:13 +0000 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 7B3ED9A16 for ; Thu, 25 Mar 2021 12:04:13 +0100 (CET) Received: from localhost ([::1]:54386 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1lPNme-0004na-Kt for larch@yhetil.org; Thu, 25 Mar 2021 07:04:12 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:56472) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1lPNmV-0004kw-Ad for guix-patches@gnu.org; Thu, 25 Mar 2021 07:04:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:54016) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1lPNmV-0007wF-2v for guix-patches@gnu.org; Thu, 25 Mar 2021 07:04:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1lPNmU-0001Vm-Uv for guix-patches@gnu.org; Thu, 25 Mar 2021 07:04:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#47288] [PATCH v3 2/2] guix: http-client: Refactor http-multiple-get. Resent-From: Christopher Baines Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 25 Mar 2021 11:04:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 47288 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 47288@debbugs.gnu.org Received: via spool by 47288-submit@debbugs.gnu.org id=B47288.16166702005745 (code B ref 47288); Thu, 25 Mar 2021 11:04:02 +0000 Received: (at 47288) by debbugs.gnu.org; 25 Mar 2021 11:03:20 +0000 Received: from localhost ([127.0.0.1]:37328 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lPNln-0001UV-J9 for submit@debbugs.gnu.org; Thu, 25 Mar 2021 07:03:20 -0400 Received: from mira.cbaines.net ([212.71.252.8]:50968) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1lPNll-0001UG-RJ for 47288@debbugs.gnu.org; Thu, 25 Mar 2021 07:03:18 -0400 Received: from localhost (unknown [IPv6:2a02:8010:68c1:0:8ac0:b4c7:f5c8:7caa]) by mira.cbaines.net (Postfix) with ESMTPSA id D2A8F27BC5D for <47288@debbugs.gnu.org>; Thu, 25 Mar 2021 11:03:16 +0000 (GMT) Received: from localhost (localhost [local]) by localhost (OpenSMTPD) with ESMTPA id 551b1553 for <47288@debbugs.gnu.org>; Thu, 25 Mar 2021 11:03:16 +0000 (UTC) From: Christopher Baines Date: Thu, 25 Mar 2021 11:03:16 +0000 Message-Id: <20210325110316.862-2-mail@cbaines.net> X-Mailer: git-send-email 2.30.1 In-Reply-To: <20210325110316.862-1-mail@cbaines.net> References: <20210325110316.862-1-mail@cbaines.net> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: "Guix-patches" X-Migadu-Flow: FLOW_IN ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1616670253; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post; bh=D0HEE4jQFssr6YVwwZEUzFKTrUveHIYIOMaX9anlaIU=; b=b9rSypmZ4K6febrIRf5Jx4bxr4XBZyCvYJjV2qP491zSVmh09Qhni30mc9kLhLX2nFKYPb /jrZu5FDsEBs3VzXPmIVW+U2hGfULzwPvBx+Js79kACgRR4fSS1wtG/kUCsCPYzG4nma2l wQ/CIBr5tWLJtLgcCEl03dMW665hlCvSjmfZmBBrYMXju+cvXv/1drWsIQxV0mqb4qh+j5 vVdTGlbvlfqwhmS5zs1LTWBub4LuhPnAr8SiuPk9B1eSp+vfCMFbm8Xn0lqPt7CkfibcAh 5htBHFKWpDkFUmt1km88BbqKGs34FJs0y5dPm76ua593tt7a/zVgovlYBHIbFg== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1616670253; a=rsa-sha256; cv=none; b=MmerWa7KWe0FSja+NL/v2h56l2F0n7grfgEhmPHLprYMwlUHqHA3L6Cw3OOE0Cf17KTw1S 6DzQxWPzzVy3sUmNvnuBEhDo17VMTeR5NuqHZ//2eHQeLGgAdDqxkY2yHpvsJuXtHoDyEs dMol2GuS+EmnN4aFulqqhrSD8RtykjGoXEY4SfbVjtRYBYEoUl5NLX3OlpjyQj+ou87kAh FkuFOPPftlgnUgq4Yvetmf7GEUDKiZguC7SMFA8fRNaPGr0xmOOXM/NKUj5Qi2revvOUgI ve0kiwRPSxVpDXKSEutreNgZGcWaVpOhUml6pipLfbRUsQdKdAK0Jz4O2ylQeQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Spam-Score: 2.58 Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=none; spf=pass (aspmx1.migadu.com: domain of guix-patches-bounces@gnu.org designates 209.51.188.17 as permitted sender) smtp.mailfrom=guix-patches-bounces@gnu.org X-Migadu-Queue-Id: 7B3ED9A16 X-Spam-Score: 2.58 X-Migadu-Scanner: scn0.migadu.com X-TUID: PUfxZaFer+gI Split the procedure in to three smaller procedures, rather than using two longer let statements. This might make it easier to read. * guix/http-client.scm (http-multiple-get): Refactor. --- guix/http-client.scm | 195 ++++++++++++++++++++++--------------------- 1 file changed, 101 insertions(+), 94 deletions(-) diff --git a/guix/http-client.scm b/guix/http-client.scm index adbfbc0d6e..b584feba5d 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -147,7 +147,7 @@ Raise an '&http-get-error' condition if downloading fails." (uri->string uri) code (response-reason-phrase resp)))))))))))) -(define* (http-multiple-get base-uri proc seed requests +(define* (http-multiple-get base-uri proc seed all-requests #:key port (verify-certificate? #t) (open-connection guix:open-connection-for-uri) (keep-alive? #t) @@ -161,16 +161,90 @@ When PORT is specified, use it as the initial connection on which HTTP requests are sent; otherwise call OPEN-CONNECTION to open a new connection for a URI. When KEEP-ALIVE? is false, close the connection port before returning." - (let connect ((port port) - (requests requests) - (result seed)) + (define (send-batch-of-requests p batch) + ;; Send BATCH in a row. + ;; XXX: Do our own caching to work around inefficiencies when + ;; communicating over TLS: . + (let-values (((buffer get) (open-bytevector-output-port))) + ;; Inherit the HTTP proxying property from P. + (set-http-proxy-port?! buffer (http-proxy-port? p)) + + (for-each (cut write-request <> buffer) + batch) + (put-bytevector p (get)) + (force-output p))) + + (define (process-batch-of-responses p + all-remaining-requests + batch-remaining-requests + processed + result) + (if (null? batch-remaining-requests) + (match (drop all-remaining-requests processed) + (() + (unless keep-alive? + (close-port p)) + (reverse result)) + (remainder + (connect-and-make-requests p remainder result))) + (match + (catch #t + (lambda () + (let* ((request (car batch-remaining-requests)) + (resp (read-response p)) + (body (response-body-port resp)) + (result (proc request resp body result))) + ;; The server can choose to stop responding at any time, in + ;; which case we have to try again. Check whether that is + ;; the case. Note that even upon "Connection: close", we can + ;; read from BODY. + (match (assq 'connection (response-headers resp)) + (('connection 'close) + (close-port p) + (list 'connect-and-make-requests + #f + (drop all-remaining-requests (+ 1 processed)) + result)) + (_ + (list 'process-batch-of-responses + p + all-remaining-requests + (cdr batch-remaining-requests) + (+ 1 processed) + result))))) + (lambda (key . args) + ;; If PORT was cached and the server closed the connection in + ;; the meantime, we get EPIPE. In that case, open a fresh + ;; connection and retry. We might also get 'bad-response or a + ;; similar exception from (web response) later on, once we've + ;; sent the request, or a ERROR/INVALID-SESSION from GnuTLS. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (and (eq? key 'gnutls-error) + (eq? (first args) error/invalid-session)) + (memq key + '(bad-response + bad-header + bad-header-component))) + (begin + (close-port p) + (list 'connect-and-make-requests + #f + (drop all-remaining-requests processed) + result)) + (apply throw key args)))) + + (('connect-and-make-requests . args) + (apply connect-and-make-requests args)) + (('process-batch-of-responses . args) + (apply process-batch-of-responses args))))) + + (define (connect-and-make-requests port remaining-requests result) (define batch - (if (>= batch-size (length requests)) - requests - (take requests batch-size))) + (if (>= batch-size (length remaining-requests)) + remaining-requests + (take remaining-requests batch-size))) - ;; (format (current-error-port) "connecting (~a requests left)..." - ;; (length requests)) (let ((p (or port (open-connection base-uri #:verify-certificate? verify-certificate?)))) @@ -178,92 +252,25 @@ returning." (when (file-port? p) (setvbuf p 'block (expt 2 16))) - ;; Send BATCH in a row. - ;; XXX: Do our own caching to work around inefficiencies when - ;; communicating over TLS: . - (let-values (((buffer get) (open-bytevector-output-port))) - ;; Inherit the HTTP proxying property from P. - (set-http-proxy-port?! buffer (http-proxy-port? p)) - - (catch #t - (lambda () - (for-each (cut write-request <> buffer) - batch) - (put-bytevector p (get)) - (force-output p)) - (lambda (key . args) - ;; If PORT becomes unusable, open a fresh connection and - ;; retry. - (if (or (and (eq? key 'system-error) - (= EPIPE (system-error-errno `(,key ,@args)))) - (and (eq? key 'gnutls-error) - (eq? (first args) error/invalid-session))) - (begin - (close-port p) ; close the broken port - (connect #f - requests - result)) - (apply throw key args))))) + (catch #t + (lambda () + (send-batch-of-requests p batch)) + (lambda (key . args) + ;; If PORT becomes unusable, open a fresh connection and retry. + (if (or (and (eq? key 'system-error) + (= EPIPE (system-error-errno `(,key ,@args)))) + (and (eq? key 'gnutls-error) + (eq? (first args) error/invalid-session))) + (begin + (close-port p) ; close the broken port + (connect-and-make-requests #f + remaining-requests + result)) + (apply throw key args)))) - ;; Now start processing responses. - (let loop ((sent batch) - (processed 0) - (result result)) - (match sent - (() - (match (drop requests processed) - (() - (unless keep-alive? - (close-port p)) - (reverse result)) - (remainder - (connect p remainder result)))) - ((head tail ...) - (match - (catch #t - (lambda () - (let* ((resp (read-response p)) - (body (response-body-port resp)) - (result (proc head resp body result))) - ;; The server can choose to stop responding at any time, - ;; in which case we have to try again. Check whether - ;; that is the case. Note that even upon "Connection: - ;; close", we can read from BODY. - (match (assq 'connection (response-headers resp)) - (('connection 'close) - (close-port p) - (list 'connect - #f - (drop requests (+ 1 processed)) - result)) - (_ - (list 'loop tail (+ 1 processed) result))))) - (lambda (key . args) - ;; If PORT was cached and the server closed the connection - ;; in the meantime, we get EPIPE. In that case, open a - ;; fresh connection and retry. We might also get - ;; 'bad-response or a similar exception from (web response) - ;; later on, once we've sent the request, or a - ;; ERROR/INVALID-SESSION from GnuTLS. - (if (or (and (eq? key 'system-error) - (= EPIPE (system-error-errno `(,key ,@args)))) - (and (eq? key 'gnutls-error) - (eq? (first args) error/invalid-session)) - (memq key - '(bad-response - bad-header - bad-header-component))) - (begin - (close-port p) - (list 'connect - #f - (drop requests processed) - result)) - (apply throw key args)))) - (('connect . args) - (apply connect args)) - (('loop . args) - (apply loop args))))))))) + (process-batch-of-responses p remaining-requests batch 0 result))) + + (connect-and-make-requests port all-requests seed)) ;;; -- 2.30.1