139 lines
4.7 KiB
Racket
139 lines
4.7 KiB
Racket
#lang racket/base
|
|
(require racket/path
|
|
racket/list
|
|
racket/function
|
|
racket/file
|
|
racket/port
|
|
racket/match
|
|
racket/format
|
|
net/url
|
|
json)
|
|
|
|
(define-logger pkg)
|
|
|
|
(define (make-parent-directory* p)
|
|
(define parent (path-only p))
|
|
(make-directory* parent))
|
|
|
|
(define (table-display l)
|
|
(define how-many-cols (length (first l)))
|
|
(define max-widths
|
|
(for/list ([col (in-range how-many-cols)])
|
|
(apply max (map (compose string-length (curryr list-ref col)) l))))
|
|
(for ([row (in-list l)])
|
|
(for ([col (in-list row)]
|
|
[i (in-naturals 1)]
|
|
[width (in-list max-widths)])
|
|
(printf "~a~a"
|
|
col
|
|
(if (= i how-many-cols)
|
|
""
|
|
(make-string (+ (- width (string-length col)) 4) #\space))))
|
|
(printf "\n")))
|
|
|
|
(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 headers
|
|
#:redirections 25
|
|
#:status? #t))
|
|
(and (string=? "200" (substring hs 9 12))
|
|
(fun ip)))
|
|
|
|
(define (url-path/no-slash url)
|
|
(define p (url-path url))
|
|
(define rp (reverse p))
|
|
(reverse
|
|
(match rp
|
|
[(list* (path/param "" _) rest)
|
|
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
|
|
(string->url pkg-url-str))
|
|
(match (url-scheme pkg-url)
|
|
["github"
|
|
(match-define (list* user repo branch path)
|
|
(map path/param-path (url-path/no-slash pkg-url)))
|
|
(define api-u
|
|
(url "https" #f "api.github.com" #f #t
|
|
(map (λ (x) (path/param x empty))
|
|
(list "repos" user repo "branches"))
|
|
(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)))))
|
|
(unless api-bs
|
|
(error 'package-url->checksum
|
|
"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
|
|
"Invalid response from Github: ~e"
|
|
api-bs))
|
|
(for/or ([b (in-list branches)])
|
|
(and (equal? (hash-ref b 'name) branch)
|
|
(hash-ref (hash-ref b 'commit) 'sha)))]
|
|
[_
|
|
(define u (string-append pkg-url-str ".CHECKSUM"))
|
|
(download-printf "Downloading checksum\n")
|
|
(log-pkg-debug "Downloading checksum as ~a" u)
|
|
(call/input-url+200 (string->url u)
|
|
port->string)]))
|
|
|
|
;; uses a custodian to avoid leaks:
|
|
(define (call-with-url url handler)
|
|
(define c (make-custodian))
|
|
(dynamic-wind
|
|
void
|
|
(lambda ()
|
|
(define-values (p hs)
|
|
(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)))
|
|
(lambda ()
|
|
(custodian-shutdown-all c))))
|
|
|
|
(define (read-from-server who url pred
|
|
[failure
|
|
(lambda (s)
|
|
(error who
|
|
(~a "bad response from server\n"
|
|
" url: ~a\n"
|
|
" response: ~v")
|
|
(url->string url)
|
|
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)))))
|
|
|
|
(provide (all-defined-out))
|