Take a guess at where READMEs might be

TODO.md

@@ -1,6 +1,3 @@
-Link to Github's README section in the Documentation link from a
-package page, if such a Github section exists.
-
 Documentation/help text on the edit package page?
 
 Move `generic-input` and friends into bootstrap.rkt

src/packages.rkt

@@ -8,6 +8,8 @@
          sorted-package-names
          package-detail
          package-batch-detail
+         package-external-information
+         set-package-external-information!
          package-search
          replace-package!
          delete-package!
@@ -44,6 +46,7 @@
 (define base-bogus-timeout (* 5 1000)) ;; 5 seconds
 
 (struct package-manager-state (local-packages
+                               external-information
                                all-tags
                                all-formal-tags
                                next-fetch-deadline
@@ -74,6 +77,7 @@
 
 (define (package-manager)
   (package-manager-main (package-manager-state (hash)
+                                               (hash)
                                                (set)
                                                (set)
                                                0
@@ -111,10 +115,10 @@
       (if new-local-pkg
           (hash-set acc package-name new-local-pkg)
           acc)))
-  (rebuild-all-tags (struct-copy package-manager-state state
+  (rebuild-indexes (struct-copy package-manager-state state
-                                 [local-packages new-local-packages])))
+                                [local-packages new-local-packages])))
 
-(define (rebuild-all-tags state)
+(define (rebuild-indexes state)
   (struct-copy package-manager-state state
                [all-tags
                 (for/fold ((ts (set)))
@@ -134,7 +138,7 @@
   (when (not (eq? old-package-name new-package-name))
     (notify-package-change! #f old-package-name))
   (notify-package-change! completion-ch new-package-name)
-  (rebuild-all-tags
+  (rebuild-indexes
    (struct-copy package-manager-state state
                 [local-packages
                  (hash-set (if old-pkg
@@ -157,6 +161,7 @@
 
 (define (package-manager-main state)
   (match-define (package-manager-state local-packages
+                                       external-information
                                        all-tags
                                        all-formal-tags
                                        next-fetch-deadline
@@ -198,6 +203,14 @@
           (values (lookup-package name local-packages) state)]
          [(list 'package-batch-detail names)
           (values (for/list ((name names)) (lookup-package name local-packages)) state)]
+         [(list 'external-information name)
+          (values (hash-ref external-information name (lambda () (hash))) state)]
+         [(list 'set-external-information! name info)
+          (values (void) (struct-copy package-manager-state state
+                                      [external-information
+                                       (if info
+                                           (hash-set external-information name info)
+                                           (hash-remove external-information name))]))]
          [(list 'replace-package! completion-ch old-pkg new-pkg)
           (values (void) (replace-package completion-ch old-pkg new-pkg state))]
          [(list 'delete-package! completion-ch package-name)
@@ -207,7 +220,8 @@
 
 (define package-manager-thread
   (make-persistent-state 'package-manager-thread
-                         (lambda () (daemon-thread 'package-manager package-manager))))
+                         (lambda () (daemon-thread 'package-manager
+                                                   (lambda () (package-manager))))))
 
 ;; Set to a thread in site.rkt (because the thread needs to call
 ;; routines only available from site.rkt)
@@ -232,6 +246,10 @@
 (define (all-formal-tags) (manager-rpc 'all-formal-tags))
 (define (package-detail package-name) (manager-rpc 'package-detail package-name))
 (define (package-batch-detail package-names) (manager-rpc 'package-batch-detail package-names))
+(define (package-external-information package-name)
+  (manager-rpc 'external-information package-name))
+(define (set-package-external-information! package-name info)
+  (manager-rpc 'set-external-information! package-name info))
 (define (replace-package! completion-ch old-pkg new-pkg)
   (manager-rpc 'replace-package! completion-ch old-pkg new-pkg))
 (define (delete-package! completion-ch package-name)

src/site.rkt

@@ -9,6 +9,8 @@
 (require racket/format)
 (require racket/date)
 (require racket/string)
+(require racket/port)
+(require net/url)
 (require net/uri-codec)
 (require web-server/servlet)
 (require json)
@@ -475,10 +477,15 @@
                ,(authors-list (@ pkg authors)))
            (td (p ,(@ pkg description))
                ,@(maybe-splice
-                  (pair? (@ pkg build docs))
+                  (or (pair? (package-docs pkg)) (package-readme-url pkg))
                   `(div
                     (span ((class "doctags-label")) "Docs: ")
-                    ,(doc-links (@ pkg build docs))))
+                    ,(doc-links (package-docs pkg))
+                    ,@(maybe-splice (package-readme-url pkg)
+                                    " "
+                                    `(a ((href ,(package-readme-url pkg)))
+                                      "README"))
+                    ))
                ,@(maybe-splice
                   (pair? (@ pkg tags))
                   `(div
@@ -551,12 +558,21 @@
                      `(span ((class ,(format "label label-~a" label-type)))
                        ,(glyphicon glyphicon-type) " " ,str))))
 
+(define (package-default-version pkg)
+  (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f)))
+
+(define (package-docs pkg)
+  (or (@ pkg build docs) '()))
+
+(define (package-readme-url pkg)
+  (@ (package-external-information (string->symbol (@ pkg name))) readme-url))
+
 (define (package-page request package-name-str)
   (authentication-wrap
    #:request request
    (define package-name (string->symbol package-name-str))
    (define pkg (package-detail package-name))
-   (define default-version (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f)))
+   (define default-version (package-default-version pkg))
    (cond
     [(and (not (current-session)) (not (static-render)))
      ;; Redirect to static version
@@ -586,7 +602,7 @@
                              [else
                               ""])
                            (div ((class "dropdown"))
-                                ,@(let ((docs (or (@ pkg build docs) '())))
+                                ,@(let ((docs (package-docs pkg)))
                                     (match docs
                                       [(list)
                                        `()]
@@ -595,16 +611,25 @@
                                        (list (buildhost-link
                                               #:attributes `((class "btn btn-success btn-lg"))
                                               u
-                                              "Documentation"))]
+                                              `(span ,(glyphicon 'file) " Documentation")))]
                                       [_
                                        `((button ((class "btn btn-success btn-lg dropdown-toggle")
                                                   (data-toggle "dropdown"))
-                                                 "Documentation "
+                                                 ,(glyphicon 'file)
+                                                 " Documentation "
                                                  (span ((class "caret"))))
                                          (ul ((class "dropdown-menu")
                                               (role "menu"))
                                              ,@(for/list ((doc docs)) `(li ,(doc-link doc)))))]))
 
+                                " "
+                                ,@(maybe-splice
+                                   (package-readme-url pkg)
+                                   `(a ((class "btn btn-info btn-lg")
+                                        (href ,(package-readme-url pkg)))
+                                     ,(glyphicon 'eye-open)
+                                     " README"))
+
                                 ;; Heuristic guess as to whether we should present a "browse"
                                 ;; link or a "download" link.
                                 " "
@@ -652,7 +677,7 @@
                                (td (div ((class "authors-detail"))
                                         ,(authors-list #:gravatars? #t (@ pkg authors)))))
                            (tr (th "Documentation")
-                               (td ,(doc-links (@ pkg build docs))))
+                               (td ,(doc-links (package-docs pkg))))
                            (tr (th "Tags")
                                (td ,(tag-links (@ pkg tags))))
                            (tr (th "Last updated")
@@ -1201,8 +1226,34 @@
     (response-output response)
     #:exists 'replace))
 
+;; TODO: fold the collection of this information into the package
+;; database itself.
+(define (update-external-package-information! package-name)
+  (define pkg (package-detail package-name))
+  (define default-version (package-default-version pkg))
+  (define external-information
+    (and pkg
+         (if (equal? (@ default-version source)
+                     (@ default-version source_url))
+             ;; We don't know where to look for a readme.
+             (hash)
+             ;; It's probably a github-like repo. Check for a readme.
+             (let ((contents
+                    (port->string
+                     (get-pure-port (string->url (@ default-version source_url))
+                                    #:redirections 10))))
+               ;;(log-info "CONTENTS: ~a === ~a" (@ default-version source_url) contents)
+               (if (regexp-match? #px"(?i:id=.readme.)" contents)
+                   (let ((readme-url (string-append (@ default-version source_url) "#readme")))
+                     (log-info "Package ~a has a readme at ~a" package-name readme-url)
+                     (hash 'readme-url readme-url))
+                   (hash))))))
+  (set-package-external-information! package-name external-information))
+
 (define (rerender-all!)
-  (for ((p (all-package-names))) (static-render! package-page (symbol->string p)))
+  (for ((p (all-package-names)))
+    (update-external-package-information! p)
+    (static-render! package-page (symbol->string p)))
   (static-render! main-page))
 
 (define (package-change-handler)
@@ -1218,6 +1269,7 @@
                               (lambda (_)
                                 (match (thread-receive)
                                   [(list completion-ch package-name)
+                                   (update-external-package-information! package-name)
                                    (static-render! package-page (symbol->string package-name))
                                    (loop #t (if completion-ch
                                                 (cons completion-ch pending-completions)