suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some safety and port maintenance (currently running out of file handles)

Browse Source
This commit is contained in:
Jay McCarthy 2016-07-20 10:41:07 -04:00 committed by Tony Garnock-Jones
parent d38f1c1f16
commit 09aa9050e2
3 changed files with 26 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/jsonp-client.rkt
View File

@ -44,12 +44,12 @@
(define extraction-expr (format "^callback~a\\((.*)\\);$" stamp)) (define extraction-expr (format "^callback~a\\((.*)\\);$" stamp))
(define parameters (cons (cons 'callback callback-label) original-parameters)) (define parameters (cons (cons 'callback callback-label) original-parameters))
(define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set"))) (define baseurl (or (jsonp-baseurl) (error 'jsonp-rpc! "jsonp-baseurl is not set")))
(define request-url (define request-urls
(string->url (format "~a~a?~a"
(format "~a~a?~a"
baseurl baseurl
site-relative-url site-relative-url
(alist->form-urlencoded parameters)))) (alist->form-urlencoded parameters)))
(define request-url (string->url request-urls))
(define req-headers (define req-headers
(if include-credentials? (if include-credentials?
(list (list
@ -65,10 +65,16 @@
(get-pure-port/headers request-url (get-pure-port/headers request-url
req-headers))) req-headers)))
(define raw-response (port->string body-port)) (define raw-response (port->string body-port))
(match-define (pregexp extraction-expr (list _ json)) raw-response) (close-input-port body-port)
(define reply (string->jsexpr json)) (match raw-response
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply)) [(pregexp extraction-expr (list _ json))
reply) (define reply (string->jsexpr json))
(unless sensitive? (log-info "jsonp-rpc: reply ~a" reply))
reply]
[x
(error 'jsonp-rpc! "Illegal response to ~v: ~v"
(if sensitive? "REDACTED" request-urls)
(if sensitive? "REDACTED" raw-response))]))
(define (simple-json-rpc! #:sensitive? [sensitive? #f] (define (simple-json-rpc! #:sensitive? [sensitive? #f]
#:include-credentials? [include-credentials? #t] #:include-credentials? [include-credentials? #t]
@ -96,6 +102,9 @@
(session-password s))) (session-password s)))
'())) '()))
(define raw-response (port->string (post-pure-port request-url post-data req-headers))) (define raw-response (port->string (post-pure-port request-url post-data req-headers)))
(define response-port (post-pure-port request-url post-data req-headers))
(define raw-response (port->string response-port))
(close-input-port response-port)
(define reply (string->jsexpr raw-response)) (define reply (string->jsexpr raw-response))
(unless sensitive? (log-info "simple-json-rpc: reply ~v" reply)) (unless sensitive? (log-info "simple-json-rpc: reply ~v" reply))
reply) reply)

6
src/packages.rkt
View File

@ -57,8 +57,10 @@
(lambda (e) (lambda (e)
((error-display-handler) (exn-message e) e) ((error-display-handler) (exn-message e) e)
#f)]) #f)])
(define response-bytes (define response-port
(port->bytes (get-pure-port (string->url package-index-url)))) (get-pure-port (string->url package-index-url)))
(define response-bytes (port->bytes response-port))
(close-input-port response-port)
(define decompressed (gunzip/bytes response-bytes)) (define decompressed (gunzip/bytes response-bytes))
(define decoded (bytes->jsexpr decompressed)) (define decoded (bytes->jsexpr decompressed))
decoded)) decoded))

8
src/site.rkt
View File

@ -1396,9 +1396,11 @@
package-name package-name
(exn->string e)) (exn->string e))
"")]) "")])
(port->string (define the-port
(get-pure-port (string->url (@ default-version source_url)) (get-pure-port (string->url (@ default-version source_url))
#:redirections 10))))) #:redirections 10))
(begin0 (port->string the-port)
(close-input-port the-port)))))
;;(log-info "CONTENTS: ~a === ~a" (@ default-version source_url) contents) ;;(log-info "CONTENTS: ~a === ~a" (@ default-version source_url) contents)
(if (regexp-match? #px"(?i:id=.readme.)" contents) (if (regexp-match? #px"(?i:id=.readme.)" contents)
(let ((readme-url (string-append (@ default-version source_url) "#readme"))) (let ((readme-url (string-append (@ default-version source_url) "#readme")))