From 4776595e7977d559cd775b4e66be4cc5ede61813 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 3 Aug 2016 19:30:15 -0400 Subject: [PATCH] Bring site (closer to being) into line with package source spec --- src/package-source.rkt | 160 ++++++++++++++++++++++++++++++++++++++ src/site.rkt | 172 +++++++++++++++++++++-------------------- static/editpackage.js | 28 +++---- 3 files changed, 261 insertions(+), 99 deletions(-) create mode 100644 src/package-source.rkt diff --git a/src/package-source.rkt b/src/package-source.rkt new file mode 100644 index 0000000..8749ce1 --- /dev/null +++ b/src/package-source.rkt @@ -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) + ) + ) diff --git a/src/site.rkt b/src/site.rkt index 9a8aa35..9f110df 100644 --- a/src/site.rkt +++ b/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))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/static/editpackage.js b/static/editpackage.js index 9d5e43b..4070b60 100644 --- a/static/editpackage.js +++ b/static/editpackage.js @@ -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); }