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

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

Browse Source
This commit is contained in:
Jay McCarthy 2013-04-28 07:18:53 -06:00
parent 568a621799
commit bbd24edb54
3 changed files with 53 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/meta/pkg-index/official/main.rkt
View File

@ -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

2
collects/meta/pkg-index/sync.sh
View File

@ -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/

16
collects/pkg/util.rkt
View File

@ -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
(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)