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

Split site into static and dynamic parts, for easy cacheability etc.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2014-11-10 23:55:40 -05:00
parent d2ef8edd6a
commit 84c7068f75
4 changed files with 347 additions and 268 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -8,3 +8,4 @@ compiled/
*.[0-9]* *.[0-9]*
server-cert.pem server-cert.pem
private-key.pem private-key.pem
static/cached/

1
src/main.rkt
View File

@ -3,6 +3,7 @@
(module+ main (module+ main
(require "entrypoint.rkt") (require "entrypoint.rkt")
(void (make-entry-point 'refresh-packages! "packages.rkt")) (void (make-entry-point 'refresh-packages! "packages.rkt"))
(void (make-entry-point 'rerender-all! "site.rkt"))
(start-service #:reloadable? (getenv "SITE_RELOADABLE") (start-service #:reloadable? (getenv "SITE_RELOADABLE")
(make-entry-point 'request-handler "site.rkt") (make-entry-point 'request-handler "site.rkt")
(make-entry-point 'on-continuation-expiry "site.rkt"))) (make-entry-point 'on-continuation-expiry "site.rkt")))

3
src/signals.rkt
View File

@ -32,5 +32,8 @@
(poll-signal "../signals/.fetchindex" (poll-signal "../signals/.fetchindex"
"Index refresh signal received" "Index refresh signal received"
(lambda () ((entry-point-value (lookup-entry-point 'refresh-packages!))))) (lambda () ((entry-point-value (lookup-entry-point 'refresh-packages!)))))
(poll-signal "../signals/.rerender"
"Static rerender request received"
(lambda () ((entry-point-value (lookup-entry-point 'rerender-all!)))))
(sleep 0.5) (sleep 0.5)
(loop))))) (loop)))))

610
src/site.rkt
View File

@ -1,7 +1,8 @@
#lang racket/base #lang racket/base
(provide request-handler (provide request-handler
on-continuation-expiry) on-continuation-expiry
rerender-all!)
(require racket/set) (require racket/set)
(require racket/match) (require racket/match)
@ -20,6 +21,9 @@
(require "reload.rkt") (require "reload.rkt")
(require "daemon.rkt") (require "daemon.rkt")
(define static-cached-directory "../static/cached")
(define static-cached-urlprefix "/cached")
(define nav-index "Package Index") (define nav-index "Package Index")
(define nav-search "Search") (define nav-search "Search")
@ -48,11 +52,14 @@
(define-values (request-handler named-url) (define-values (request-handler named-url)
(dispatch-rules (dispatch-rules
[("index") main-page]
[("") main-page] [("") main-page]
[("search") search-page] [("search") search-page]
[("package" (string-arg)) package-page] [("package" (string-arg)) package-page]
[("package" (string-arg) "edit") edit-package-page] [("package" (string-arg) "edit") edit-package-page]
[("create") edit-package-page] [("create") edit-package-page]
[("login") login-page]
[("register-or-reset") register-or-reset-page]
[("logout") logout-page] [("logout") logout-page]
[("json" "search-completions") json-search-completions] [("json" "search-completions") json-search-completions]
[("json" "tag-search-completions") json-tag-search-completions] [("json" "tag-search-completions") json-tag-search-completions]
@ -65,6 +72,8 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define static-render (make-parameter #f))
(define-syntax-rule (authentication-wrap #:request request body ...) (define-syntax-rule (authentication-wrap #:request request body ...)
(authentication-wrap* #f request (lambda () body ...))) (authentication-wrap* #f request (lambda () body ...)))
@ -82,80 +91,76 @@
#:path "/" #:path "/"
#:expires "Thu, 01 Jan 1970 00:00:00 GMT")) #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))
(define (authentication-wrap* require-login? request body) (define-syntax-rule (with-session-cookie cookie-value body ...)
(define original-session-cookies (let ((v cookie-value))
(parameterize ((bootstrap-cookies
(if v
(list (make-cookie COOKIE v #:path "/" #:secure? #t))
(list clear-session-cookie))))
body ...)))
(define (request->session request)
(define session-cookies
(filter (lambda (c) (equal? (client-cookie-name c) COOKIE)) (filter (lambda (c) (equal? (client-cookie-name c) COOKIE))
(request-cookies request))) (request-cookies request)))
(define original-session-keys (define session-keys (map client-cookie-value session-cookies))
(map client-cookie-value original-session-cookies)) ;; (log-info "Session keys from cookie: ~a" session-keys)
;; (log-info "Session keys from cookie: ~a" original-session-keys) (for/or ((k session-keys)) (lookup-session/touch! k)))
(let redo ((session-keys original-session-keys))
(define session (for/or ((k session-keys)) (lookup-session/touch! k)))
;; (log-info "session: ~a" session)
;; If needed in future, we can change this to preserve *all* of (define (authentication-wrap* require-login? request body)
;; the original request by simply calling redo with the new (define session (request->session request))
;; session key, (redo (list new-session-key)). ;; (log-info "session: ~a" session)
;; (define requested-url (url->string (request-uri request)))
;; For now, we need to redirect to a clean URL in every case, so
;; just do that.
(define (after-login new-session-key)
(parameterize ((bootstrap-cookies
(if new-session-key
(list (make-cookie COOKIE new-session-key #:path "/" #:secure? #t))
(list clear-session-cookie))))
(with-site-config
(bootstrap-redirect (url->string (request-uri request))))))
(send/suspend/dispatch (if (and require-login? (not session))
(lambda (embed-url) (login-or-register-flow* requested-url login-form)
(if (and require-login? (not session)) (parameterize ((bootstrap-navbar-extension
(after-login (login-page)) (cond
(parameterize ((bootstrap-navbar-extension [(not session)
(cond `((a ((id "register-button")
[(not session) (class "btn btn-default navbar-btn navbar-right")
`((a ((id "register-button") (href ,(login-or-register-url requested-url
(class "btn btn-default navbar-btn navbar-right") (named-url register-or-reset-page))))
(href ,(embed-url "Register")
(lambda (req) (after-login (register-page)))))) (a ((id "sign-in-button")
"Register") (class "btn btn-success navbar-btn navbar-right")
(a ((id "sign-in-button") (href ,(login-or-register-url requested-url
(class "btn btn-success navbar-btn navbar-right") (named-url login-page))))
(href ,(embed-url "Sign in"))]
(lambda (req) (after-login (login-page)))))) [else
"Sign in"))] `((ul ((class "nav navbar-nav navbar-right"))
[else (li ((class "dropdown"))
`((ul ((class "nav navbar-nav navbar-right")) (a ((class "dropdown-toggle")
(li ((class "dropdown")) (data-toggle "dropdown"))
(a ((class "dropdown-toggle") (img ((src ,(gravatar-image-url (session-email session)
(data-toggle "dropdown")) 48))))
(img ((src ,(gravatar-image-url (session-email session) " "
48)))) ,(session-email session)
" " " "
,(session-email session) (span ((class "caret"))))
" " (ul ((class "dropdown-menu") (role "menu"))
(span ((class "caret")))) (li (a ((href ,(named-url edit-package-page)))
(ul ((class "dropdown-menu") (role "menu")) ,(glyphicon 'plus-sign) " New package"))
(li (a ((href ,(named-url edit-package-page))) (li (a ((href ,(tags-page-url
,(glyphicon 'plus-sign) " New package")) (list
(li (a ((href ,(tags-page-url (format "author:~a"
(list (session-email session))))))
(format "author:~a" ,(glyphicon 'user) " My packages"))
(session-email session)))))) (li ((class "divider"))
,(glyphicon 'user) " My packages")) (li (a ((href
(li ((class "divider")) ,(login-or-register-url
(li (a ((href ,(embed-url requested-url
(lambda (req) (after-login #f))))) (named-url logout-page))))
,(glyphicon 'log-out) " Log out")))))))])) ,(glyphicon 'log-out) " Log out")))))))]))
(current-session session) (current-session session)
(bootstrap-cookies (bootstrap-cookies
(if session (if session
(list (make-cookie COOKIE (list (make-cookie COOKIE
(session-key session) (session-key session)
#:path "/" #:path "/"
#:secure? #t)) #:secure? #t))
(list)))) (list))))
(with-site-config (body)))))))) (with-site-config (body)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -208,7 +213,34 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (login-page [error-message #f]) (define (login-or-register-url k baseurl)
(format "~a?~a"
baseurl
(alist->form-urlencoded (list (cons 'k k)))))
(define (login-or-register-flow request thunk)
(define-form-bindings request ([k (named-url main-page)]))
(login-or-register-flow* k thunk))
(define (login-or-register-flow* k thunk)
(with-session-cookie (thunk)
(with-site-config
(bootstrap-redirect k))))
(define (login-page request)
(login-or-register-flow request login-form))
(define (register-or-reset-page request)
(login-or-register-flow request register-form))
(define (logout-page request)
(define session (request->session request))
(when session (destroy-session! (session-key session)))
(login-or-register-flow request (lambda () #f)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (login-form [error-message #f])
(with-site-config (with-site-config
(send/suspend/dispatch (send/suspend/dispatch
(lambda (embed-url) (lambda (embed-url)
@ -222,10 +254,10 @@
,(form-group 2 2 (label "password" "Password:") ,(form-group 2 2 (label "password" "Password:")
0 5 (password-input "password")) 0 5 (password-input "password"))
,(form-group 4 5 ,(form-group 4 5
`(a ((href ,(embed-url (lambda (req) (register-page))))) `(a ((href ,(embed-url (lambda (req) (register-form)))))
"Need to reset your password?")) "Need to reset your password?"))
,(form-group 4 5 ,(form-group 4 5
`(a ((href ,(embed-url (lambda (req) (register-page))))) `(a ((href ,(embed-url (lambda (req) (register-form)))))
"Register an account")) "Register an account"))
,@(maybe-splice ,@(maybe-splice
error-message error-message
@ -246,16 +278,16 @@
(define-form-bindings request (email password)) (define-form-bindings request (email password))
(if (or (equal? (string-trim email) "") (if (or (equal? (string-trim email) "")
(equal? (string-trim password) "")) (equal? (string-trim password) ""))
(login-page "Please enter your email address and password.") (login-form "Please enter your email address and password.")
(match (authenticate-with-server! email password "") (match (authenticate-with-server! email password "")
["wrong-code" ["wrong-code"
(login-page "Something went awry; please try again.")] (login-form "Something went awry; please try again.")]
[(or "emailed" #f) [(or "emailed" #f)
(summarise-code-emailing "Incorrect password, or nonexistent user." email)] (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
[else [else
(create-session! email password)]))) (create-session! email password)])))
(define (register-page #:email [email ""] (define (register-form #:email [email ""]
#:code [code ""] #:code [code ""]
#:error-message [error-message #f]) #:error-message [error-message #f])
(with-site-config (with-site-config
@ -308,7 +340,7 @@
(define (apply-account-code request) (define (apply-account-code request)
(define-form-bindings request (email code password confirm_password)) (define-form-bindings request (email code password confirm_password))
(define (retry msg) (define (retry msg)
(register-page #:email email (register-form #:email email
#:code code #:code code
#:error-message msg)) #:error-message msg))
(cond (cond
@ -346,14 +378,24 @@
(code ,email) ". Please check your email and then click " (code ,email) ". Please check your email and then click "
"the button to continue:") "the button to continue:")
`(a ((class "btn btn-primary") `(a ((class "btn btn-primary")
(href ,(embed-url (lambda (req) (register-page))))) (href ,(embed-url (lambda (req) (register-form)))))
"Enter your code")))))) "Enter your code"))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (package-link package-name) (define (main-page-url)
(if (current-session)
(named-url main-page)
(format "~a~a" static-cached-urlprefix (named-url main-page))))
(define (view-package-url package-name)
(define package-name-str (~a package-name)) (define package-name-str (~a package-name))
`(a ((href ,(named-url package-page package-name-str))) ,package-name-str)) (if (current-session)
(named-url package-page package-name-str)
(format "~a~a" static-cached-urlprefix (named-url package-page package-name-str))))
(define (package-link package-name)
`(a ((href ,(view-package-url package-name))) ,(~a package-name)))
(define (doc-destruct doc) (define (doc-destruct doc)
(match doc (match doc
@ -469,38 +511,37 @@
(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
(bootstrap-response "Racket Package Index" (cond
#:title-element "" [(and (not (current-session)) (not (static-render)))
#:body-class "main-page" ;; Redirect to static version
`(div ((class "jumbotron")) (bootstrap-redirect (main-page-url))]
(h1 "Racket Packages") [else
(p "These are the packages in the official " (bootstrap-response "Racket Package Index"
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html")) #:title-element ""
"package catalog") ".") #:body-class "main-page"
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html")) `(div ((class "jumbotron"))
(kbd "raco pkg install " (var "package-name"))) (h1 "Racket Packages")
" installs a package.") (p "These are the packages in the official "
(p "You can " (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
(a ((id "create-package-link") "package catalog") ".")
(href ,(named-url edit-package-page))) (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(span ((class "label label-success")) (kbd "raco pkg install " (var "package-name")))
,(glyphicon 'plus-sign) " installs a package.")
" add your own")) (p "You can "
" packages to the index.")) (a ((id "create-package-link")
`(div ((id "search-box")) (href ,(named-url edit-package-page)))
(form ((role "form") (span ((class "label label-success"))
(action ,(named-url search-page))) ,(glyphicon 'plus-sign)
,(text-input "q" #:placeholder "Search packages"))) " add your own"))
`(div " packages to the index."))
(p ((class "package-count")) `(div ((id "search-box"))
,(format "~a packages" (length package-name-list))) (form ((role "form")
,(package-summary-table package-name-list)))))) (action ,(named-url search-page)))
,(text-input "q" #:placeholder "Search packages")))
(define (logout-page request) `(div
(with-site-config (p ((class "package-count"))
(parameterize ((bootstrap-cookies (list clear-session-cookie))) ,(format "~a packages" (length package-name-list)))
(when (current-session) (destroy-session! (session-key (current-session)))) ,(package-summary-table package-name-list)))]))))
(bootstrap-redirect (named-url main-page)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -517,156 +558,161 @@
(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 (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f))) (define default-version (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f)))
(if (not pkg) (cond
(bootstrap-response #:code 404 [(and (not (current-session)) (not (static-render)))
#:message #"No such package" ;; Redirect to static version
"Package not found" (bootstrap-redirect (view-package-url package-name))]
`(div "The package " (code ,package-name-str) " does not exist.")) [(not pkg)
(bootstrap-response (~a package-name) (bootstrap-response #:code 404
#:title-element "" #:message #"No such package"
`(div ((class "jumbotron")) "Package not found"
(h1 ,(~a package-name)) `(div "The package " (code ,package-name-str) " does not exist."))]
(p ,(@ pkg description)) [else
,(cond (bootstrap-response (~a package-name)
[(@ pkg build failure-log) #:title-element ""
(build-status (@ pkg build failure-log) `(div ((class "jumbotron"))
"failed" "danger" "fire")] (h1 ,(~a package-name))
[(and (@ pkg build success-log) (p ,(@ pkg description))
(@ pkg build dep-failure-log)) ,(cond
(build-status (@ pkg build dep-failure-log) [(@ pkg build failure-log)
"problems" "warning" "question-sign")] (build-status (@ pkg build failure-log)
[(@ pkg build success-log) "failed" "danger" "fire")]
(build-status (@ pkg build success-log) [(and (@ pkg build success-log)
"ok" "success" "ok")] (@ pkg build dep-failure-log))
[else (build-status (@ pkg build dep-failure-log)
""]) "problems" "warning" "question-sign")]
(div ((class "dropdown")) [(@ pkg build success-log)
,@(let ((docs (or (@ pkg build docs) '()))) (build-status (@ pkg build success-log)
(match docs "ok" "success" "ok")]
[(list) [else
`()] ""])
[(list doc) (div ((class "dropdown"))
(define-values (n u) (doc-destruct doc)) ,@(let ((docs (or (@ pkg build docs) '())))
(list (buildhost-link (match docs
#:attributes `((class "btn btn-success btn-lg")) [(list)
u `()]
"Documentation"))] [(list doc)
[_ (define-values (n u) (doc-destruct doc))
`((button ((class "btn btn-success btn-lg dropdown-toggle") (list (buildhost-link
(data-toggle "dropdown")) #:attributes `((class "btn btn-success btn-lg"))
"Documentation " u
(span ((class "caret")))) "Documentation"))]
(ul ((class "dropdown-menu") [_
(role "menu")) `((button ((class "btn btn-success btn-lg dropdown-toggle")
,@(for/list ((doc docs)) `(li ,(doc-link doc)))))])) (data-toggle "dropdown"))
"Documentation "
(span ((class "caret"))))
(ul ((class "dropdown-menu")
(role "menu"))
,@(for/list ((doc docs)) `(li ,(doc-link doc)))))]))
;; 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) (or (@ pkg authors) '())) (member (current-email) (or (@ pkg authors) '()))
" " " "
`(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 (@ pkg _LOCALLY_MODIFIED_) (if (@ pkg _LOCALLY_MODIFIED_)
`(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 (@ pkg checksum-error) (if (@ pkg checksum-error)
`(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 (@ pkg authors))))) ,(authors-list #:gravatars? #t (@ pkg authors)))))
(tr (th "Documentation") (tr (th "Documentation")
(td ,(doc-links (@ pkg build docs)))) (td ,(doc-links (@ pkg build docs))))
(tr (th "Tags") (tr (th "Tags")
(td ,(tag-links (@ pkg tags)))) (td ,(tag-links (@ pkg tags))))
(tr (th "Last updated") (tr (th "Last updated")
(td ,(utc->string (@ pkg last-updated)))) (td ,(utc->string (@ pkg last-updated))))
(tr (th "Ring") (tr (th "Ring")
(td ,(~a (or (@ pkg ring) "N/A")))) (td ,(~a (or (@ pkg ring) "N/A"))))
(tr (th "Conflicts") (tr (th "Conflicts")
(td ,(package-links (@ pkg conflicts)))) (td ,(package-links (@ pkg conflicts))))
(tr (th "Dependencies") (tr (th "Dependencies")
(td ,(package-links (@ pkg dependencies)))) (td ,(package-links (@ pkg dependencies))))
(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
(@ pkg build success-log) (@ pkg build success-log)
`(li "Compiled successfully: " `(li "Compiled successfully: "
,(buildhost-link (@ pkg build success-log) "transcript"))) ,(buildhost-link (@ pkg build success-log) "transcript")))
,@(maybe-splice ,@(maybe-splice
(@ pkg build failure-log) (@ pkg build failure-log)
`(li "Compiled unsuccessfully: " `(li "Compiled unsuccessfully: "
,(buildhost-link (@ pkg build failure-log) "transcript"))) ,(buildhost-link (@ pkg build failure-log) "transcript")))
,@(maybe-splice ,@(maybe-splice
(@ pkg build conflicts-log) (@ pkg build conflicts-log)
`(li "Conflicts: " `(li "Conflicts: "
,(buildhost-link (@ pkg build conflicts-log) "details"))) ,(buildhost-link (@ pkg build conflicts-log) "details")))
,@(maybe-splice ,@(maybe-splice
(@ pkg build dep-failure-log) (@ pkg build dep-failure-log)
`(li "Dependency problems: " `(li "Dependency problems: "
,(buildhost-link (@ pkg build dep-failure-log) "details"))) ,(buildhost-link (@ pkg build dep-failure-log) "details")))
))) )))
,@(let* ((vs (or (@ pkg versions) (hash))) ,@(let* ((vs (or (@ pkg versions) (hash)))
(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 (@ pkg last-checked)))) (td ,(utc->string (@ pkg last-checked))))
(tr (th "Last edited") (tr (th "Last edited")
(td ,(utc->string (@ pkg last-edit)))) (td ,(utc->string (@ pkg last-edit))))
(tr (th "Modules") (tr (th "Modules")
(td (ul ((class "module-list")) (td (ul ((class "module-list"))
,@(for/list ((mod (or (@ pkg modules) '()))) ,@(for/list ((mod (or (@ pkg modules) '())))
(match-define (list kind path) mod) (match-define (list kind path) mod)
`(li ((class ,kind)) ,path))))) `(li ((class ,kind)) ,path)))))
))))) ))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -678,7 +724,7 @@
(cond (cond
[(and pkg (not (member (current-email) (or (@ pkg authors) '())))) [(and pkg (not (member (current-email) (or (@ pkg authors) '()))))
;; Not ours. Show it instead. ;; Not ours. Show it instead.
(bootstrap-redirect (named-url package-page package-name-str))] (bootstrap-redirect (view-package-url package-name))]
[(not pkg) [(not pkg)
;; Doesn't exist. ;; Doesn't exist.
(package-form #f (draft-package "" (package-form #f (draft-package ""
@ -847,7 +893,7 @@
has-old-name? has-old-name?
" " " "
`(a ((class "btn btn-default") `(a ((class "btn btn-default")
(href ,(named-url package-page old-name))) (href ,(view-package-url old-name)))
"Cancel changes and return to package page")))))) "Cancel changes and return to package page"))))))
)))))) ))))))
@ -866,7 +912,7 @@
(define completion-ch (make-channel)) (define completion-ch (make-channel))
(delete-package! completion-ch (string->symbol package-name-str)) (delete-package! completion-ch (string->symbol package-name-str))
(channel-get completion-ch) (channel-get completion-ch)
(bootstrap-redirect (named-url main-page)))) (bootstrap-redirect (main-page-url))))
(define ((update-draft draft0) request) (define ((update-draft draft0) request)
(define draft (read-draft-form draft0 (request-bindings request))) (define draft (read-draft-form draft0 (request-bindings request)))
@ -875,7 +921,7 @@
["save_changes" ["save_changes"
(if (save-draft! draft) (if (save-draft! draft)
(with-site-config (with-site-config
(bootstrap-redirect (named-url package-page (~a (draft-package-name draft))))) (bootstrap-redirect (view-package-url (draft-package-name draft))))
(package-form "Save failed." (package-form "Save failed."
;; ^ TODO: This is the worst error message. ;; ^ TODO: This is the worst error message.
;; Right up there with "parse error". ;; Right up there with "parse error".
@ -1126,18 +1172,46 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (rerender-indexes!) (define (static-render! handler . named-url-args)
(log-info "Rerendering indexes")) (local-require racket/promise)
(local-require racket/file)
(local-require web-server/private/servlet)
(local-require web-server/http/request-structs)
(define request-url (apply named-url handler named-url-args))
(log-info "Rendering static version of ~a" request-url)
(define response
(parameterize ((static-render #t))
(call-with-continuation-barrier
(lambda ()
(call-with-continuation-prompt
(lambda ()
(apply handler
(request #"GET"
(string->url request-url)
'()
(delay '())
#f
"127.0.0.1"
0
"127.0.0.1")
named-url-args))
servlet-prompt)))))
(define filename (format "~a~a" static-cached-directory request-url))
(make-parent-directory* filename)
(call-with-output-file filename
(response-output response)
#:exists 'replace))
(define (rerender-package! package-name) (define (rerender-all!)
(log-info "Rerendering package ~a" package-name)) (for ((p (all-package-names))) (static-render! package-page (symbol->string p)))
(static-render! main-page))
(define (package-change-handler) (define (package-change-handler)
(let loop ((index-rerender-needed? #f) (let loop ((index-rerender-needed? #f)
(pending-completions '())) (pending-completions '()))
(sync/timeout (and index-rerender-needed? (sync/timeout (and index-rerender-needed?
(lambda () (lambda ()
(rerender-indexes!) (static-render! main-page)
(for ((completion-ch pending-completions)) (for ((completion-ch pending-completions))
(channel-put completion-ch (void))) (channel-put completion-ch (void)))
(loop #f '()))) (loop #f '())))
@ -1145,7 +1219,7 @@
(lambda (_) (lambda (_)
(match (thread-receive) (match (thread-receive)
[(list completion-ch package-name) [(list completion-ch package-name)
(rerender-package! package-name) (static-render! package-page (symbol->string package-name))
(loop #t (if completion-ch (loop #t (if completion-ch
(cons completion-ch pending-completions) (cons completion-ch pending-completions)
pending-completions))])))))) pending-completions))]))))))