From 91fe0e20c7da2b706a1ac0e7b75235b6c1e6ed0a Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Tue, 14 May 2013 23:51:36 +0200
Subject: ftp-client: Let callers handle `ftp-open' exceptions.

* guix/ftp-client.scm (ftp-open): Let exceptions through.
* guix/scripts/package.scm (waiting): Wrap EXP in a `dynamic-wind', so
  the line is always cleared.
---
 guix/ftp-client.scm      | 72 ++++++++++++++++++++++--------------------------
 guix/scripts/package.scm | 16 ++++++-----
 2 files changed, 42 insertions(+), 46 deletions(-)

diff --git a/guix/ftp-client.scm b/guix/ftp-client.scm
index ba3201fdab..dd9135e95a 100644
--- a/guix/ftp-client.scm
+++ b/guix/ftp-client.scm
@@ -87,45 +87,39 @@ (define* (ftp-open host #:optional (port 21))
   ;; Use 21 as the default PORT instead of "ftp", to avoid depending on
   ;; libc's NSS, which is not available during bootstrap.
 
-  (catch 'getaddrinfo-error
-    (lambda ()
-      (define addresses
-        (getaddrinfo host
-                     (if (number? port) (number->string port) port)
-                     (if (number? port) AI_NUMERICSERV 0)))
-
-      (let loop ((addresses addresses))
-        (let* ((ai (car addresses))
-               (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
-                           (addrinfo:protocol ai))))
-
-          (catch 'system-error
-            (lambda ()
-              (connect s (addrinfo:addr ai))
-              (setvbuf s _IOLBF)
-              (let-values (((code message) (%ftp-listen s)))
-                (if (eqv? code 220)
-                    (begin
-                      ;;(%ftp-command "OPTS UTF8 ON" 200 s)
-                      (%ftp-login "anonymous" "guix@example.com" s)
-                      (%make-ftp-connection s ai))
-                    (begin
-                      (format (current-error-port)
-                              "FTP to `~a' failed: ~A: ~A~%"
-                              host code message)
-                      (close s)
-                      #f))))
-
-            (lambda args
-              ;; Connection failed, so try one of the other addresses.
-              (close s)
-              (if (null? addresses)
-                  (apply throw args)
-                  (loop (cdr addresses))))))))
-    (lambda (key errcode)
-      (format (current-error-port) "failed to resolve `~a': ~a~%"
-              host (gai-strerror errcode))
-      #f)))
+  (define addresses
+    (getaddrinfo host
+                 (if (number? port) (number->string port) port)
+                 (if (number? port) AI_NUMERICSERV 0)))
+
+  (let loop ((addresses addresses))
+    (let* ((ai (car addresses))
+           (s  (socket (addrinfo:fam ai) (addrinfo:socktype ai)
+                       (addrinfo:protocol ai))))
+
+      (catch 'system-error
+        (lambda ()
+          (connect s (addrinfo:addr ai))
+          (setvbuf s _IOLBF)
+          (let-values (((code message) (%ftp-listen s)))
+            (if (eqv? code 220)
+                (begin
+                  ;;(%ftp-command "OPTS UTF8 ON" 200 s)
+                  (%ftp-login "anonymous" "guix@example.com" s)
+                  (%make-ftp-connection s ai))
+                (begin
+                  (format (current-error-port)
+                          "FTP to `~a' failed: ~A: ~A~%"
+                          host code message)
+                  (close s)
+                  #f))))
+
+        (lambda args
+          ;; Connection failed, so try one of the other addresses.
+          (close s)
+          (if (null? addresses)
+              (apply throw args)
+              (loop (cdr addresses))))))))
 
 (define (ftp-close conn)
   (close (ftp-connection-socket conn)))
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 5c6a118560..094d348ac9 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -307,13 +307,15 @@ (define-syntax-rule (waiting exp fmt rest ...)
     (force-output (current-error-port))
     (call-with-sigint-handler
      (lambda ()
-       (let ((result exp))
-         ;; Clear the line.
-         (display #\cr (current-error-port))
-         (display blank (current-error-port))
-         (display #\cr (current-error-port))
-         (force-output (current-error-port))
-         exp))
+       (dynamic-wind
+         (const #f)
+         (lambda () exp)
+         (lambda ()
+           ;; Clear the line.
+           (display #\cr (current-error-port))
+           (display blank (current-error-port))
+           (display #\cr (current-error-port))
+           (force-output (current-error-port)))))
      (lambda (signum)
        (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
        #f))))
-- 
cgit v1.2.3