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)
-  (file->string (build-path root "client_id")))
-(define (client_secret)
-  (file->string (build-path root "client_secret")))
+(github-client_id (file->string (build-path root "client_id")))
+(github-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)
-       (list (cons 'client_id (client_id))
-             (cons 'client_secret (client_secret)))))
+       (package-ref i 'source)))
     (package-begin
      (define* i
        (hash-set i 'checksum
@@ -852,10 +848,27 @@
    (λ ()
      (while true
        (printf "updating checksums\n")
-       (with-handlers ([exn:fail? void])
-         (update-checksums #f (package-list)))
-       ;; update once per day based on whenever the server started
-       (sleep (* 24 60 60)))))
+       (let loop ([pkg*ts
+                   (for/list ([pkg (in-list (package-list))])
+                     (cons pkg (thread (λ () (update-checksum #f pkg)))))]
+                  [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,16 +63,23 @@
        (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
-                           #:headers (list (format "User-Agent: raco-pkg/~a" (version)))))
+       (call/input-url+200
+        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)
@@ -99,9 +109,9 @@
           (parameterize ([current-custodian c])
             (get-pure-port/headers url #:redirections 25 #:status? #t)))
         (begin0
-         (and (string=? "200" (substring hs 9 12))
-              (handler p))
-         (close-input-port p)))
+          (and (string=? "200" (substring hs 9 12))
+               (handler p))
+          (close-input-port p)))
       (lambda ()
         (custodian-shutdown-all c))))
 
@@ -116,13 +126,13 @@
                                     s))])
   (define bytes (call-with-url url port->bytes))
   ((if bytes
-       (with-handlers ([exn:fail:read? (lambda (exn)
-                                         (lambda () (failure bytes)))])
-         (define v (read (open-input-bytes bytes)))
-         (lambda ()
-           (if (pred v)
-               v
-               (failure bytes))))
-       (lambda () (failure #f)))))
+     (with-handlers ([exn:fail:read? (lambda (exn)
+                                       (lambda () (failure bytes)))])
+       (define v (read (open-input-bytes bytes)))
+       (lambda ()
+         (if (pred v)
+           v
+           (failure bytes))))
+     (lambda () (failure #f)))))
 
 (provide (all-defined-out))