raco pkg: improve package-source checking and error reporting
This commit is contained in:
Matthew Flatt
parent
d901504174
commit
e7d300d238
|
|
@ -8,84 +8,108 @@
|
|||
[(_ expr (values a ...))
|
||||
(check-equal? (call-with-values (lambda () expr) list) (list a ...))]))
|
||||
|
||||
(define (parse a b [bad-rx #f]
|
||||
#:link-dirs? [link-dirs? #f])
|
||||
(define reason #f)
|
||||
(define-values (name type) (package-source->name+type
|
||||
a b
|
||||
#:link-dirs? link-dirs?
|
||||
#:must-infer-name? #f
|
||||
#:complain (lambda (s r)
|
||||
(unless reason (set! reason r)))))
|
||||
(values name
|
||||
type
|
||||
(if reason
|
||||
(if bad-rx
|
||||
(not (regexp-match? bad-rx reason))
|
||||
#f)
|
||||
(not bad-rx))))
|
||||
|
||||
(define (run-pkg-tests)
|
||||
(check-equal-values? (package-source->name+type "" #f) (values #f #f))
|
||||
(check-equal-values? (parse "" #f #rx"ill-formed") (values #f #f #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "fish" #f) (values "fish" 'name))
|
||||
(check-equal-values? (package-source->name+type "fish" 'name) (values "fish" 'name))
|
||||
(check-equal-values? (package-source->name+type "fish!" 'name) (values #f 'name))
|
||||
(check-equal-values? (package-source->name+type "fish/" 'name) (values #f 'name))
|
||||
(check-equal-values? (package-source->name+type "fish123A_B-C" #f) (values "fish123A_B-C" 'name))
|
||||
(check-equal-values? (package-source->name+type "fish123A_B-C!" 'name) (values #f 'name))
|
||||
(check-equal-values? (parse "fish" #f) (values "fish" 'name #t))
|
||||
(check-equal-values? (parse "fish" 'name) (values "fish" 'name #t))
|
||||
(check-equal-values? (parse "fish!" 'name #rx"disallowed") (values #f 'name #f))
|
||||
(check-equal-values? (parse "fish/" 'name #rx"disallowed") (values #f 'name #f))
|
||||
(check-equal-values? (parse "fish123A_B-C" 'name) (values "fish123A_B-C" 'name #t))
|
||||
(check-equal-values? (parse "fish123A_B-C!" 'name #rx"disallowed") (values #f 'name #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "fish.plt" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.zip" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.tar" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.tgz" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.tar.gz" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "ocean/fish.tar.gz" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.plt" 'file) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.tar.gz" 'file) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish.other" 'file) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish" 'file) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "fish!" 'file) (values #f 'file))
|
||||
(check-equal-values? (parse "fish.plt" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.zip" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.tar" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.tgz" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.tar.gz" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "ocean/fish.tar.gz" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.plt" 'file) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.tar.gz" 'file) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "fish.other" 'file #rx"archive") (values "fish" 'file #f))
|
||||
(check-equal-values? (parse "fish" 'file #rx"archive") (values "fish" 'file #f))
|
||||
(check-equal-values? (parse "fish!" 'file #rx"archive") (values #f 'file #f))
|
||||
(check-equal-values? (parse "" 'file #rx"ill-formed") (values #f 'file #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "fish/" #f) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "./fish" #f) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "sub/fish" #f) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "fish/" 'dir) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "fish/" 'link) (values "fish" 'link))
|
||||
(check-equal-values? (package-source->name+type "fish" 'dir) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "fish!/" 'dir) (values #f 'dir))
|
||||
(check-equal-values? (parse "fish/" #f) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "./fish" #f) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "sub/fish" #f) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "fish/" 'dir) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "fish/" 'link) (values "fish" 'link #t))
|
||||
(check-equal-values? (parse "fish" 'dir) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "fish!/" 'dir) (values #f 'dir #t))
|
||||
(check-equal-values? (parse "/" 'dir #rx"no elements in path") (values #f 'dir #f))
|
||||
(check-equal-values? (parse (path->string (build-path 'same)) 'dir #rx"ending path") (values #f 'dir #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "fish/" #f #:link-dirs? #t) (values "fish" 'link))
|
||||
(check-equal-values? (package-source->name+type "fish/" 'dir #:link-dirs? #t) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "fish.plt" #f #:link-dirs? #t) (values "fish" 'file))
|
||||
(check-equal-values? (parse "fish/" #f #:link-dirs? #t) (values "fish" 'link #t))
|
||||
(check-equal-values? (parse "fish/" 'dir #:link-dirs? #t) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "fish.plt" #f #:link-dirs? #t) (values "fish" 'file #t))
|
||||
|
||||
(check-equal? (package-source->name "http://") #f)
|
||||
(check-equal-values? (parse "http://" #f #rx"path is empty") (values #f 'dir-url #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish.plt" #f) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "https://racket-lang.org/fish.plt" #f) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish.tar.gz" #f) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish" 'file-url) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "fish" 'file-url) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "dir/fish" 'file-url) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "fish/" 'file-url) (values "fish" 'file-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish!" 'file-url) (values #f 'file-url))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "https://racket-lang.org/fish.plt" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish.tar.gz" #f) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" 'file-url #rx"archive") (values "fish" 'file-url #f))
|
||||
(check-equal-values? (parse "fish.zip" 'file-url) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "dir/fish.zip" 'file-url) (values "fish" 'file-url #t))
|
||||
(check-equal-values? (parse "fish/" 'file-url #rx"archive") (values "fish" 'file-url #f))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish!.zip" 'file-url) (values #f 'file-url #t))
|
||||
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish/" #f) (values "fish" 'dir-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish/" 'dir-url) (values "fish" 'dir-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish" 'dir-url) (values "fish" 'dir-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish.plt" 'dir-url) (values #f 'dir-url))
|
||||
(check-equal-values? (package-source->name+type "http://racket-lang.org/fish" #f) (values "fish" 'dir-url))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish/" #f) (values "fish" 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish/" 'dir-url) (values "fish" 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" 'dir-url) (values "fish" 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish.plt" 'dir-url) (values #f 'dir-url #t))
|
||||
(check-equal-values? (parse "http://racket-lang.org/fish" #f) (values "fish" 'dir-url #t))
|
||||
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/master" #f) (values "fish" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish.rkt/master" #f) (values #f 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/release" #f) (values "fish" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/release/catfish" #f) (values "catfish" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/release/catfish/" #f) (values "catfish" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/release/catfish/bill" #f) (values "bill" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish/master" 'github) (values "fish" 'github))
|
||||
(check-equal-values? (package-source->name+type "racket/fish/master" 'github) (values "fish" 'github))
|
||||
(check-equal-values? (package-source->name+type "racket/fish/master/" 'github) (values "fish" 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/fish/master" 'github) (values #f 'github))
|
||||
(check-equal-values? (package-source->name+type "fish/master" 'github) (values #f 'github))
|
||||
(check-equal-values? (package-source->name+type "github://github.com/racket/fish.more/release" 'github) (values #f 'github))
|
||||
(check-equal-values? (parse "github://notgithub.com/racket/fish/master" #f #rx"github.com") (values #f 'github #f))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/master" #f) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish.rkt/master" #f) (values #f 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/release" #f) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish" #f) (values "catfish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish/" #f) (values "catfish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/release/catfish/bill" #f) (values "bill" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish/master" 'github) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "github://github.com/fish/master" 'github #rx"three") (values #f 'github #f))
|
||||
(check-equal-values? (parse "github://github.com/racket/fish.more/release" 'github) (values #f 'github #t))
|
||||
|
||||
(check-equal-values? (package-source->name+type "file://fish.plt" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "file:///root/fish.plt" #f) (values "fish" 'file))
|
||||
(check-equal-values? (package-source->name+type "file://fish" #f) (values "fish" 'dir))
|
||||
(check-equal-values? (package-source->name+type "file:///root/fish" #f) (values "fish" 'dir))
|
||||
(check-equal-values? (parse "racket/fish/master" 'github) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "racket/fish/master/" 'github) (values "fish" 'github #t))
|
||||
(check-equal-values? (parse "racket/fish" 'github #rx"three") (values #f 'github #f))
|
||||
(check-equal-values? (parse "fish" 'github #rx"three") (values #f 'github #f))
|
||||
|
||||
(check-equal-values? (package-source->name+type "random://racket-lang.org/fish.plt" #f) (values #f #f))
|
||||
(check-equal-values? (parse "file://fish.plt" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "file:///root/fish.plt" #f) (values "fish" 'file #t))
|
||||
(check-equal-values? (parse "file://fish" #f) (values "fish" 'dir #t))
|
||||
(check-equal-values? (parse "file:///root/fish" #f) (values "fish" 'dir #t))
|
||||
|
||||
(check-equal-values? (package-source->name+type "" #f) (values #f #f))
|
||||
(check-equal-values? (package-source->name+type "" 'file) (values #f 'file))
|
||||
(check-equal-values? (package-source->name+type "" 'link) (values #f 'link))
|
||||
(check-equal-values? (package-source->name+type "" 'static-link) (values #f 'static-link))
|
||||
(check-equal-values? (package-source->name+type "" 'file-url) (values #f 'file-url))
|
||||
(check-equal-values? (package-source->name+type "" 'dir-url) (values #f 'dir-url))
|
||||
(check-equal-values? (package-source->name+type "" 'github) (values #f 'github))
|
||||
(check-equal-values? (parse "random://racket-lang.org/fish.plt" #f #rx"scheme") (values #f #f #f))
|
||||
|
||||
(check-equal-values? (parse "" #f) (values #f #f #f))
|
||||
(check-equal-values? (parse "" 'file) (values #f 'file #f))
|
||||
(check-equal-values? (parse "" 'link) (values #f 'link #f))
|
||||
(check-equal-values? (parse "" 'static-link) (values #f 'static-link #f))
|
||||
(check-equal-values? (parse "" 'file-url) (values #f 'file-url #f))
|
||||
(check-equal-values? (parse "" 'dir-url) (values #f 'dir-url #f))
|
||||
(check-equal-values? (parse "" 'github #rx"empty") (values #f 'github #f))
|
||||
|
||||
(void))
|
||||
|
||||
|
|
|
|||
|
|
@ -796,6 +796,13 @@
|
|||
#:fail (lambda (s) #f)))
|
||||
c))]))
|
||||
|
||||
(define (complain-about-source s reason)
|
||||
(pkg-error (~a "invalid package source;\n"
|
||||
" ~a\n"
|
||||
" given: ~a")
|
||||
reason
|
||||
s))
|
||||
|
||||
;; Downloads a package (if needed) and unpacks it (if needed) into a
|
||||
;; temporary directory.
|
||||
(define (stage-package/info pkg
|
||||
|
|
@ -817,8 +824,13 @@
|
|||
(if link-dirs?
|
||||
'link
|
||||
'dir)
|
||||
'file)))
|
||||
(package-source->name+type pkg given-type #:link-dirs? link-dirs?)))
|
||||
'file))
|
||||
#:must-infer-name? (not given-pkg-name)
|
||||
#:complain complain-about-source)
|
||||
(package-source->name+type pkg given-type
|
||||
#:link-dirs? link-dirs?
|
||||
#:must-infer-name? (not given-pkg-name)
|
||||
#:complain complain-about-source)))
|
||||
(define pkg-name (or given-pkg-name inferred-pkg-name))
|
||||
(when (and type (not pkg-name))
|
||||
(pkg-error (~a "could not infer package name from source\n"
|
||||
|
|
@ -851,7 +863,7 @@
|
|||
" source: ~a")
|
||||
pkg))
|
||||
(match-define (list* user repo branch path)
|
||||
(map path/param-path (url-path/no-slash pkg-url)))
|
||||
(split-github-url pkg-url))
|
||||
(define new-url
|
||||
(url "https" #f "github.com" #f #t
|
||||
(map (λ (x) (path/param x empty))
|
||||
|
|
@ -1741,7 +1753,9 @@
|
|||
;; Infer the package-source type and name:
|
||||
(define-values (inferred-name type) (package-source->name+type
|
||||
(pkg-desc-source pkg-name)
|
||||
(pkg-desc-type pkg-name)))
|
||||
(pkg-desc-type pkg-name)
|
||||
#:must-infer-name? (not (pkg-desc-name pkg-name))
|
||||
#:complain complain-about-source))
|
||||
(define name (or (pkg-desc-name pkg-name)
|
||||
inferred-name))
|
||||
;; Check that the package is installed, and get current checksum:
|
||||
|
|
|
|||
|
|
@ -1,12 +1,16 @@
|
|||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/contract
|
||||
racket/format
|
||||
racket/string
|
||||
net/url)
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
[package-source->name+type (->* (string? (or/c #f symbol?))
|
||||
(#:link-dirs? boolean?)
|
||||
(#:complain (-> string? string? any)
|
||||
#:must-infer-name? boolean?
|
||||
#:link-dirs? boolean?)
|
||||
(values (or/c #f string?) (or/c #f symbol?)))]
|
||||
[package-source->name (->* (string?)
|
||||
((or/c #f symbol?))
|
||||
|
|
@ -15,19 +19,30 @@
|
|||
(define rx:package-name #rx"^[-_a-zA-Z0-9]+$")
|
||||
(define rx:archive #rx"[.](plt|zip|tar|tgz|tar[.]gz)$")
|
||||
|
||||
(define (validate-name name)
|
||||
(define (validate-name name complain inferred?)
|
||||
(and name
|
||||
(regexp-match? rx:package-name name)
|
||||
name))
|
||||
(cond
|
||||
[(regexp-match? rx:package-name name)
|
||||
name]
|
||||
[(equal? name "")
|
||||
(complain (~a (if inferred? "inferred " "")
|
||||
"package name is empty"))
|
||||
#f]
|
||||
[else
|
||||
(complain (~a (if inferred? "inferred " "")
|
||||
"package name includes disallowed characters"))
|
||||
#f])))
|
||||
|
||||
(define (extract-archive-name name+ext)
|
||||
(define (extract-archive-name name+ext complain)
|
||||
(validate-name
|
||||
(path->string
|
||||
(if (regexp-match #rx#"[.]tar[.]gz$" (if (path? name+ext)
|
||||
(path->bytes name+ext)
|
||||
name+ext))
|
||||
(path-replace-suffix (path-replace-suffix name+ext #"") #"")
|
||||
(path-replace-suffix name+ext #"")))))
|
||||
(path-replace-suffix name+ext #"")))
|
||||
complain
|
||||
#t))
|
||||
|
||||
(define (last-non-empty p)
|
||||
(cond
|
||||
|
|
@ -36,37 +51,60 @@
|
|||
(and (not (equal? "" (path/param-path (car p))))
|
||||
(path/param-path (car p))))]))
|
||||
|
||||
(define (package-source->name+type s type #:link-dirs? [link-dirs? #f])
|
||||
(define-syntax-rule (cor v complain)
|
||||
(or v (begin complain #f)))
|
||||
|
||||
(define (package-source->name+type s type
|
||||
#:link-dirs? [link-dirs? #f]
|
||||
#:complain [complain-proc void]
|
||||
#:must-infer-name? [must-infer-name? #f])
|
||||
;; returns (values inferred-name inferred-type);
|
||||
;; if `type' is given it should be returned, but name can be #f;
|
||||
;; type should not be #f for a non-#f name
|
||||
(define (complain msg)
|
||||
(complain-proc s msg))
|
||||
(define complain-name
|
||||
(if must-infer-name? complain void))
|
||||
(define (parse-path s)
|
||||
(cond
|
||||
[(if type
|
||||
(eq? type 'file)
|
||||
(and (path-string? s)
|
||||
(regexp-match rx:archive s)))
|
||||
(unless (path-string? s)
|
||||
(complain "ill-formed path"))
|
||||
(unless (regexp-match rx:archive s)
|
||||
(complain "path does not end with a recognized archive suffix"))
|
||||
(define-values (base name+ext dir?) (if (path-string? s)
|
||||
(split-path s)
|
||||
(values #f #f #f)))
|
||||
(define name (and name+ext (extract-archive-name name+ext)))
|
||||
(define name (and name+ext (extract-archive-name name+ext complain-name)))
|
||||
(values name 'file)]
|
||||
[(if type
|
||||
(or (eq? type 'dir)
|
||||
(eq? type 'link)
|
||||
(eq? type 'static-link))
|
||||
(path-string? s))
|
||||
(unless (path-string? s)
|
||||
(complain "ill-formed path"))
|
||||
(define-values (base name dir?) (if (path-string? s)
|
||||
(split-path s)
|
||||
(values #f #f #f)))
|
||||
(define dir-name (and (path? name) (path->string name)))
|
||||
(values (validate-name dir-name) (or type (and dir-name (if link-dirs? 'link 'dir))))]
|
||||
(define dir-name (and (cor (path? name)
|
||||
(if (not name)
|
||||
(complain "no elements in path")
|
||||
(complain "ending path element is not a name")))
|
||||
(path->string name)))
|
||||
(values (validate-name dir-name complain-name #t)
|
||||
(or type (and dir-name (if link-dirs? 'link 'dir))))]
|
||||
[else
|
||||
(complain "ill-formed path")
|
||||
(values #f #f)]))
|
||||
(cond
|
||||
[(if type
|
||||
(eq? type 'name)
|
||||
(regexp-match? rx:package-name s))
|
||||
(validate-name s complain #f)
|
||||
(values (and (regexp-match? rx:package-name s) s) 'name)]
|
||||
[(and (eq? type 'github)
|
||||
(not (regexp-match? #rx"^github://" s)))
|
||||
|
|
@ -87,34 +125,55 @@
|
|||
[(if type
|
||||
(eq? type 'github)
|
||||
(equal? (url-scheme url) "github"))
|
||||
(unless (equal? (url-scheme url) "github")
|
||||
(complain "URL scheme is not 'github'"))
|
||||
(define name
|
||||
(and (pair? p)
|
||||
(and (cor (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(cor (equal? "github.com" (url-host url))
|
||||
(complain "URL host is not 'github.com'"))
|
||||
(let ([p (if (equal? "" (path/param-path (last p)))
|
||||
(reverse (cdr (reverse p)))
|
||||
p)])
|
||||
(and ((length p) . >= . 3)
|
||||
(validate-name
|
||||
(and (cor ((length p) . >= . 3)
|
||||
(complain "URL does not have at least three path elements"))
|
||||
(validate-name
|
||||
(if (= (length p) 3)
|
||||
(path/param-path (second (reverse p)))
|
||||
(last-non-empty p)))))))
|
||||
(last-non-empty p))
|
||||
complain-name
|
||||
#t)))))
|
||||
(values name (or type 'github))]
|
||||
[(if type
|
||||
(eq? type 'file-url)
|
||||
(and (pair? p)
|
||||
(path/param? (last p))
|
||||
(regexp-match? rx:archive (path/param-path (last p)))))
|
||||
(unless (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(when (pair? p)
|
||||
(unless (path/param? (last p))
|
||||
(complain "URL's last path element is missing"))
|
||||
(unless (regexp-match? rx:archive (path/param-path (last p)))
|
||||
(complain "URL does not end with a recognized archive suffix")))
|
||||
(values (and (pair? p)
|
||||
(extract-archive-name (last-non-empty p)))
|
||||
(extract-archive-name (last-non-empty p) complain-name))
|
||||
'file-url)]
|
||||
[else
|
||||
(values (validate-name (last-non-empty p)) 'dir-url)]))
|
||||
(unless (pair? p)
|
||||
(complain "URL path is empty"))
|
||||
(when (pair? p)
|
||||
(unless (path/param? (last p))
|
||||
(complain "URL's last path element is missing")))
|
||||
(values (validate-name (last-non-empty p) complain-name #t) 'dir-url)]))
|
||||
(values #f #f)))
|
||||
(values (validate-name name) (or type (and name-type)))]
|
||||
(values (validate-name name complain-name #f) (or type (and name-type)))]
|
||||
[(and (not type)
|
||||
(regexp-match #rx"^file://(.*)$" s))
|
||||
=> (lambda (m) (parse-path (cadr m)))]
|
||||
[(and (not type)
|
||||
(regexp-match? #rx"^[a-zA-Z]*://" s))
|
||||
(complain "unreognized URL scheme")
|
||||
(values #f #f)]
|
||||
[else
|
||||
(parse-path s)]))
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
racket/port
|
||||
racket/match
|
||||
racket/format
|
||||
racket/string
|
||||
net/url
|
||||
json)
|
||||
|
||||
|
|
@ -51,6 +52,9 @@
|
|||
(define github-client_id (make-parameter #f))
|
||||
(define github-client_secret (make-parameter #f))
|
||||
|
||||
(define (split-github-url pkg-url)
|
||||
(map path/param-path (url-path/no-slash pkg-url)))
|
||||
|
||||
(define (package-url->checksum pkg-url-str [query empty]
|
||||
#:download-printf [download-printf void]
|
||||
#:pkg-name [pkg-name "package"])
|
||||
|
|
@ -59,7 +63,7 @@
|
|||
(match (url-scheme pkg-url)
|
||||
["github"
|
||||
(match-define (list* user repo branch path)
|
||||
(map path/param-path (url-path/no-slash pkg-url)))
|
||||
(split-github-url pkg-url))
|
||||
(define api-u
|
||||
(url "https" #f "api.github.com" #f #t
|
||||
(map (λ (x) (path/param x empty))
|
||||
|
|
@ -79,7 +83,7 @@
|
|||
#: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\n URL: ~a"
|
||||
(url->string api-u)))
|
||||
(define branches
|
||||
(read-json (open-input-bytes api-bs)))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user