Add language-family support, group packages into umbrellas, and record build platforms in catalog

src/bootstrap.rkt

@@ -24,6 +24,7 @@
 
 (require racket/match)
 (require racket/string)
+(require racket/runtime-path)
 (require web-server/servlet)
 (require "html-utils.rkt")
 (require "xexpr-utils.rkt")
@@ -42,8 +43,24 @@
 (define bootstrap-inline-js (make-parameter #f))
 (define bootstrap-head-extra (make-parameter '()))
 
+(define-runtime-path static-content-dir "../static")
+
+;; Append a cache-busting query string derived from the asset's
+;; modification time, so browsers (Firefox in particular, which
+;; caches more aggressively when no explicit Cache-Control is sent)
+;; refetch when the file changes instead of serving a stale copy.
+(define (cache-busting-suffix str)
+  (define rel (regexp-replace #rx"^/" str ""))
+  (define path
+    (and (not (string=? rel ""))
+         (with-handlers ([exn:fail? (lambda (_) #f)])
+           (apply build-path static-content-dir (regexp-split #rx"/" rel)))))
+  (if (and path (file-exists? path))
+      (format "?v=~a" (file-or-directory-modify-seconds path))
+      ""))
+
 (define (static str)
-  (string-append (bootstrap-static-urlprefix) str))
+  (string-append (bootstrap-static-urlprefix) str (cache-busting-suffix str)))
 (define (dynamic str)
   (string-append (bootstrap-dynamic-urlprefix) str))
 
@@ -102,7 +119,7 @@
 
       (script ,@(cond [(bootstrap-inline-js) => list] [else '()]))
       (script ((type "text/javascript") (src ,(static "/jquery.min.js"))))
-      (script ((type "text/javascript") (src ,(static "/jquery.tablesorter.min.js"))))
+      (script ((type "text/javascript") (src ,(static "/jquery.tablesorter.combined.min.js"))))
       (script ((type "text/javascript") (src ,(static "/jquery-ui.min.js"))))
       (script ((type "text/javascript") (src ,(static "/bootstrap/js/bootstrap.min.js"))))
       (script ((type "text/javascript") (src ,(static "/site.js"))))

src/pkg-index/update.rkt

@@ -159,7 +159,8 @@
 (define (update-from-content i)
   (log! "\tgetting package content for ~v" (hash-ref i 'name))
   (match-define-values
-   (checksum module-paths (list deps rt-deps license implies collection))
+   (checksum module-paths (list deps rt-deps license implies collection
+                                umbrella language-families build-platforms))
    (pkg:get-pkg-content
     (pkg:pkg-desc (hash-ref i 'source)
                   #f
@@ -173,9 +174,14 @@
               (pkg:extract-pkg-dependencies get-info #:build-deps? #f)
               (get-info 'license (λ () missing))
               (get-info 'implies (λ () empty))
-              (get-info 'collection (λ () #f)))
+              (get-info 'collection (λ () #f))
+              (get-info 'umbrella (λ () #f))
+              (get-info 'language-families (λ () #f))
+              (get-info 'build-platforms (λ () #f)))
         (list empty empty missing empty #f)))))
 
+  (define (guard v pred alt-v) (if (pred v) v alt-v))
+
   (package-begin
    (define* i (hash-set i 'modules module-paths))
    (define* i (hash-set i 'dependencies deps))
@@ -184,9 +190,25 @@
                         (cond
                           [(eq? license missing) #f]
                           [else (format "~s" license)])))
-   (define* i (hash-set i 'implies implies))
+   (define* i (hash-set i 'implies (guard implies
+                                          (lambda (v) (or (string? v) (eq? v 'core)))
+                                          empty)))
    ;; avoid conflation of symbols and strings in JSON
    (define* i (hash-set i 'collection (if (eq? collection 'multi) (list 'multi) collection)))
+   (define* i (hash-set i 'umbrella (guard umbrella
+                                           string?
+                                           #f)))
+   (define* i (hash-set i 'language-families (guard language-families
+                                                    (lambda (l) (and (list? l)
+                                                                     (andmap string? l)))
+                                                    '("Racket"))))
+   (define* i (hash-set i 'build-platforms (guard build-platforms
+                                                  (lambda (l)
+                                                    (or (not l)
+                                                        (and (list? l)
+                                                             (andmap (lambda (i) (or (string? i) (symbol? i)))
+                                                                     l))))
+                                                  #f)))
    i))
 
 (define (do-update! pkgs)

src/site.rkt

@@ -647,11 +647,64 @@
       (string-append (date->string (seconds->date utc #f) #t) " (UTC)")
       "N/A"))
 
-(define (get-implied-docs pkg)
-  (define implied-names (map string->symbol
-                             (dependencies->package-names
-                              (package-implies pkg))))
-  (append-map package-docs (package-batch-detail implied-names)))
+(define (get-all-pkg-docs pkg inferred-umbrellas)
+  (define-values (docs seen)
+    (let loop ([pkgs (list pkg)] [docs null] [seen #hash()])
+      (cond
+        [(null? pkgs) (values (set->list (list->set docs))
+                              seen)]
+        [(hash-ref seen (package-name (car pkgs)) #f)
+         (loop (cdr pkgs) docs seen)]
+        [else
+         (define pkg (car pkgs))
+         (let ([docs (append (package-docs pkg) docs)]
+               [seen (hash-set seen (package-name pkg) #t)])
+           (define implied-names (dependencies->package-names
+                                  (package-implies pkg)))
+           (define umbrella-name (or (package-umbrella pkg)
+                                     (hash-ref inferred-umbrellas (package-name pkg) #f)))
+           (define next-names (map string->symbol
+                                   (append (if umbrella-name
+                                               (list umbrella-name)
+                                               null)
+                                           implied-names)))
+           (cond
+             [(null? next-names) (loop (cdr pkgs) docs seen)]
+             [else
+              (loop (append (package-batch-detail next-names)
+                            (cdr pkgs))
+                    docs
+                    seen)]))])))
+  docs)
+
+(define (infer-umbrellas)
+  (define names (for/hash ([name-sym (in-list (all-package-names))])
+                  (values (symbol->string name-sym) #t)))
+  (for/fold ([inferred-umbrellas #hash()])
+            ([name (in-hash-keys names)])
+    (define m (regexp-match #rx"^(.*)-(?:lib|exe|doc|test)$" name))
+    (define potential-umbrella-name (and m (cadr m)))
+    (if (and potential-umbrella-name
+             (hash-ref names potential-umbrella-name #f))
+        (hash-set inferred-umbrellas name potential-umbrella-name)
+        inferred-umbrellas)))
+
+;; determines umbrella relationshops, but only among `pkgs`,
+;; while `inferrd-umbrellas` may have information on additional packages
+(define (umbrellas-and-members pkgs inferred-umbrellas)
+  (define names (for/hash ([pkg (in-list pkgs)]) (values (package-name pkg) #t)))
+  (define umbrellas
+    (for/hash ([pkg (in-list pkgs)]
+               #:do [(define umbrella-name
+                        (or (package-umbrella pkg)
+                            (hash-ref inferred-umbrellas (package-name pkg) #f)))]
+               #:when (hash-ref names umbrella-name #f))
+      (values (package-name pkg) umbrella-name)))
+  (define umbrella-members
+    (for/fold ([umbrella-members #hash()]) ([(sub super) (in-hash umbrellas)])
+      (hash-set umbrella-members super (cons sub (hash-ref umbrella-members super null)))))
+  (values umbrellas
+          umbrella-members))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Package hashtable getters.
@@ -693,6 +746,9 @@
 (define (package-dependencies pkg)      (or (@ pkg dependencies) '()))
 (define (package-implies pkg)           (or (@ pkg implies) '()))
 (define (package-modules pkg)           (or (@ pkg modules) '()))
+(define (package-language-families pkg) (or (@ pkg language-families) '("Racket")))
+(define (package-build-platforms pkg)   (or (@ pkg build-platforms) #f))
+(define (package-umbrella pkg)          (or (@ pkg umbrella) #f))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -705,7 +761,9 @@
           (action ,(named-url bulk-operation-page))
           (method "post"))
     (table
-     ((class "packages sortable") (data-todokey ,(number->string num-todos)))
+     ([class "packages sortable"]
+      [id "package-table"]
+      [data-todokey ,(number->string num-todos)])
      (thead
       ,@(maybe-splice
          bulk-operations-enabled?
@@ -731,6 +789,7 @@
        ,@(maybe-splice bulk-operations-enabled? `(th 'nbsp))
        (th "Package")
        (th "Description")
+       (th "Family")
        (th "Build")
        (th ((style "display: none")) 'nbsp))) ;; todokey
      (tbody
@@ -746,20 +805,44 @@
   ;; representing packages with outstanding build errors or
   ;; failing tests, or which are missing docs, license metadata, or tags.
   (define now (/ (current-inexact-milliseconds) 1000))
+  (define inferred-umbrellas (infer-umbrellas))
+  (define pkgs (package-batch-detail package-names))
+  (define-values (umbrellas umbrella-members) (umbrellas-and-members pkgs inferred-umbrellas))
+  (define sorted-pkgs (sort pkgs
+                            (lambda (a b)
+                              (define a-name (package-name a))
+                              (define b-name (package-name b))
+                              (define a-parent (or (hash-ref umbrellas a-name #f) a-name))
+                              (define b-parent (or (hash-ref umbrellas b-name #f) b-name))
+                              (cond
+                                [(equal? a-parent b-parent)
+                                 (cond
+                                   [(equal? a-name a-parent) #true]
+                                   [(equal? b-name a-parent) #false]
+                                   [else (string-ci<? a-name b-name)])]
+                                [else
+                                 (string-ci<? a-parent b-parent)]))))
+  (define package-name-to-language-families
+    (for/hash ([pkg (in-list sorted-pkgs)])
+      (values (package-name pkg) (package-language-families pkg))))
   (define-values (pkg-rows num-todos)
     (for/fold ([pkg-rows null] [num-todos 0])
-              ([pkg (package-batch-detail package-names)])
-      (define pkg-docs (append (package-docs pkg) (get-implied-docs pkg)))
+              ([pkg sorted-pkgs]
+               [pkg-pos (in-naturals)])
+      (define pkg-docs (get-all-pkg-docs pkg inferred-umbrellas))
       (define has-docs? (pair? pkg-docs))
       (define has-readme? (pair? (package-readme-url pkg)))
       (define has-tags? (pair? (package-tags pkg)))
       (define has-desc? (not (string=? "" (package-description pkg))))
       (define pkg-license (parse-license-jsexpr (package-license-jsexpr pkg)))
+      (define pkg-families (package-language-families pkg))
       (define has-valid-license? (match pkg-license
                                    [(cons 'valid _)
                                     #t]
                                    [_
                                     #f]))
+      (define umbrella-name (hash-ref umbrellas (package-name pkg) #f))
+      (define umbrella-member-names (hash-ref umbrella-members (package-name pkg) null))
       (define todokey
         (cond [(package-build-failure-log pkg) 6]
               [(package-build-test-failure-log pkg) 5]
@@ -768,10 +851,21 @@
               [(not has-valid-license?) 2]
               [(not has-tags?) 1]
               [else 0]))
+      (define pkg-sort-families (if umbrella-name
+                                    ;; ensure that sorting by families doesn't break up the umbrella
+                                    (hash-ref package-name-to-language-families umbrella-name pkg-families)
+                                    pkg-families))
       (define row-xexp
         `(tr
-          ((data-todokey ,(number->string todokey)))
-          (td (span ((class "last-updated-negated") (style "display: none"))
+          ([data-todokey ,(number->string todokey)]
+           [data-families ,(string-join pkg-sort-families ",")]
+           [data-sortpos ,(number->string pkg-pos)]
+           ,@(if umbrella-name
+                 `([class "umbrella-content in-closed-umbrella tablesorter-childRow"]
+                   [data-umbrella ,umbrella-name])
+                 null))
+          (td ([class "package-left"])
+              (span ((class "last-updated-negated") (style "display: none"))
                     ,(~a (- (package-last-updated pkg))))
               ,@(maybe-splice
                  (and (not (package-checksum-error pkg))
@@ -784,13 +878,23 @@
                               "label-danger") "Todo")))
           ,@(maybe-splice
              bulk-operations-enabled?
-             `(td (p "Ring " ,(~a (package-ring pkg)))
+             `(td ([class "package-left"])
+                  (p "Ring " ,(~a (package-ring pkg)))
                   ,(checkbox-input "selected-packages"
                                    (package-name pkg)
                                    #:id #f
                                    #:extra-classes `("selected-packages"))))
-          (td (h2 ,(package-link (package-name pkg)))
-              ,(authors-list (package-authors pkg)))
+          (td ([class "package-left package-desc"])
+              (h2 ,(package-link (package-name pkg)))
+              ,(authors-list (package-authors pkg))
+              ,@(if (null? umbrella-member-names)
+                    null
+                    `((div
+                       (div ([class "umbrella-arrow umbrella-closed"]
+                             [data-umbrella ,(package-name pkg)])
+                            "")
+                       ,@(for/list ([sub (in-list umbrella-member-names)])
+                           `(span () ,(package-link sub) " "))))))
           (td (p ,(if (string=? "" (package-description pkg))
                       `(span ((class "label label-warning")) "This package needs a description")
                       (package-description pkg)))
@@ -813,8 +917,14 @@
                             "This package needs license metadata"
                             #:extra-attributes missing-license-tooltip-attributes)
                    `(div
-                     (span ((class "doctags-label")) "License: ")
+                     (span ((class "license-label")) "License: ")
                      ,(license-links pkg-license))))
+          (td ,@(apply
+                 append
+                 (for/list ([family (in-list pkg-families)]
+                            [i (in-naturals)])
+                   (list (if (zero? i) "" ", ")
+                         (family-link family)))))
           ,(build-status-td pkg)
           (td ((style "display: none")) ,(number->string todokey))))
       (values (cons row-xexp pkg-rows)
@@ -856,6 +966,30 @@
            (match-define (list u p l) e)
            (if u `(span ,p ,(buildhost-link u l)) `(span)))))
 
+(define (build-package-language-family-list package-names)
+  (define pkgs (package-batch-detail package-names))
+  (define families
+    (sort (set->list
+           (for*/set ([pkg (in-list pkgs)]
+                      [family (in-list (package-language-families pkg))])
+             family))
+          (lambda (a b)
+            (if (equal? a "Racket")
+                #t
+                (string-ci<? a b)))))
+  `(div ([class "language-families"])
+        "Language families: "
+        (span ([id "language-family-list"])
+              ,(family-link (car families))
+              ,@(apply
+                 append
+                 (for/list ([family (in-list (cdr families))])
+                   (list ", " (family-link family)))))))
+
+(define (family-link family)
+  `(span ([class "family-select"]
+          [data-family ,family])
+         ,family))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -893,11 +1027,12 @@
                  (form ((role "form")
                         (action ,(named-url search-page)))
                        ,(text-input "q" #:placeholder "Search packages")))
+           (build-package-language-family-list package-name-list)
            `(div
              (p ((class "package-count"))
-                ,(format "~a packages" (length package-name-list))
+                ,(format "~a packages." (length package-name-list))
                 " "
-                (a ((href ,(format "~a?q=%20" (named-url search-page)))) "(see all, including packages tagged as \"deprecated\", \"main-distribution\", or \"main-tests\")"))
+                (a ((href ,(format "~a?q=%20" (named-url search-page)))) "See all, including packages tagged as \"deprecated\", \"main-distribution\", or \"main-tests\"."))
              (p ((class "package-count") (id "todo-msg")) "")
              ,(package-summary-table package-name-list))
            `(div ((class "jumbotron"))
@@ -1114,6 +1249,8 @@
                       (td ,(tag-links (package-tags pkg))))
                   (tr (th "License")
                       (td ,(license-links pkg-license)))
+                  (tr (th "Language families")
+                      (td ,(string-join (package-language-families pkg) ", ")))
                   (tr (th "Last updated")
                       (td ,(utc->string (package-last-updated pkg))))
                   (tr (th "Ring")
@@ -1129,6 +1266,11 @@
                       (td ,(package-links
                             (dependencies->package-names
                              (package-dependencies pkg)))))
+                  (tr (th "Build platforms")
+                      (td ,(let ([platforms (package-build-platforms pkg)])
+                             (if platforms
+                                 (string-join (map ~a platforms) ", ")
+                                 '(i "any platform")))))
                   (tr (th "Most recent build results")
                       (td (ul ((class "build-results"))
                               ,@(maybe-splice