suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Take a guess at where READMEs might be

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-14 20:30:57 -05:00
parent d6ce78e728
commit ab0eaf622e
3 changed files with 83 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.md
View File

@ -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

28
src/packages.rkt
View File

@ -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
[local-packages new-local-packages])))
(rebuild-indexes (struct-copy package-manager-state state
[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)

68
src/site.rkt
View File

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