Bring site (closer to being) into line with package source spec

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)
+    )
+  )

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)
+              (define-values (source-type simple-url g-transport g-host+port g-repo g-commit g-path)
-                (match source
+                (match parsed-source
-                  [(pregexp #px"github://github\\.com/([^/]*)/([^/]*)(/([^/]*)/?)?"
+                  [#f
-                            (list _ u p _ b))
+                   (values "simple" "" "" "" "" "" "")]
-                   (values "github" "" "github.com" u p (if (equal? b "master") "" (or b #f)))]
+                  [(simple-url-source u _ _)
-                  [(pregexp #px"git://([^/]*)/([^/]*)/([^/]*)(/([^/]*)/?)?"
+                   (values "simple" u "" "" "" "" "")]
-                            (list _ h u p _ b))
+                  [(git-source _ _ _ tr host port repo c path)
-                   (values "git" "" h u p (if (equal? b "master") "" (or b "")))]
+                   (values "git"
-                  [_
+                           ""
-                   (values "simple" source "" "" "" "")]))
+                           (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_host_port" "Host" g-host+port)
-                            ,(textfield "g_user" "Repo User" g-user)
+                            ,(textfield "g_repo" "Repository" g-repo "user/repo")
-                            ,(textfield "g_project" "Repo Project" g-project)
+                            ,(textfield "g_commit" "Branch or commit" g-commit "master")
-                            ,(textfield "g_branch" "Repo Branch" g-branch "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,7 +1155,7 @@
                      draft)]
       [else
        (package-form #f (struct-copy draft-package draft
-                                     [versions (cons (list new_version default-empty-source-url)
+                          [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
@@ -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_transport (vg 'g_transport ""))
-    (define g_user (vg 'g_user ""))
+    (define g_host_port (vg 'g_host_port ""))
-    (define g_project (vg 'g_project ""))
+    (define g_repo0 (vg 'g_repo ""))
-    (define g_branch0 (vg 'g_branch ""))
+    (define g_repo (cond
-    (define g_branch (if (equal? g_branch0 "") "master" g_branch0))
+                     [(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
-      ["github" (format "github://github.com/~a/~a/~a" g_user g_project g_branch)]
+        ["simple" simple_url]
-      ["git"    (format "git://~a/~a/~a/~a" g_host g_user g_project g_branch)]
+        ["git" (unparse-package-source (git-source "" #f #f
-      ["simple" simple_url]))
+                                                   (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 (unparse-package-source parsed)
-                  'source_url (package-url->useful-url source)))))
+                  ;; N.B. the source_url setting here survives only while we have saved it
-
+                  ;; locally, before the package server catches up! The package server
-;; Copied from meta/pkg-index/official/static.rkt
+                  ;; uses its own version of this code and generates its own source_url.
-;; Modified slightly to recognise additional ad-hockery
+                  ;; However, we ignore source_url from the package server now that
-;; e.g. git://github.com/user/repo/ as well as
+                  ;; parsed-package-source-human-tree-url can do better.
-;;      git://github.com/user/repo  (note no trailing slash)
+                  'source_url (parsed-package-source-human-tree-url parsed)))))
-;;
-;; 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]))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

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_transport", gt),
-	    showhide1("g_user", gu),
+	    showhide1("g_host_port", gh),
-	    showhide1("g_project", gp),
+	    showhide1("g_repo", gr),
-	    showhide1("g_branch", gb)];
+	    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);
+      pieces = showhide(false, true, true, true, true, true);
-      previewUrl = "git://" + pieces[1] + "/" + pieces[2] + "/" + pieces[3] +
+      previewUrl = pieces[1] + "://" + pieces[2] + "/" + pieces[3] +
-                   (pieces[4] ? "/" + pieces[4] : "");
+        (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);
     }