Making github API keys part of the remote-package-checksum API so that the official catalog won't be blocked during routine updates

collects/meta/pkg-index/official/main.rkt

@@ -48,10 +48,8 @@
 (define users.new-path (build-path root "users.new"))
 (make-directory* users.new-path)
 
-(define (client_id)
+(github-client_id (file->string (build-path root "client_id")))
-  (file->string (build-path root "client_id")))
+(github-client_secret (file->string (build-path root "client_secret")))
-(define (client_secret)
-  (file->string (build-path root "client_secret")))
 
 (define pkgs-path (build-path root "pkgs"))
 (make-directory* pkgs-path)
@@ -708,9 +706,7 @@
     (printf "\tupdating ~a\n" pkg-name)
     (define new-checksum
       (package-url->checksum
-       (package-ref i 'source)
+       (package-ref i 'source)))
-       (list (cons 'client_id (client_id))
-             (cons 'client_secret (client_secret)))))
     (package-begin
      (define* i
        (hash-set i 'checksum
@@ -763,7 +759,7 @@
   (and
    (with-handlers ([exn:fail? (λ (x) #f)])
      (begin
-       (download-package-source! 
+       (download-package-source!
         (package-ref (package-info pkg) 'source)
         pd)
        #t))
@@ -852,10 +848,27 @@
    (λ ()
      (while true
        (printf "updating checksums\n")
-       (with-handlers ([exn:fail? void])
+       (let loop ([pkg*ts
-         (update-checksums #f (package-list)))
+                   (for/list ([pkg (in-list (package-list))])
-       ;; update once per day based on whenever the server started
+                     (cons pkg (thread (λ () (update-checksum #f pkg)))))]
-       (sleep (* 24 60 60)))))
+                  [the-alarm
+                   (alarm-evt (+ (current-inexact-milliseconds)
+                                 (* 1000 (* 24 60 60))))])
+         (apply
+          sync
+          (handle-evt the-alarm
+                      (λ _
+                        (for ([pkg*t (in-list pkg*ts)])
+                          (match-define (cons pkg t) pkg*t)
+                          (when (thread-running? t)
+                            (printf "~a checksum thread stalled\n" pkg)
+                            (kill-thread t)))))
+          (for/list ([pkg*t (in-list pkg*ts)])
+            (match-define (cons pkg t) pkg*t)
+            (handle-evt t
+                        (λ _
+                          (printf "~a thread finished\n" pkg)
+                          (loop (remove pkg*t pkg*ts) the-alarm)))))))))
   (serve/servlet
    main-dispatch
    #:command-line? #t

collects/meta/pkg-index/sync.sh

@@ -8,6 +8,6 @@ for i in official planet-compat ; do
     rsync -a --progress -h --delete plt-etc:local/galaxy/meta/pkg-index/$i/root/ $i/root/
 done
 
-rsync -a --progress -h --delete --exclude root --exclude compiled --exclude doc ../../pkg/ plt-etc:local/plt/collects/$i/
+rsync -a --progress -h --delete --exclude root --exclude compiled --exclude doc ../../pkg/ plt-etc:local/plt/collects/pkg/
 
 rsync -a --progress -h --delete --exclude compiled ../../web-server ../../net plt-etc:local/plt/collects/

collects/pkg/util.rkt

@@ -48,6 +48,9 @@
       rest]
      [_ rp])))
 
+(define github-client_id (make-parameter #f))
+(define github-client_secret (make-parameter #f))
+
 (define (package-url->checksum pkg-url-str [query empty]
                                #:download-printf [download-printf void])
   (define pkg-url
@@ -60,23 +63,30 @@
        (url "https" #f "api.github.com" #f #t
             (map (λ (x) (path/param x empty))
                  (list "repos" user repo "branches"))
-            query
+            (append query
+                    (if (and (github-client_id)
+                             (github-client_secret))
+                      (list (cons 'client_id (github-client_id))
+                            (cons 'client_secret (github-client_secret)))
+                      empty))
             #f))
      (download-printf "Querying GitHub\n")
      (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
-                           #:headers (list (format "User-Agent: raco-pkg/~a" (version)))))
+        api-u port->bytes
+        #:headers (list (format "User-Agent: raco-pkg/~a" (version)))))
      (unless api-bs
        (error 'package-url->checksum
-              "Could not connect to GitHub"))
+              "Could not connect to GitHub"
+              (url->string api-u)))
      (define branches
        (read-json (open-input-bytes api-bs)))
      (unless (and (list? branches)
                   (andmap hash? branches)
                   (andmap (λ (b) (hash-has-key? b 'name)) branches)
                   (andmap (λ (b) (hash-has-key? b 'commit)) branches))
-       (error 'package-url->checksum 
+       (error 'package-url->checksum
               "Invalid response from Github: ~e"
               api-bs))
      (for/or ([b (in-list branches)])
@@ -99,14 +109,14 @@
           (parameterize ([current-custodian c])
             (get-pure-port/headers url #:redirections 25 #:status? #t)))
         (begin0
-         (and (string=? "200" (substring hs 9 12))
+          (and (string=? "200" (substring hs 9 12))
-              (handler p))
+               (handler p))
-         (close-input-port p)))
+          (close-input-port p)))
       (lambda ()
         (custodian-shutdown-all c))))
 
 (define (read-from-server who url pred
-                          [failure 
+                          [failure
                            (lambda (s)
                              (error who
                                     (~a "bad response from server\n"
@@ -116,13 +126,13 @@
                                     s))])
   (define bytes (call-with-url url port->bytes))
   ((if bytes
-       (with-handlers ([exn:fail:read? (lambda (exn)
+     (with-handlers ([exn:fail:read? (lambda (exn)
-                                         (lambda () (failure bytes)))])
+                                       (lambda () (failure bytes)))])
-         (define v (read (open-input-bytes bytes)))
+       (define v (read (open-input-bytes bytes)))
-         (lambda ()
+       (lambda ()
-           (if (pred v)
+         (if (pred v)
-               v
+           v
-               (failure bytes))))
+           (failure bytes))))
-       (lambda () (failure #f)))))
+     (lambda () (failure #f)))))
 
 (provide (all-defined-out))