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

Don't redirect to static resources: avoids a redirect loop in some configurations. Instead, just supply links to static resources for the next hop.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-01-27 13:50:07 -05:00
parent 17e769739b
commit b54d6a685f
1 changed files with 184 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

378
src/site.rkt
View File

@ -105,7 +105,7 @@
;; " Download") ;; " Download")
;; "http://download.racket-lang.org/") ;; "http://download.racket-lang.org/")
)) ))
(bootstrap-static-urlprefix (if (use-cache?) static-urlprefix "")) (bootstrap-static-urlprefix (if (rendering-static-page?) static-urlprefix ""))
(jsonp-baseurl backend-baseurl)) (jsonp-baseurl backend-baseurl))
body ...)) body ...))
@ -583,37 +583,32 @@
(define package-name-list (package-search "" '((main-distribution #f)))) (define package-name-list (package-search "" '((main-distribution #f))))
(authentication-wrap (authentication-wrap
#:request request #:request request
(cond (bootstrap-response "Racket Package Index"
[(and (use-cache?) (not (rendering-static-page?))) #:title-element ""
;; Redirect to static version #:body-class "main-page"
(bootstrap-redirect (main-page-url))] `(div ((class "jumbotron"))
[else (h1 "Racket Packages")
(bootstrap-response "Racket Package Index" (p "These are the packages in the official "
#:title-element "" (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
#:body-class "main-page" "package catalog") ".")
`(div ((class "jumbotron")) (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(h1 "Racket Packages") (kbd "raco pkg install " (var "package-name")))
(p "These are the packages in the official " " installs a package.")
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html")) (p "You can "
"package catalog") ".") (a ((id "create-package-link")
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html")) (href ,(named-url edit-package-page)))
(kbd "raco pkg install " (var "package-name"))) (span ((class "label label-success"))
" installs a package.") ,(glyphicon 'plus-sign)
(p "You can " " add your own"))
(a ((id "create-package-link") " packages to the index."))
(href ,(named-url edit-package-page))) `(div ((id "search-box"))
(span ((class "label label-success")) (form ((role "form")
,(glyphicon 'plus-sign) (action ,(named-url search-page)))
" add your own")) ,(text-input "q" #:placeholder "Search packages")))
" packages to the index.")) `(div
`(div ((id "search-box")) (p ((class "package-count"))
(form ((role "form") ,(format "~a packages" (length package-name-list)))
(action ,(named-url search-page))) ,(package-summary-table package-name-list))))))
,(text-input "q" #:placeholder "Search packages")))
`(div
(p ((class "package-count"))
,(format "~a packages" (length package-name-list)))
,(package-summary-table package-name-list)))]))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -630,174 +625,169 @@
(define package-name (string->symbol package-name-str)) (define package-name (string->symbol package-name-str))
(define pkg (package-detail package-name)) (define pkg (package-detail package-name))
(define default-version (package-default-version pkg)) (define default-version (package-default-version pkg))
(cond (if (not pkg)
[(and (use-cache?) (not (rendering-static-page?))) (bootstrap-response #:code 404
;; Redirect to static version #:message #"No such package"
(bootstrap-redirect (view-package-url package-name))] "Package not found"
[(not pkg) `(div "The package " (code ,package-name-str) " does not exist."))
(bootstrap-response #:code 404 (bootstrap-response (~a package-name)
#:message #"No such package" #:title-element ""
"Package not found" `(div ((class "jumbotron"))
`(div "The package " (code ,package-name-str) " does not exist."))] (h1 ,(~a package-name))
[else (p ,(package-description pkg))
(bootstrap-response (~a package-name) ,(cond
#:title-element "" [(package-build-failure-log pkg)
`(div ((class "jumbotron")) (build-status (package-build-failure-log pkg)
(h1 ,(~a package-name)) "failed" "danger" "fire")]
(p ,(package-description pkg)) [(and (package-build-success-log pkg)
,(cond (package-build-dep-failure-log pkg))
[(package-build-failure-log pkg) (build-status (package-build-dep-failure-log pkg)
(build-status (package-build-failure-log pkg) "problems" "warning" "question-sign")]
"failed" "danger" "fire")] [(package-build-success-log pkg)
[(and (package-build-success-log pkg) (build-status (package-build-success-log pkg)
(package-build-dep-failure-log pkg)) "ok" "success" "ok")]
(build-status (package-build-dep-failure-log pkg) [else
"problems" "warning" "question-sign")] ""])
[(package-build-success-log pkg) (div ((class "dropdown"))
(build-status (package-build-success-log pkg) ,@(let ((docs (package-docs pkg)))
"ok" "success" "ok")] (match docs
[else [(list)
""]) `()]
(div ((class "dropdown")) [(list doc)
,@(let ((docs (package-docs pkg))) (define-values (n u) (doc-destruct doc))
(match docs (list (buildhost-link
[(list) #:attributes `((class "btn btn-success btn-lg"))
`()] u
[(list doc) `(span ,(glyphicon 'file) " Documentation")))]
(define-values (n u) (doc-destruct doc)) [_
(list (buildhost-link `((button ((class "btn btn-success btn-lg dropdown-toggle")
#:attributes `((class "btn btn-success btn-lg")) (data-toggle "dropdown"))
u ,(glyphicon 'file)
`(span ,(glyphicon 'file) " Documentation")))] " Documentation "
[_ (span ((class "caret"))))
`((button ((class "btn btn-success btn-lg dropdown-toggle") (ul ((class "dropdown-menu")
(data-toggle "dropdown")) (role "menu"))
,(glyphicon 'file) ,@(for/list ((doc docs)) `(li ,(doc-link doc)))))]))
" Documentation "
(span ((class "caret"))))
(ul ((class "dropdown-menu")
(role "menu"))
,@(for/list ((doc docs)) `(li ,(doc-link doc)))))]))
" " " "
,@(maybe-splice ,@(maybe-splice
(package-readme-url pkg) (package-readme-url pkg)
`(a ((class "btn btn-info btn-lg") `(a ((class "btn btn-info btn-lg")
(href ,(package-readme-url pkg))) (href ,(package-readme-url pkg)))
,(glyphicon 'eye-open) ,(glyphicon 'eye-open)
" README")) " README"))
;; Heuristic guess as to whether we should present a "browse" ;; Heuristic guess as to whether we should present a "browse"
;; link or a "download" link. ;; link or a "download" link.
" " " "
,(if (equal? (@ default-version source) ,(if (equal? (@ default-version source)
(@ default-version source_url)) (@ default-version source_url))
`(a ((class "btn btn-default btn-lg") `(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url))) (href ,(@ default-version source_url)))
,(glyphicon 'download) " Download" ,(glyphicon 'download) " Download"
;; ,(if (regexp-match? "(?i:\\.zip$)" (or (@ default-version source_url) "")) ;; ,(if (regexp-match? "(?i:\\.zip$)" (or (@ default-version source_url) ""))
;; " Zip file" ;; " Zip file"
;; " Download") ;; " Download")
) )
`(a ((class "btn btn-default btn-lg") `(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url))) (href ,(@ default-version source_url)))
,(glyphicon 'link) " Code")) ,(glyphicon 'link) " Code"))
,@(maybe-splice ,@(maybe-splice
(member (current-email) (package-authors pkg)) (member (current-email) (package-authors pkg))
" " " "
`(a ((class "btn btn-info btn-lg") `(a ((class "btn btn-info btn-lg")
(href ,(named-url edit-package-page package-name-str))) (href ,(named-url edit-package-page package-name-str)))
,(glyphicon 'edit) " Edit this package")) ,(glyphicon 'edit) " Edit this package"))
)) ))
(if (package-locally-modified? pkg) (if (package-locally-modified? pkg)
`(div ((class "alert alert-warning") `(div ((class "alert alert-warning")
(role "alert")) (role "alert"))
,(glyphicon 'exclamation-sign) ,(glyphicon 'exclamation-sign)
" This package has been modified since the package index was last rebuilt." " This package has been modified since the package index was last rebuilt."
" The next index refresh is scheduled for " " The next index refresh is scheduled for "
,(utc->string (/ (next-fetch-deadline) 1000)) ".") ,(utc->string (/ (next-fetch-deadline) 1000)) ".")
"") "")
(if (package-checksum-error pkg) (if (package-checksum-error pkg)
`(div ((class "alert alert-danger") `(div ((class "alert alert-danger")
(role "alert")) (role "alert"))
(span ((class "label label-danger")) (span ((class "label label-danger"))
"Checksum error") "Checksum error")
" The package checksum does not match" " The package checksum does not match"
" the package source code.") " the package source code.")
"") "")
`(table ((class "package-details")) `(table ((class "package-details"))
(tr (th "Authors") (tr (th "Authors")
(td (div ((class "authors-detail")) (td (div ((class "authors-detail"))
,(authors-list #:gravatars? #t (package-authors pkg))))) ,(authors-list #:gravatars? #t (package-authors pkg)))))
(tr (th "Documentation") (tr (th "Documentation")
(td ,(doc-links (package-docs pkg)))) (td ,(doc-links (package-docs pkg))))
(tr (th "Tags") (tr (th "Tags")
(td ,(tag-links (package-tags pkg)))) (td ,(tag-links (package-tags pkg))))
(tr (th "Last updated") (tr (th "Last updated")
(td ,(utc->string (package-last-updated pkg)))) (td ,(utc->string (package-last-updated pkg))))
(tr (th "Ring") (tr (th "Ring")
(td ,(~a (or (package-ring pkg) "N/A")))) (td ,(~a (or (package-ring pkg) "N/A"))))
(tr (th "Conflicts") (tr (th "Conflicts")
(td ,(package-links (package-conflicts pkg)))) (td ,(package-links (package-conflicts pkg))))
(tr (th "Dependencies") (tr (th "Dependencies")
(td ,(package-links (package-dependencies pkg)))) (td ,(package-links (package-dependencies pkg))))
(tr (th "Most recent build results") (tr (th "Most recent build results")
(td (ul ((class "build-results")) (td (ul ((class "build-results"))
,@(maybe-splice ,@(maybe-splice
(package-build-success-log pkg) (package-build-success-log pkg)
`(li "Compiled successfully: " `(li "Compiled successfully: "
,(buildhost-link (package-build-success-log pkg) ,(buildhost-link (package-build-success-log pkg)
"transcript"))) "transcript")))
,@(maybe-splice ,@(maybe-splice
(package-build-failure-log pkg) (package-build-failure-log pkg)
`(li "Compiled unsuccessfully: " `(li "Compiled unsuccessfully: "
,(buildhost-link (package-build-failure-log pkg) ,(buildhost-link (package-build-failure-log pkg)
"transcript"))) "transcript")))
,@(maybe-splice ,@(maybe-splice
(package-build-conflicts-log pkg) (package-build-conflicts-log pkg)
`(li "Conflicts: " `(li "Conflicts: "
,(buildhost-link (package-build-conflicts-log pkg) ,(buildhost-link (package-build-conflicts-log pkg)
"details"))) "details")))
,@(maybe-splice ,@(maybe-splice
(package-build-dep-failure-log pkg) (package-build-dep-failure-log pkg)
`(li "Dependency problems: " `(li "Dependency problems: "
,(buildhost-link (package-build-dep-failure-log pkg) ,(buildhost-link (package-build-dep-failure-log pkg)
"details"))) "details")))
))) )))
,@(let* ((vs (package-versions pkg)) ,@(let* ((vs (package-versions pkg))
(empty-checksum "9f098dddde7f217879070816090c1e8e74d49432") (empty-checksum "9f098dddde7f217879070816090c1e8e74d49432")
(vs (for/hash (((k v) (in-hash vs)) (vs (for/hash (((k v) (in-hash vs))
#:when (not (equal? (@ v checksum) #:when (not (equal? (@ v checksum)
empty-checksum))) empty-checksum)))
(values k v)))) (values k v))))
(maybe-splice (maybe-splice
(not (hash-empty? vs)) (not (hash-empty? vs))
`(tr (th "Versions") `(tr (th "Versions")
(td (table ((class "package-versions")) (td (table ((class "package-versions"))
(tr (th "Version") (tr (th "Version")
(th "Source") (th "Source")
(th "Checksum")) (th "Checksum"))
,@(for/list ,@(for/list
(((version-sym v) (in-hash vs))) (((version-sym v) (in-hash vs)))
`(tr `(tr
(td ,(~a version-sym)) (td ,(~a version-sym))
(td (a ((href ,(@ v source_url))) (td (a ((href ,(@ v source_url)))
,(@ v source))) ,(@ v source)))
(td ,(@ v checksum))))))))) (td ,(@ v checksum)))))))))
(tr (th "Last checked") (tr (th "Last checked")
(td ,(utc->string (package-last-checked pkg)))) (td ,(utc->string (package-last-checked pkg))))
(tr (th "Last edited") (tr (th "Last edited")
(td ,(utc->string (package-last-edit pkg)))) (td ,(utc->string (package-last-edit pkg))))
(tr (th "Modules") (tr (th "Modules")
(td (ul ((class "module-list")) (td (ul ((class "module-list"))
,@(for/list ((mod (package-modules pkg))) ,@(for/list ((mod (package-modules pkg)))
(match-define (list kind path) mod) (match-define (list kind path) mod)
`(li ((class ,kind)) ,path))))) `(li ((class ,kind)) ,path)))))
))]))) )))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;