added some logging info to planet

svn: r13237

collects/planet/planet.ss

@@ -24,6 +24,7 @@ PLANNED FEATURES:
 
     (make-directory* (PLANET-DIR))
     (make-directory* (CACHE-DIR))
+    (planet-logging-to-stdout #t)
     
     (svn-style-command-line
      #:program "planet"

collects/planet/private/planet-shared.ss

@@ -486,14 +486,36 @@ Various common pieces of code that both the client and server need to access
   
   (define (wrap x) (begin (write x) (newline) x))
   
+  (define planet-logging-to-stdout (make-parameter #f))
+  
+  (define planet-log 
+    (let ([planet-logger (make-logger 'PLaneT (current-logger))])
+      (λ (str . fmt)
+        (parameterize ([current-logger planet-logger])
+          (log-info (apply format str fmt))
+          (when (planet-logging-to-stdout)
+            (apply fprintf (current-output-port) str fmt)
+            (newline (current-output-port)))))))
+  
   (define (with-logging logfile f)
-    (let* ((null-out (open-output-nowhere))
-           (outport
-            (if logfile
-                (with-handlers ((exn:fail:filesystem? (lambda (e) null-out)))
-                  (open-output-file logfile #:exists 'append))
-                null-out)))
-      (parameterize ([current-output-port outport])
+    (let-values ([(in out) (make-pipe)])
+      (thread
+       (λ () 
+         (let ([outport
+                (and logfile
+                     (with-handlers ((exn:fail:filesystem? (lambda (e) #f)))
+                       (open-output-file logfile #:exists 'append)))])
+           (let loop ()
+             (let ([l (read-line in)])
+               (cond
+                 [(eof-object? l)
+                  (close-input-port in) 
+                  (when outport (close-output-port outport))]
+                 [else
+                  (when outport (display l outport))
+                  (planet-log l)
+                  (loop)]))))))
+      (parameterize ([current-output-port out])
         (f))))
   
   

collects/planet/resolver.ss

@@ -560,6 +560,10 @@ subdirectory.
 ;; raises an exception if some protocol failure occurs in the download process
 (define (download-package/planet pkg)
 
+  (define stupid-internal-define-syntax (planet-log "downloading ~a from ~a via planet protocol" 
+                                                    (pkg-spec->string pkg)
+                                                    (PLANET-SERVER-NAME)))
+  
   (define-values (ip op) (tcp-connect (PLANET-SERVER-NAME) (PLANET-SERVER-PORT)))
 
   (define (close-ports) (close-input-port ip) (close-output-port op))
@@ -610,7 +614,8 @@ subdirectory.
   (define (state:failure msg) (list #f msg))
 
   (with-handlers ([void (lambda (e) (close-ports) (raise e))])
-    (begin0 (state:initialize)
+    (begin0 
+      (state:initialize)
       (close-ports))))
 
 ;; ------------------------------------------------------------
@@ -651,6 +656,13 @@ subdirectory.
       (when (> attempts 5)
         (return "Download failed too many times (possibly due to an unreliable network connection)"))
 
+      (planet-log "downloading ~a from ~a via HTTP~a" 
+                  (pkg-spec->string pkg)
+                  (PLANET-SERVER-NAME)
+                  (if (= attempts 1)
+                      ""
+                      (format ", attempt #~a" attempts)))
+
       (with-handlers ([exn:fail:network? (λ (e) (return (exn-message e)))])
         (let* ([target            (pkg->download-url pkg)]
                [ip                (get-impure-port target)]
@@ -706,6 +718,17 @@ subdirectory.
              (abort (format "Internal error (unknown HTTP response code ~a)"
                             response-code))]))))))
 
+;; formats the pkg-spec back into a string the way the user typed it in.
+;; assumes that the pkg-spec comes from the command-line
+(define (pkg-spec->string pkg)
+  (format "'~a ~a ~a ~a'"
+          (if (pair? (pkg-spec-path pkg))
+              (car (pkg-spec-path pkg))
+              "<<unknown>>") ;; this shouldn't happen
+          (pkg-spec-name pkg)
+          (pkg-spec-maj pkg)
+          (pkg-spec-minor-lo pkg)))
+  
 ;; =============================================================================
 ;; MODULE MANAGEMENT
 ;; Handles interaction with the module system