Ticket #414: proxy-auth-Basic.patch

chicken-install.scm

@@ -83 +83 @@
   (define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
   (define *proxy-host* #f)
   (define *proxy-port* #f)
+  (define *proxy-user-pass* #f)
   (define *running-test* #f)
   (define *mappings* '())
   (define *deploy* #f)
@@ -263 +264 @@
          password: *password*
          trunk: *trunk*
          proxy-host: *proxy-host*
-         proxy-port: *proxy-port*)
+         proxy-port: *proxy-port*
+         proxy-user-pass: *proxy-user-pass*)
       [(exn net)
        (print "TCP connect timeout")
        (values #f "") ]
@@ -622 +624 @@
 
   (define (setup-proxy uri)
     (if (string? uri)
-        (cond ((irregex-match "(.+)\\:([0-9]+)" uri) =>
-               (lambda (m)
-                 (set! *proxy-host* (irregex-match-substring m 1))
-                 (set! *proxy-port* (string->number (irregex-match-substring m 2))))
-               (else
-                (set! *proxy-host* uri)
-                (set! *proxy-port* 80))))))
+        (begin 
+          (set! *proxy-user-pass* (get-environment-variable "proxy_auth"))
+          (cond ((irregex-match "(.+)\\:([0-9]+)" uri) =>
+                 (lambda (m)
+                   (set! *proxy-host* (irregex-match-substring m 1))
+                   (set! *proxy-port* (string->number (irregex-match-substring m 2))))
+                 (else
+                  (set! *proxy-host* uri)
+                  (set! *proxy-port* 80)))))))
   
   (define *short-options* '(#\h #\k #\l #\t #\s #\p #\r #\n #\v #\i #\u #\D))
 

setup-download.scm

@@ -219 +219 @@
        (if m (irregex-match-substring m 5) "/")) ) )
 
   (define (locate-egg/http egg url #!optional version destination tests
-                           proxy-host proxy-port)
+                           proxy-host proxy-port proxy-user-pass)
     (let ([tmpdir (or destination (get-temporary-directory))])
       (let-values ([(host port locn) (deconstruct-url url)])
         (let ([locn (string-append
@@ -230 +230 @@
                      (if tests "&tests=yes" ""))]
               [eggdir (make-pathname tmpdir egg) ] )
           (unless (file-exists? eggdir) (create-directory eggdir))
-          (http-fetch host port locn eggdir proxy-host proxy-port)
+          (http-fetch host port locn eggdir proxy-host proxy-port proxy-user-pass)
           ; If we get here then version of egg exists
           (values eggdir (or version "")) ) ) ) )
 
@@ -249 +249 @@
                              (connection "close")
                              (accept "*")
                              (content-length 0)
-                             proxy-host proxy-port)
+                             proxy-host proxy-port proxy-user-pass)
     (conc
      "GET " 
      (if proxy-host 
@@ -260 +260 @@
      "User-Agent: " user-agent "\r\n"
      "Accept: " accept "\r\n"
      "Host: " host #\: port "\r\n"
+     (when proxy-user-pass
+     (string-append "Proxy-Authorization: Basic " proxy-user-pass "\r\n"))
      "Content-length: " content-length "\r\n"
      "\r\n") )
 
@@ -273 +275 @@
   (define (match-chunked-transfer-encoding ln)
     (irregex-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
 
-  (define (http-fetch host port locn dest proxy-host proxy-port)
+  (define (http-fetch host port locn dest proxy-host proxy-port proxy-user-pass)
     (d "connecting to host ~s, port ~a ~a...~%" host port
        (if proxy-host
            (sprintf "(via ~a:~a) " proxy-host proxy-port)
@@ -291 +293 @@
                [response-match (match-http-response h1)])
           (d "~a~%" h1)
           ;;*** handle redirects here
-          (unless (response-match-code? response-match 200)
-            (network-failure "invalid response from server" h1) )
+          (if (response-match-code? response-match 407)
+          (begin 
+            (let-values ([(inpx outpx) (tcp-connect proxy-host proxy-port)])
+              (set! in inpx) (set! out outpx))
+            (display
+              (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*"
+                            proxy-host: proxy-host proxy-port: proxy-port 
+                proxy-user-pass: proxy-user-pass)
+              out))
+          (unless (response-match-code? response-match 200)
+                      (network-failure "invalid response from server" h1)))
           (let loop ()
             (let ([ln (read-line in)])
               (unless (string-null? ln)
@@ -351 +362 @@
 
   (define (retrieve-extension name transport location
                               #!key version quiet destination username password tests
-                              proxy-host proxy-port trunk (mode 'default))
+                              proxy-host proxy-port proxy-user-pass trunk (mode 'default))
     (fluid-let ((*quiet* quiet)
                 (*trunk* trunk)
                 (*mode* mode))
@@ -361 +372 @@
         ((svn)
          (locate-egg/svn name location version destination username password) )
         ((http)
-         (locate-egg/http name location version destination tests proxy-host proxy-port) )
+         (locate-egg/http name location version destination tests proxy-host proxy-port proxy-user-pass) )
         (else
          (error "cannot retrieve extension unsupported transport" transport) ) ) ) )