From 861ef7f721c7c6a2975bb4231f6479bce538e35b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 Apr 2013 07:33:21 -0600 Subject: [PATCH] raco pkg: GitHub API now requires a User-Agent Merge to v5.3.4 (cherry picked from commit 9d43fcad3e5fb22146cb4435172b26571987bda0) --- collects/pkg/lib.rkt | 2 -- collects/pkg/util.rkt | 14 ++++++++++---- 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/collects/pkg/lib.rkt b/collects/pkg/lib.rkt index 8c42717610..cfca7551a0 100644 --- a/collects/pkg/lib.rkt +++ b/collects/pkg/lib.rkt @@ -48,8 +48,6 @@ (for/list ([v (in-list l)]) (format "\n ~a" v))))) -(define-logger pkg) - (define (log-exn x what) (log-pkg-error (~a "failure ~a\n" " error: ~s") diff --git a/collects/pkg/util.rkt b/collects/pkg/util.rkt index a0f2cc23d4..5c94485695 100644 --- a/collects/pkg/util.rkt +++ b/collects/pkg/util.rkt @@ -8,6 +8,8 @@ net/url json) +(define-logger pkg) + (define (make-parent-directory* p) (define parent (path-only p)) (make-directory* parent)) @@ -28,9 +30,11 @@ (make-string (+ (- width (string-length col)) 4) #\space)))) (printf "\n"))) -(define (call/input-url+200 u fun) +(define (call/input-url+200 u fun #:headers [headers '()]) #;(printf "\t\tReading ~a\n" (url->string u)) - (define-values (ip hs) (get-pure-port/headers u #:redirections 25 #:status? #t)) + (define-values (ip hs) (get-pure-port/headers u headers + #:redirections 25 + #:status? #t)) (and (string=? "200" (substring hs 9 12)) (fun ip))) @@ -56,10 +60,12 @@ (list "repos" user repo "branches")) query #f)) + (log-pkg-debug "Querying GitHub at ~a" (url->string api-u)) (define api-bs - (call/input-url+200 api-u port->bytes)) + (call/input-url+200 api-u port->bytes + #:headers (list (format "User-Agent: raco-pkg/~a" (version))))) (unless api-bs - (error 'package-url->checksum + (error 'package-url->checksum "Could not connect to GitHub")) (define branches (read-json (open-input-bytes api-bs)))