support [plt_]{http,no}_proxy environment variables
The `current-proxy-servers` and `current-no-proxy-servers` parameters are initialized on-demand from environment variables.
This commit is contained in:
Tim Brown
Matthew Flatt
parent
76e27da8ba
commit
0b1d0610f2
|
|
@ -4,6 +4,7 @@
|
|||
racket/contract/base
|
||||
racket/list
|
||||
racket/match
|
||||
racket/promise
|
||||
(prefix-in hc: "http-client.rkt")
|
||||
(only-in "url-connect.rkt" current-https-protocol)
|
||||
"uri-codec.rkt"
|
||||
|
|
@ -23,27 +24,95 @@
|
|||
;; "impure" = they have text waiting
|
||||
;; "pure" = the MIME headers have been read
|
||||
|
||||
(define current-proxy-servers
|
||||
(make-parameter null
|
||||
(lambda (v)
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (v)
|
||||
(and (list? v)
|
||||
(= 3 (length v))
|
||||
(equal? (car v) "http")
|
||||
(string? (car v))
|
||||
(exact-integer? (caddr v))
|
||||
(<= 1 (caddr v) 65535)))
|
||||
v))
|
||||
(raise-type-error
|
||||
'current-proxy-servers
|
||||
"list of list of scheme, string, and exact integer in [1,65535]"
|
||||
(define proxiable-url-schemes '("http"))
|
||||
|
||||
(define (env->c-p-s-entries envars)
|
||||
(if (null? envars)
|
||||
null
|
||||
(match (getenv (car envars))
|
||||
[#f (env->c-p-s-entries (cdr envars))]
|
||||
["" null]
|
||||
[(app string->url
|
||||
(url (and scheme "http") #f (? string? host) (? integer? port)
|
||||
_ (list) (list) #f))
|
||||
(list (list scheme host port))]
|
||||
[(app string->url
|
||||
(url (and scheme "http") _ (? string? host) (? integer? port)
|
||||
_ _ _ _))
|
||||
(log-net/url-error "~s contains somewhat invalid proxy URL format" (car envars))
|
||||
(list (list scheme host port))]
|
||||
[inv (log-net/url-error "~s contained invalid proxy URL format: ~s"
|
||||
(car envars) inv)
|
||||
null])))
|
||||
|
||||
(define current-proxy-servers-promise
|
||||
(make-parameter (delay (env->c-p-s-entries '("plt_http_proxy" "http_proxy")))))
|
||||
|
||||
(define (proxy-servers-guard v)
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (v)
|
||||
(and (list? v)
|
||||
(= 3 (length v))
|
||||
(equal? (car v) "http")
|
||||
(string? (car v))
|
||||
(exact-integer? (caddr v))
|
||||
(<= 1 (caddr v) 65535)))
|
||||
v))
|
||||
(map (lambda (v)
|
||||
(list (string->immutable-string (car v))
|
||||
(string->immutable-string (cadr v))
|
||||
(caddr v)))
|
||||
v))))
|
||||
(raise-type-error
|
||||
'current-proxy-servers
|
||||
"list of list of scheme, string, and exact integer in [1,65535]"
|
||||
v))
|
||||
(map (lambda (v)
|
||||
(list (string->immutable-string (car v))
|
||||
(string->immutable-string (cadr v))
|
||||
(caddr v)))
|
||||
v))
|
||||
|
||||
(define current-proxy-servers
|
||||
(make-derived-parameter current-proxy-servers-promise
|
||||
(λ (v) (let ((guarded (proxy-servers-guard v)))
|
||||
(delay guarded)))
|
||||
force))
|
||||
|
||||
(define (env->n-p-s-entries envars)
|
||||
(if (null? envars)
|
||||
null
|
||||
(match (getenv (car envars))
|
||||
[#f (env->n-p-s-entries (cdr envars))]
|
||||
["" null]
|
||||
[hostnames (string-split hostnames ",")])))
|
||||
|
||||
(define current-no-proxy-servers-promise
|
||||
(make-parameter (delay (no-proxy-servers-guard (env->n-p-s-entries '("plt_no_proxy" "no_proxy"))))))
|
||||
|
||||
(define (no-proxy-servers-guard v)
|
||||
(unless (and (list? v)
|
||||
(andmap (lambda (v)
|
||||
(or (string? v)
|
||||
(regexp? v)))
|
||||
v))
|
||||
(raise-type-error 'current-no-proxy-servers
|
||||
"list of string or regexp"
|
||||
v))
|
||||
(map (match-lambda
|
||||
[(? regexp? re) re]
|
||||
[(regexp "^(\\..*)$" (list _ m))
|
||||
(regexp (string-append ".*" (regexp-quote m)))]
|
||||
[(? string? s) (regexp (string-append "^"(regexp-quote s)"$"))])
|
||||
v))
|
||||
|
||||
(define current-no-proxy-servers
|
||||
(make-derived-parameter current-no-proxy-servers-promise
|
||||
(λ (v)
|
||||
(let ((guarded (no-proxy-servers-guard v)))
|
||||
(delay guarded)))
|
||||
force))
|
||||
|
||||
(define (proxy-server-for url-schm (dest-host-name #f))
|
||||
(let ((rv (assoc url-schm (current-proxy-servers))))
|
||||
(cond [(not dest-host-name) rv]
|
||||
[(memf (lambda (np) (regexp-match np dest-host-name)) (current-no-proxy-servers)) #f]
|
||||
[else rv])))
|
||||
|
||||
(define (url-error fmt . args)
|
||||
(raise (make-url-exception
|
||||
|
|
@ -58,6 +127,7 @@
|
|||
(cond [(not scheme) 80]
|
||||
[(string=? scheme "http") 80]
|
||||
[(string=? scheme "https") 443]
|
||||
[(string=? scheme "git") 9418]
|
||||
[else (url-error "URL scheme ~s not supported" scheme)])))
|
||||
|
||||
;; make-ports : url -> hc
|
||||
|
|
@ -76,7 +146,7 @@
|
|||
;; -> hc
|
||||
(define (http://getpost-impure-port get? url post-data strings
|
||||
make-ports 1.1?)
|
||||
(define proxy (assoc (url-scheme url) (current-proxy-servers)))
|
||||
(define proxy (proxy-server-for (url-scheme url) (url-host url)))
|
||||
(define hc (make-ports url proxy))
|
||||
(define access-string
|
||||
(ensure-non-empty
|
||||
|
|
@ -326,7 +396,7 @@
|
|||
[(get) "GET"] [(post) "POST"] [(head) "HEAD"]
|
||||
[(put) "PUT"] [(delete) "DELETE"] [(options) "OPTIONS"]
|
||||
[else (url-error "unsupported method: ~a" method)])]
|
||||
[proxy (assoc (url-scheme url) (current-proxy-servers))]
|
||||
[proxy (proxy-server-for (url-scheme url) (url-host url))]
|
||||
[hc (make-ports url proxy)]
|
||||
[access-string
|
||||
(ensure-non-empty
|
||||
|
|
@ -387,7 +457,12 @@
|
|||
(listof string?)
|
||||
any)))
|
||||
(current-proxy-servers
|
||||
(parameter/c (or/c false/c (listof (list/c string? string? number?))))))
|
||||
(parameter/c (or/c false/c (listof (list/c string? string? number?)))))
|
||||
(current-no-proxy-servers
|
||||
(parameter/c (or/c false/c (listof (or/c string? regexp?)))))
|
||||
(proxy-server-for (->* (string?) ((or/c false/c string?))
|
||||
(or/c false/c (list/c string? string? number?))))
|
||||
(proxiable-url-schemes (listof string?)))
|
||||
|
||||
(define (http-sendrecv/url u
|
||||
#:method [method-bss #"GET"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user