~ chicken-core (chicken-5) 895a4d51277071deee6cfe0f0e2a04f0bc10813e
commit 895a4d51277071deee6cfe0f0e2a04f0bc10813e
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Nov 25 10:05:13 2009 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Nov 25 10:05:13 2009 +0100
proxy-support for chicken-install (suggested by Nicolas Pelletier)
diff --git a/chicken-install.scm b/chicken-install.scm
index 4b34f21c..f8b7e1b9 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -81,6 +81,8 @@
(define *default-location* #f)
(define *default-transport* 'http)
(define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
+ (define *proxy-host* #f)
+ (define *proxy-port* #f)
(define-constant +module-db+ "modules.db")
(define-constant +defaults-file+ "setup.defaults")
@@ -187,7 +189,9 @@
destination: (and *retrieve-only* (current-directory))
tests: *run-tests*
username: *username*
- password: *password*)
+ password: *password*
+ proxy-host: *proxy-host*
+ proxy-port: *proxy-port*)
[(exn net)
(print "TCP connect timeout")
(values #f "") ]
@@ -301,7 +305,8 @@
(if *no-install* " -e \"(setup-install-mode #f)\"" "")
(if *host-extension* " -e \"(host-extension #t)\"" "")
(if *prefix* (sprintf " -e \"(installation-prefix \\\"~a\\\")\"" *prefix*) "")
- #\space (shellpath (make-pathname (cadr e+d+v) (car e+d+v) "setup"))) )
+ #\space
+ (shellpath (make-pathname (cadr e+d+v) (car e+d+v) "setup"))) )
(define (install eggs)
(retrieve eggs)
@@ -388,6 +393,7 @@ usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
-k -keep keep temporary files
-l -location LOCATION install from given location instead of default
-t -transport TRANSPORT use given transport instead of default
+ -proxy HOST[:PORT] download via HTTP proxy
-s -sudo use sudo(1) for filesystem operations
-r -retrieve only retrieve egg into current directory, don't install
-n -no-install do not install, just build (implies `-keep')
@@ -474,6 +480,16 @@ EOF
(unless (pair? (cdr args)) (usage 1))
(init-repository (cadr args))
(exit 0))
+ ((string=? "-proxy" arg)
+ (unless (pair? (cdr args)) (usage 1))
+ (cond ((string-match "(.+)\\:([0-9]+)" (cadr args)) =>
+ (lambda (m)
+ (set! *proxy-host* (cadr m))
+ (set! *proxy-port* (string->number (caddr m)))))
+ (else
+ (set! *proxy-host* (cadr args))
+ (set! *proxy-port* 80)))
+ (loop (cddr args) eggs))
((string=? "-test" arg)
(set! *run-tests* #t)
(loop (cdr args) eggs))
diff --git a/manual/Extensions b/manual/Extensions
index e9103538..5cc4cd6b 100644
--- a/manual/Extensions
+++ b/manual/Extensions
@@ -457,6 +457,7 @@ Available options:
; {{-k -keep}} : keep temporary files
; {{-l -location LOCATION}} : install from given location instead of default
; {{-t -transport TRANSPORT}} : use given transport instead of default
+; {{-proxy HOST[:PORT]}} : connect via HTTP proxy
; {{-s -sudo}} : use {{sudo(1)}} for installing or removing files
; {{-r -retrieve}} : only retrieve egg into current directory, don't install
; {{-n -no-install}} : do not install, just build (implies {{-keep}})
diff --git a/setup-download.scm b/setup-download.scm
index 38c8fb64..9526d5ae 100644
--- a/setup-download.scm
+++ b/setup-download.scm
@@ -47,7 +47,6 @@
(tcp-write-timeout +default-tcp-read/write-timeout+)
(define *quiet* #f)
-
(define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
(define (d fstr . args)
@@ -161,7 +160,8 @@
80)
(if m (list-ref m 5) "/")) ) )
- (define (locate-egg/http egg url #!optional version destination tests)
+ (define (locate-egg/http egg url #!optional version destination tests
+ proxy-host proxy-port)
(let ([tmpdir (or destination (get-temporary-directory))])
(let-values ([(host port locn) (deconstruct-url url)])
(let ([locn (string-append
@@ -171,7 +171,7 @@
(if tests "&tests=yes" ""))]
[eggdir (make-pathname tmpdir egg) ] )
(unless (file-exists? eggdir) (create-directory eggdir))
- (http-fetch host port locn eggdir)
+ (http-fetch host port locn eggdir proxy-host proxy-port)
; If we get here then version of egg exists
(values eggdir (or version "")) ) ) ) )
@@ -189,9 +189,14 @@
(port 80)
(connection "close")
(accept "*")
- (content-length 0))
+ (content-length 0)
+ proxy-host proxy-port)
(conc
- "GET " location " HTTP/1.1" "\r\n"
+ "GET "
+ (if proxy-host
+ (string-append "http://" host location)
+ location)
+ " HTTP/1.1" "\r\n"
"Connection: " connection "\r\n"
"User-Agent: " user-agent "\r\n"
"Accept: " accept "\r\n"
@@ -209,12 +214,16 @@
(define (match-chunked-transfer-encoding ln)
(string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
- (define (http-fetch host port locn dest)
- (d "connecting to host ~s, port ~a ...~%" host port)
- (let-values ([(in out) (tcp-connect host port)])
+ (define (http-fetch host port locn dest proxy-host proxy-port)
+ (d "connecting to host ~s, port ~a ~a...~%" host port
+ (if proxy-host
+ (sprintf "(via ~a:~a) " proxy-host proxy-port)
+ ""))
+ (let-values ([(in out) (tcp-connect (or proxy-host host) (or proxy-port port))])
(d "requesting ~s ...~%" locn)
(display
- (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
+ (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*"
+ proxy-host: proxy-host proxy-port: proxy-port)
out)
(flush-output out)
(d "reading response ...~%")
@@ -279,7 +288,8 @@
(get-chunks (cons chunk data)) ) ) ) ) )
(define (retrieve-extension name transport location
- #!key version quiet destination username password tests)
+ #!key version quiet destination username password tests
+ proxy-host proxy-port)
(fluid-let ([*quiet* quiet])
(case transport
[(local)
@@ -288,7 +298,7 @@
[(svn)
(locate-egg/svn name location version destination username password) ]
[(http)
- (locate-egg/http name location version destination tests) ]
+ (locate-egg/http name location version destination tests proxy-host proxy-port) ]
[else
(error "cannot retrieve extension unsupported transport" transport) ] ) ) )
Trap