Bring site (closer to being) into line with package source spec
This commit is contained in:
Tony Garnock-Jones
parent
750cbf5b5d
commit
4776595e79
160
src/package-source.rkt
Normal file
160
src/package-source.rkt
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
#lang racket/base
|
||||
;; Package Source URLs: their various kinds
|
||||
|
||||
;; Here we're only interested in remote URLs -- http, https, git and
|
||||
;; github. Local file and directory package sources are not to be
|
||||
;; accepted.
|
||||
|
||||
(provide parse-package-source
|
||||
parsed-package-source-human-url
|
||||
parsed-package-source-human-tree-url
|
||||
unparse-package-source
|
||||
package-source->human-tree-url
|
||||
(struct-out parsed-package-source)
|
||||
(struct-out simple-url-source)
|
||||
(struct-out git-source))
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in racket/string string-join string-split))
|
||||
(require net/url)
|
||||
(require pkg/private/repo-path)
|
||||
(require pkg/name)
|
||||
|
||||
;; A ParsedPackageSource is one of
|
||||
;; -- (simple-url-source String (Option String) (Option Symbol))
|
||||
;; -- (git-source String (Option String) Symbol Symbol String (Option Number) String String String)
|
||||
(struct parsed-package-source (url-string inferred-name type) #:prefab)
|
||||
(struct simple-url-source parsed-package-source () #:prefab)
|
||||
(struct git-source parsed-package-source (transport host port repo commit path) #:prefab)
|
||||
|
||||
;; String -> (Values (Option ParsedPackageSource) (Listof String))
|
||||
;; The second result is a list of complaints about the passed-in package source URL string.
|
||||
(define (parse-package-source p)
|
||||
(define complaints '())
|
||||
(define (complain message) (set! complaints (append complaints (list message))))
|
||||
|
||||
(define-values (name type)
|
||||
(with-handlers ([void (lambda (e) (values #f #f))])
|
||||
(package-source->name+type p #f
|
||||
#:complain (lambda (_p message) (complain message))
|
||||
#:must-infer-name? #t)))
|
||||
|
||||
(define parsed-source
|
||||
(match type
|
||||
[#f
|
||||
(complain "couldn't guess package source type")
|
||||
(simple-url-source p name type)]
|
||||
|
||||
;; ['name] -- only ever returned if it was passed in as second arg to package-source->name+type
|
||||
;; ['clone] -- only returned if passed in, like 'name
|
||||
;; ['link] -- only returned if #:link-dirs? given, except if it's a file:// url with a type query parameter of link
|
||||
;; ['static-link] -- only returned if it's a file:// url with a type query parameter of static-link
|
||||
|
||||
[(or 'file 'dir)
|
||||
(complain "local file or directory package source types are not permitted")
|
||||
#f]
|
||||
|
||||
[(or 'git 'github)
|
||||
(with-handlers ([void (lambda (e) (simple-url-source p name type))])
|
||||
(define u (string->url p))
|
||||
(define-values (transport host port repo commit path) (split-git-or-hub-url u #:type type))
|
||||
(git-source p name type
|
||||
(if (eq? type 'github) 'git transport)
|
||||
host
|
||||
port
|
||||
repo
|
||||
commit
|
||||
(string-join path "/")))]
|
||||
|
||||
[(or 'file-url 'dir-url)
|
||||
(with-handlers ([void (lambda (e) (simple-url-source p name type))])
|
||||
(define u (string->url p)) ;; just to check it *can* be parsed as a URL
|
||||
(simple-url-source p name type))]))
|
||||
|
||||
(values parsed-source complaints))
|
||||
|
||||
(define (parsed-package-source-human-url s)
|
||||
(match s
|
||||
[(git-source u _ type _ host port repo _ _)
|
||||
(real-git-url (string->url u) host port repo #:type type)]
|
||||
[(simple-url-source u _ _)
|
||||
u]))
|
||||
|
||||
(define (parsed-package-source-human-tree-url s)
|
||||
(match s
|
||||
[(git-source _ _ _ _ "github.com" _ repo commit path)
|
||||
(url->string
|
||||
(url "https"
|
||||
#f
|
||||
"github.com"
|
||||
#f
|
||||
#t
|
||||
(append (->url-path (regexp-replace #rx"[.]git$" repo ""))
|
||||
(list (path/param "tree" '())
|
||||
(path/param commit '()))
|
||||
(->url-path path))
|
||||
'()
|
||||
#f))]
|
||||
[_ (parsed-package-source-human-url s)]))
|
||||
|
||||
(define (unparse-package-source s)
|
||||
(match s
|
||||
[(git-source _ _ _ transport host port repo commit path)
|
||||
(url->string
|
||||
(url (symbol->string transport)
|
||||
#f
|
||||
host
|
||||
port
|
||||
#t
|
||||
(->url-path repo)
|
||||
(match path ["" '()] [_ (list (cons 'path path))])
|
||||
(match commit [#f #f] ["master" #f] [_ commit])))]
|
||||
[(simple-url-source u _ _)
|
||||
u]))
|
||||
|
||||
(define (->url-path str)
|
||||
(map (lambda (s) (path/param s '())) (string-split str "/")))
|
||||
|
||||
(define (package-source->human-tree-url source)
|
||||
(define-values (parsed complaints) (parse-package-source source))
|
||||
(if parsed (parsed-package-source-human-tree-url parsed) source))
|
||||
|
||||
(module+ test
|
||||
(define test-data
|
||||
(list
|
||||
"http://github.com/test/repo.git"
|
||||
"https://github.com/test/repo.git"
|
||||
"http://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
|
||||
"git://leastfixedpoint.com:55555/foo/bar.git?path=zot/quux/baz#release"
|
||||
"github://github.com/foo/bar/master"
|
||||
"github://github.com/foo/bar.git/master"
|
||||
"github://github.com/foo/bar.git/release/zot/quux/baz"
|
||||
"github://github.com/foo/bar/release/zot/quux/baz"
|
||||
"github://github.com/tonyg/racket-ansi.git/master"
|
||||
"github://github.com/tonyg/racket-ansi/master"
|
||||
))
|
||||
|
||||
(require rackunit)
|
||||
(require racket/set)
|
||||
|
||||
(define seen-types
|
||||
(for/set ((p test-data))
|
||||
(define-values (name type) (package-source->name+type p #f))
|
||||
type))
|
||||
|
||||
(define expected-types
|
||||
(set 'git 'github 'file-url 'dir-url))
|
||||
|
||||
(check-equal? (set) (set-subtract seen-types expected-types))
|
||||
(check-equal? (set) (set-subtract expected-types seen-types))
|
||||
|
||||
(for ((p test-data))
|
||||
(define-values (parsed-source complaints) (parse-package-source p))
|
||||
(printf "~v:\n - ~v\n - ~v\n - ~v\n"
|
||||
p
|
||||
parsed-source
|
||||
complaints
|
||||
(unparse-package-source parsed-source))
|
||||
(void)
|
||||
)
|
||||
)
|
||||
172
src/site.rkt
172
src/site.rkt
|
|
@ -28,6 +28,7 @@
|
|||
(require "config.rkt")
|
||||
(require "hash-utils.rkt")
|
||||
(require "static.rkt")
|
||||
(require "package-source.rkt")
|
||||
|
||||
(define static-urlprefix
|
||||
(or (@ (config) static-urlprefix)
|
||||
|
|
@ -58,7 +59,9 @@
|
|||
(or (@ (config) backend-baseurl)
|
||||
"https://pkgd.racket-lang.org"))
|
||||
|
||||
(define default-empty-source-url "git://github.com//")
|
||||
(define default-empty-parsed-package-source
|
||||
(git-source "git://github.com/" #f 'git 'git "github.com" #f "" "" ""))
|
||||
|
||||
(define COOKIE "pltsession")
|
||||
|
||||
(define recent-seconds
|
||||
|
|
@ -801,7 +804,7 @@
|
|||
;; " Download")
|
||||
)
|
||||
`(a ((class "btn btn-default btn-lg")
|
||||
(href ,(@ default-version source_url)))
|
||||
(href ,(package-source->human-tree-url (@ default-version source))))
|
||||
,(glyphicon 'link) " Code"))
|
||||
|
||||
,@(maybe-splice
|
||||
|
|
@ -895,7 +898,8 @@
|
|||
(((version-sym v) (in-hash vs)))
|
||||
`(tr
|
||||
(td ,(~a version-sym))
|
||||
(td (a ((href ,(@ v source_url)))
|
||||
(td (a ((href ,(package-source->human-tree-url
|
||||
(@ v source))))
|
||||
,(@ v source)))
|
||||
(td ,(@ v checksum)))))))))
|
||||
(tr (th "Last checked")
|
||||
|
|
@ -927,7 +931,7 @@
|
|||
""
|
||||
(list (current-email))
|
||||
'()
|
||||
`(("default" ,default-empty-source-url))))]
|
||||
`(("default" ,default-empty-parsed-package-source))))]
|
||||
[else
|
||||
(package-form #f
|
||||
(draft-package package-name-str
|
||||
|
|
@ -936,7 +940,9 @@
|
|||
(package-authors pkg)
|
||||
(package-tags pkg)
|
||||
(for/list (((ver info) (in-hash (package-versions pkg))))
|
||||
(list (symbol->string ver) (@ info source)))))])))
|
||||
(define-values (parsed complaints)
|
||||
(parse-package-source (@ info source)))
|
||||
(list (symbol->string ver) parsed))))])))
|
||||
|
||||
(define (package-source-option source-type value label)
|
||||
`(option ((value ,value)
|
||||
|
|
@ -958,7 +964,7 @@
|
|||
(th "Source"))
|
||||
,@(for/list ((v (put-default-first
|
||||
(draft-package-versions draft))))
|
||||
(match-define (list version source) v)
|
||||
(match-define (list version parsed-source) v)
|
||||
(define (control-name c) (format "version__~a__~a" version c))
|
||||
(define (group-name c) (format "version__~a__~a__group" version c))
|
||||
(define (textfield name label-text value [placeholder ""])
|
||||
|
|
@ -967,16 +973,27 @@
|
|||
(and label-text (label (control-name name) label-text))
|
||||
0 (if label-text 9 12)
|
||||
(text-input (control-name name) value #:placeholder placeholder)))
|
||||
(define-values (source-type simple-url g-host g-user g-project g-branch)
|
||||
(match source
|
||||
[(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?"
|
||||
(list _ u p _ b))
|
||||
(values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))]
|
||||
[(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?"
|
||||
(list _ h u p _ b))
|
||||
(values "git" "" h u p (if (equal? b "master") "" (or b "")))]
|
||||
[_
|
||||
(values "simple" source "" "" "" "")]))
|
||||
(define-values (source-type simple-url g-transport g-host+port g-repo g-commit g-path)
|
||||
(match parsed-source
|
||||
[#f
|
||||
(values "simple" "" "" "" "" "" "")]
|
||||
[(simple-url-source u _ _)
|
||||
(values "simple" u "" "" "" "" "")]
|
||||
[(git-source _ _ _ tr host port repo c path)
|
||||
(values "git"
|
||||
""
|
||||
(symbol->string tr)
|
||||
(match* (tr port)
|
||||
[(_ #f) host]
|
||||
[(http 80) host]
|
||||
[(https 443) host]
|
||||
[(git 9418) host]
|
||||
[(_ _) (format "~a:~a" host port)])
|
||||
repo
|
||||
(match c
|
||||
["master" ""]
|
||||
[_ c])
|
||||
path)]))
|
||||
`(tr
|
||||
(td ,version
|
||||
,@(maybe-splice
|
||||
|
|
@ -992,9 +1009,6 @@
|
|||
(select ((class "package-version-source-type")
|
||||
(data-packageversion ,version)
|
||||
(name ,(control-name "type")))
|
||||
,(package-source-option source-type
|
||||
"github"
|
||||
"Github Repository")
|
||||
,(package-source-option source-type
|
||||
"git"
|
||||
"Git Repository")
|
||||
|
|
@ -1011,10 +1025,21 @@
|
|||
(disabled "disabled")
|
||||
(id ,(control-name "urlpreview"))))))
|
||||
,(textfield "simple_url" #f simple-url)
|
||||
,(textfield "g_host" "Repo Host" g-host)
|
||||
,(textfield "g_user" "Repo User" g-user)
|
||||
,(textfield "g_project" "Repo Project" g-project)
|
||||
,(textfield "g_branch" "Repo Branch" g-branch "master"))))))
|
||||
,(textfield "g_host_port" "Host" g-host+port)
|
||||
,(textfield "g_repo" "Repository" g-repo "user/repo")
|
||||
,(textfield "g_commit" "Branch or commit" g-commit "master")
|
||||
,(textfield "g_path" "Path within repository" g-path)
|
||||
,(row #:id (group-name "g_transport")
|
||||
0 3
|
||||
(label (control-name "g_transport") "Transport")
|
||||
0 9
|
||||
`(select ((id ,(control-name "g_transport"))
|
||||
(name ,(control-name "g_transport")))
|
||||
,@(for/list [(t (list "git" "https" "http"))]
|
||||
`(option ((value ,t)
|
||||
,@(maybe-splice (equal? t g-transport)
|
||||
'(selected "selected")))
|
||||
,t)))))))))
|
||||
|
||||
(tr (td ((colspan "2"))
|
||||
(div ((class "form-inline"))
|
||||
|
|
@ -1130,13 +1155,13 @@
|
|||
draft)]
|
||||
[else
|
||||
(package-form #f (struct-copy draft-package draft
|
||||
[versions (cons (list new_version default-empty-source-url)
|
||||
(draft-package-versions draft))]))])]
|
||||
[versions (cons (list new_version default-empty-parsed-package-source)
|
||||
(draft-package-versions draft))]))])]
|
||||
[(regexp #px"^version__(.*)__delete$" (list _ version))
|
||||
(package-form #f (struct-copy draft-package draft
|
||||
[versions (filter (lambda (v)
|
||||
(not (equal? (car v) version)))
|
||||
(draft-package-versions draft))]))]))
|
||||
[versions (filter (lambda (v)
|
||||
(not (equal? (car v) version)))
|
||||
(draft-package-versions draft))]))]))
|
||||
|
||||
(define (read-draft-form draft bindings)
|
||||
(define (g key d)
|
||||
|
|
@ -1147,15 +1172,33 @@
|
|||
(g (string->symbol (format "version__~a__~a" version name)) d))
|
||||
(define type (vg 'type "simple"))
|
||||
(define simple_url (vg 'simple_url ""))
|
||||
(define g_host (vg 'g_host ""))
|
||||
(define g_user (vg 'g_user ""))
|
||||
(define g_project (vg 'g_project ""))
|
||||
(define g_branch0 (vg 'g_branch ""))
|
||||
(define g_branch (if (equal? g_branch0 "") "master" g_branch0))
|
||||
(match type
|
||||
["github" (format "github://github.com/~a/~a/~a" g_user g_project g_branch)]
|
||||
["git" (format "git://~a/~a/~a/~a" g_host g_user g_project g_branch)]
|
||||
["simple" simple_url]))
|
||||
(define g_transport (vg 'g_transport ""))
|
||||
(define g_host_port (vg 'g_host_port ""))
|
||||
(define g_repo0 (vg 'g_repo ""))
|
||||
(define g_repo (cond
|
||||
[(regexp-match #rx"[.]git$" g_repo0) g_repo0]
|
||||
[(equal? g_transport "git") g_repo0]
|
||||
[else (string-append g_repo0 ".git")]))
|
||||
(define g_commit0 (vg 'g_commit ""))
|
||||
(define g_path (vg 'g_path ""))
|
||||
(define g_commit (if (equal? g_commit0 "") "master" g_commit0))
|
||||
(define-values (g_host g_port)
|
||||
(match (string-split g_host_port ":")
|
||||
[(list host) (values host #f)]
|
||||
[(list host (? string->number port)) (values host (string->number port))]
|
||||
[_ (values "" #f)]))
|
||||
(define source
|
||||
(match type
|
||||
["simple" simple_url]
|
||||
["git" (unparse-package-source (git-source "" #f #f
|
||||
(string->symbol g_transport)
|
||||
g_host
|
||||
g_port
|
||||
g_repo
|
||||
g_commit
|
||||
g_path))]))
|
||||
(define-values (parsed complaints) (parse-package-source source))
|
||||
parsed)
|
||||
(struct-copy draft-package draft
|
||||
[name (g 'name (draft-package-old-name draft))]
|
||||
[description (g 'description "")]
|
||||
|
|
@ -1175,7 +1218,7 @@
|
|||
(define (save-draft! draft)
|
||||
(match-define (draft-package old-name name description authors tags versions/default) draft)
|
||||
(define default-version (assoc "default" versions/default))
|
||||
(define source (cadr default-version))
|
||||
(define source (unparse-package-source (cadr default-version)))
|
||||
(define versions (remove default-version versions/default))
|
||||
(define old-pkg (package-detail (string->symbol old-name)))
|
||||
;; name, description, and default source are updateable via /jsonp/package/modify.
|
||||
|
|
@ -1240,53 +1283,16 @@
|
|||
|
||||
(define (friendly-versions draft-versions)
|
||||
(for/hash ((v draft-versions))
|
||||
(match-define (list version source) v)
|
||||
(match-define (list version parsed) v)
|
||||
(values (string->symbol version)
|
||||
(hash 'checksum ""
|
||||
'source source
|
||||
'source_url (package-url->useful-url source)))))
|
||||
|
||||
;; Copied from meta/pkg-index/official/static.rkt
|
||||
;; Modified slightly to recognise additional ad-hockery
|
||||
;; e.g. git://github.com/user/repo/ as well as
|
||||
;; git://github.com/user/repo (note no trailing slash)
|
||||
;;
|
||||
;; N.B. this code is currently only used for the version of a package
|
||||
;; just after saving it locally, before the package server catches up!
|
||||
;; The package server uses its own version of this code and generates
|
||||
;; its own source_url. In principle, TODO: ignore source_url from the
|
||||
;; package server in cases where this code can do better. (Perhaps
|
||||
;; fall back to the source_url from the package server.)
|
||||
;;
|
||||
(define (package-url->useful-url pkg-url-str)
|
||||
(define pkg-url
|
||||
(string->url pkg-url-str))
|
||||
(match (url-scheme pkg-url)
|
||||
["github"
|
||||
(match (url-path pkg-url)
|
||||
[(list* user repo branch path)
|
||||
(url->string
|
||||
(struct-copy
|
||||
url pkg-url
|
||||
[scheme "http"]
|
||||
[path (list* user repo (path/param "tree" '()) branch path)]))]
|
||||
[_
|
||||
pkg-url-str])]
|
||||
["git"
|
||||
(match (map path/param-path (url-path pkg-url))
|
||||
;; xxx make this more robust
|
||||
[(or (list user repo)
|
||||
(list user repo ""))
|
||||
(url->string
|
||||
(struct-copy
|
||||
url pkg-url
|
||||
[scheme "http"]
|
||||
[path (map (lambda (x) (path/param x '()))
|
||||
(list user repo "tree" "master"))]))]
|
||||
[_
|
||||
pkg-url-str])]
|
||||
[_
|
||||
pkg-url-str]))
|
||||
'source (unparse-package-source parsed)
|
||||
;; N.B. the source_url setting here survives only while we have saved it
|
||||
;; locally, before the package server catches up! The package server
|
||||
;; uses its own version of this code and generates its own source_url.
|
||||
;; However, we ignore source_url from the package server now that
|
||||
;; parsed-package-source-human-tree-url can do better.
|
||||
'source_url (parsed-package-source-human-tree-url parsed)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
|
|||
|
|
@ -18,34 +18,30 @@ function preenSourceType(e) {
|
|||
}
|
||||
return control(e, n).val();
|
||||
}
|
||||
function showhide(s, gh, gu, gp, gb) {
|
||||
function showhide(s, gt, gh, gr, gc, gp) {
|
||||
return [showhide1("simple_url", s),
|
||||
showhide1("g_host", gh),
|
||||
showhide1("g_user", gu),
|
||||
showhide1("g_project", gp),
|
||||
showhide1("g_branch", gb)];
|
||||
showhide1("g_transport", gt),
|
||||
showhide1("g_host_port", gh),
|
||||
showhide1("g_repo", gr),
|
||||
showhide1("g_commit", gc),
|
||||
showhide1("g_path", gp)];
|
||||
}
|
||||
var pieces;
|
||||
var previewUrl;
|
||||
var previewGroup = control(e, "urlpreview__group");
|
||||
var previewInput = control(e, "urlpreview");
|
||||
switch (e.value) {
|
||||
case "github":
|
||||
previewGroup.show();
|
||||
pieces = showhide(false, false, true, true, true);
|
||||
previewUrl = "github://github.com/" + pieces[2] + "/" + pieces[3] +
|
||||
(pieces[4] ? "/" + pieces[4] : "");
|
||||
break;
|
||||
case "git":
|
||||
previewGroup.show();
|
||||
pieces = showhide(false, true, true, true, true);
|
||||
previewUrl = "git://" + pieces[1] + "/" + pieces[2] + "/" + pieces[3] +
|
||||
(pieces[4] ? "/" + pieces[4] : "");
|
||||
pieces = showhide(false, true, true, true, true, true);
|
||||
previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
|
||||
(pieces[5] ? "?path=" + pieces[5] : "") +
|
||||
(pieces[4] && (pieces[4] !== 'master') ? '#' + pieces[4] : "");
|
||||
break;
|
||||
case "simple":
|
||||
default:
|
||||
previewGroup.hide();
|
||||
pieces = showhide(true, false, false, false, false);
|
||||
pieces = showhide(true, false, false, false, false, false);
|
||||
previewUrl = pieces[0];
|
||||
break;
|
||||
}
|
||||
|
|
@ -74,7 +70,7 @@ $(document).ready(function () {
|
|||
$(".package-version-source-type").each(function (index, e) {
|
||||
var preenE = function () { preenSourceType(e); };
|
||||
$(e).change(preenE);
|
||||
var names = ['simple_url', 'g_host', 'g_user', 'g_project', 'g_branch'];
|
||||
var names = ['simple_url', 'g_transport', 'g_host_port', 'g_repo', 'g_commit', 'g_path'];
|
||||
for (var i = 0; i < names.length; i++) {
|
||||
control(e, names[i]).change(preenE).keyup(preenE);
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user