From 9d43fcad3e5fb22146cb4435172b26571987bda0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
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
---
 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 72d87f56c3..f5ab4749fb 100644
--- a/collects/pkg/lib.rkt
+++ b/collects/pkg/lib.rkt
@@ -50,8 +50,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 c2ecc14c9b..f1f25df72d 100644
--- a/collects/pkg/util.rkt
+++ b/collects/pkg/util.rkt
@@ -9,6 +9,8 @@
          net/url
          json)
 
+(define-logger pkg)
+
 (define (make-parent-directory* p)
   (define parent (path-only p))
   (make-directory* parent))
@@ -29,9 +31,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)))
 
@@ -57,10 +61,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)))