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

AWS S3 upload support.

Browse Source
This commit is contained in:
Tony Garnock-Jones 2015-09-30 01:44:32 -04:00
parent 399788edae
commit cf559766b7
6 changed files with 494 additions and 277 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
README.md
View File

@ -30,19 +30,26 @@ Keys useful for deployment:
- *recent-seconds*: number, in seconds; default 172800. Packages - *recent-seconds*: number, in seconds; default 172800. Packages
modified fewer than this many seconds ago are considered "recent", modified fewer than this many seconds ago are considered "recent",
and displayed as such in the UI. and displayed as such in the UI.
- *static-content-target-directory*: either `#f` or a string denoting - *static-output-type*: either `'aws-s3` or `'file`.
a path to a folder to which the static content of the site will be - When `'file`,
copied. - *static-content-target-directory*: either `#f` or a string
- *static-content-update-hook*: either `#f`, or a string containing a denoting a path to a folder to which the static content of
shell command to invoke every time files are updated in the site will be copied.
*static-content-target-directory*. - When `'aws-s3`,
- *aws-s3-bucket+path*: a string naming an S3 bucket and path.
Must end with a forward slash, ".../". AWS access keys are
loaded per the documentation for the `aws` module; usually
from a file `~/.aws-keys`.
- *dynamic-urlprefix*: string; absolute or relative URL, prepended to - *dynamic-urlprefix*: string; absolute or relative URL, prepended to
URLs targetting dynamic content on the site. URLs targetting dynamic content on the site.
- *static-urlprefix*: string; absolute or relative URL, prepended to - *static-urlprefix*: string; absolute or relative URL, prepended to
relative URLs referring to static HTML files placed in relative URLs referring to static HTML files placed in
`static-generated-directory`. `static-generated-directory`.
- *extra-static-content-directories*: list of strings; defaults to - *pkg-index-generated-directory*: a string pointing to where the
the empty list. `pkg-index` package places its redered files, to be served
statically. The source file `static.rkt` in this codebase knows
precisely which files and directories within
`pkg-index-generated-directory` to upload to the final site.
Keys useful for development: Keys useful for development:

11
configs/tonyg.rkt
View File

@ -4,11 +4,18 @@
(main (hash 'port 8444 (main (hash 'port 8444
'reloadable? #t 'reloadable? #t
'package-index-url "https://localhost:8444/pkgs-all.json.gz" 'package-index-url "https://localhost:8444/pkgs-all.json.gz"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Either:
'static-output-type 'file
'static-content-target-directory (build-path (find-system-path 'home-dir) 'static-content-target-directory (build-path (find-system-path 'home-dir)
"public_html/pkg-catalog-static") "public_html/pkg-catalog-static")
;; Or:
;; 'static-output-type 'aws-s3
;; 'aws-s3-bucket+path "pkgs.leastfixedpoint.com/"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
'static-urlprefix "https://localhost/~tonyg/pkg-catalog-static" 'static-urlprefix "https://localhost/~tonyg/pkg-catalog-static"
'dynamic-urlprefix "https://localhost:8444" 'dynamic-urlprefix "https://localhost:8444"
'backend-baseurl "https://localhost:8445" 'backend-baseurl "https://localhost:8445"
'extra-static-content-directories (list (build-path (find-system-path 'home-dir) 'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
"public_html/pkg-index-static")) "public_html/pkg-index-static")
)) ))

477
src/site.rkt
View File

@ -44,9 +44,9 @@
(define nav-index "Package Index") (define nav-index "Package Index")
(define nav-search "Search") (define nav-search "Search")
(define navbar-header (define (navbar-header)
`(a ((href "http://www.racket-lang.org/")) `(a ((href "http://www.racket-lang.org/"))
(img ((src ,(string-append static-urlprefix "/logo-and-text.png")) (img ((src ,(static-resource-url "/logo-and-text.png"))
(height "60") (height "60")
(alt "Racket Package Index"))))) (alt "Racket Package Index")))))
@ -75,7 +75,7 @@
[("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]
[("package-not-found") package-not-found-page] [("not-found") not-found-page]
[("create") edit-package-page] [("create") edit-package-page]
[("login") login-page] [("login") login-page]
[("register-or-reset") register-or-reset-page] [("register-or-reset") register-or-reset-page]
@ -106,6 +106,11 @@
(define (named-url . args) (define (named-url . args)
(string-append dynamic-urlprefix (apply relative-named-url args))) (string-append dynamic-urlprefix (apply relative-named-url args)))
(define (static-resource-url suffix)
(if (rendering-static-page?)
(string-append static-urlprefix suffix)
suffix))
(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 ...)))
@ -113,7 +118,7 @@
(authentication-wrap* #t request (lambda () body ...))) (authentication-wrap* #t request (lambda () body ...)))
(define-syntax-rule (with-site-config body ...) (define-syntax-rule (with-site-config body ...)
(parameterize ((bootstrap-navbar-header navbar-header) (parameterize ((bootstrap-navbar-header (navbar-header))
(bootstrap-navigation `((,nav-index ,(main-page-url)) (bootstrap-navigation `((,nav-index ,(main-page-url))
(,nav-search ,(named-url search-page)) (,nav-search ,(named-url search-page))
;; ((div ,(glyphicon 'download-alt) ;; ((div ,(glyphicon 'download-alt)
@ -121,7 +126,12 @@
;; "http://download.racket-lang.org/") ;; "http://download.racket-lang.org/")
)) ))
(bootstrap-static-urlprefix (if (rendering-static-page?) static-urlprefix "")) (bootstrap-static-urlprefix (if (rendering-static-page?) static-urlprefix ""))
(bootstrap-inline-js (format "PkgSiteDynamicBaseUrl = '~a';" dynamic-urlprefix)) (bootstrap-inline-js
(string-append (format "PkgSiteDynamicBaseUrl = '~a';" dynamic-urlprefix)
(format "PkgSiteStaticBaseUrl = '~a';" static-urlprefix)
(format "IsStaticPage = ~a;" (if (rendering-static-page?)
"true"
"false"))))
(jsonp-baseurl backend-baseurl)) (jsonp-baseurl backend-baseurl))
body ...)) body ...))
@ -595,44 +605,46 @@
(define (main-page request) (define (main-page request)
(parameterize ((bootstrap-active-navigation nav-index) (parameterize ((bootstrap-active-navigation nav-index)
(bootstrap-page-scripts (list (string-append static-urlprefix "/searchbox.js")))) (bootstrap-page-scripts (list (static-resource-url "/searchbox.js"))))
(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" (if (and (not (rendering-static-page?)) (use-cache?))
#:title-element "" (bootstrap-redirect (main-page-url))
#:body-class "main-page" (bootstrap-response "Racket Package Index"
`(div ((class "jumbotron")) #:title-element ""
(h1 "BETA Racket Package Server") #:body-class "main-page"
(p "These are the packages in the official " `(div ((class "jumbotron"))
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html")) (h1 "BETA Racket Package Server")
"package catalog") ".") (p "These are the packages in the official "
(p "This is a temporary database instance! While the information " (a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
"in the database is copied from the main Racket catalog, changes " "package catalog") ".")
"will NOT be propagated back to the main Racket catalog.") (p "This is a temporary database instance! While the information "
(p "Questions? Comments? Bugs? Email " "in the database is copied from the main Racket catalog, changes "
(a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu") "will NOT be propagated back to the main Racket catalog.")
" or twitter " (p "Questions? Comments? Bugs? Email "
(a ((href "https://twitter.com/leastfixedpoint")) "@leastfixedpoint") (a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
".") " or twitter "
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html")) (a ((href "https://twitter.com/leastfixedpoint")) "@leastfixedpoint")
(kbd "raco pkg install " (var "package-name"))) ".")
" installs a package.") (p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(p "You can " (kbd "raco pkg install " (var "package-name")))
(a ((id "create-package-link") " installs a package.")
(href ,(named-url edit-package-page))) (p "You can "
(span ((class "label label-success")) (a ((id "create-package-link")
,(glyphicon 'plus-sign) (href ,(named-url edit-package-page)))
" add your own")) (span ((class "label label-success"))
" packages to the index.")) ,(glyphicon 'plus-sign)
`(div ((id "search-box")) " add your own"))
(form ((role "form") " packages to the index."))
(action ,(named-url search-page))) `(div ((id "search-box"))
,(text-input "q" #:placeholder "Search packages"))) (form ((role "form")
`(div (action ,(named-url search-page)))
(p ((class "package-count")) ,(text-input "q" #:placeholder "Search packages")))
,(format "~a packages" (length package-name-list))) `(div
,(package-summary-table package-name-list)))))) (p ((class "package-count"))
,(format "~a packages" (length package-name-list)))
,(package-summary-table package-name-list)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -653,186 +665,195 @@
#f])) #f]))
deps)) deps))
(define (package-not-found-page request [package-name-str #f]) (define (not-found-page request [package-name-str #f])
(authentication-wrap (authentication-wrap
#:request request #:request request
(bootstrap-response #:code 404 (bootstrap-response #:code 404
#:message #"No such package" #:message #"Page not found"
"Package not found" "Page not found"
(if package-name-str `(div "The page you requested does not exist.")
`(div "The package " (code ,package-name-str) " does not exist.") `(ul (li (a ((href ,(main-page-url)))
`(div "The requested package does not exist."))
`(ul (li (a ((href ,(named-url main-page)))
"Return to the package index")))))) "Return to the package index"))))))
(define (package-page request package-name-str) (define (package-page request package-name-str)
(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))
(if (not pkg) (authentication-wrap
(package-not-found-page request package-name-str) #:request request
(authentication-wrap (cond
#:request request [(not pkg)
(define default-version (package-default-version pkg)) (bootstrap-response #:code 404
(bootstrap-response (~a package-name) #:message #"No such package"
#:title-element "" "Package not found"
`(div ((class "jumbotron")) (if package-name-str
(h1 ,(~a package-name)) `(div "The package " (code ,package-name-str) " does not exist.")
(p ,(package-description pkg)) `(div "The requested package does not exist."))
,(cond `(ul (li (a ((href ,(main-page-url)))
[(package-build-failure-log pkg) "Return to the package index"))))]
(build-status (package-build-failure-log pkg) [(and (not (rendering-static-page?)) (use-cache?))
"failed" "danger" "fire")] (bootstrap-redirect (view-package-url package-name))]
[(and (package-build-success-log pkg) [else
(package-build-dep-failure-log pkg)) (let ((default-version (package-default-version pkg)))
(build-status (package-build-dep-failure-log pkg) (bootstrap-response (~a package-name)
"problems" "warning" "question-sign")] #:title-element ""
[(package-build-success-log pkg) `(div ((class "jumbotron"))
(build-status (package-build-success-log pkg) (h1 ,(~a package-name))
"ok" "success" "ok")] (p ,(package-description pkg))
[else ,(cond
""]) [(package-build-failure-log pkg)
(div ((class "dropdown")) (build-status (package-build-failure-log pkg)
,@(let ((docs (package-docs pkg))) "failed" "danger" "fire")]
(match docs [(and (package-build-success-log pkg)
[(list) (package-build-dep-failure-log pkg))
`()] (build-status (package-build-dep-failure-log pkg)
[(list doc) "problems" "warning" "question-sign")]
(define-values (n u) (doc-destruct doc)) [(package-build-success-log pkg)
(list (buildhost-link (build-status (package-build-success-log pkg)
#:attributes `((class "btn btn-success btn-lg")) "ok" "success" "ok")]
u [else
`(span ,(glyphicon 'file) " Documentation")))] ""])
[_ (div ((class "dropdown"))
`((button ((class "btn btn-success btn-lg dropdown-toggle") ,@(let ((docs (package-docs pkg)))
(data-toggle "dropdown")) (match docs
,(glyphicon 'file) [(list)
" Documentation " `()]
(span ((class "caret")))) [(list doc)
(ul ((class "dropdown-menu") (define-values (n u) (doc-destruct doc))
(role "menu")) (list (buildhost-link
,@(for/list ((doc docs)) `(li ,(doc-link doc)))))])) #:attributes `((class "btn btn-success btn-lg"))
u
`(span ,(glyphicon 'file) " Documentation")))]
[_
`((button ((class "btn btn-success btn-lg dropdown-toggle")
(data-toggle "dropdown"))
,(glyphicon 'file)
" 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 (td ,(package-links
(dependencies->package-names (dependencies->package-names
(package-dependencies pkg))))) (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)))))
))))) )))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1309,23 +1330,33 @@
(define (rerender-all!) (define (rerender-all!)
(thread-send (package-change-handler-thread) 'rerender-all!)) (thread-send (package-change-handler-thread) 'rerender-all!))
(define (internal:rerender-package-not-found!) (define (internal:rerender-not-found!)
(static-render! relative-named-url package-not-found-page #:ignore-response-code? #t) ;; TODO: general-purpose error page instead.
(log-info "Generating package/.htaccess") (static-render! #:mime-type "text/html"
(call-with-output-file relative-named-url not-found-page
(format "~a/package/.htaccess" static-generated-directory) #:ignore-response-code? #t)
(lambda (p) (log-info "Generating .htaccess")
(fprintf p "ErrorDocument 404 ~a~a\n" (static-put-file! "/.htaccess"
static-urlprefix (string->bytes/utf-8
(relative-named-url package-not-found-page))) (format "ErrorDocument 404 ~a~a\n"
#:exists 'replace) static-urlprefix
(finish-static-update!)) (relative-named-url not-found-page)))
"text/plain")
(static-finish-update!))
(define (package-change-handler index-rerender-needed? pending-completions) (define (package-change-handler index-rerender-needed? pending-completions)
(sync/timeout (and index-rerender-needed? (sync/timeout (and index-rerender-needed?
(lambda () (lambda ()
(static-render! relative-named-url main-page #:filename "/index.html") (static-render! #:mime-type "text/html"
(finish-static-update!) relative-named-url main-page
#:filename "/index.html")
(static-render! #:mime-type "application/json"
relative-named-url json-search-completions)
(static-render! #:mime-type "application/json"
relative-named-url json-tag-search-completions)
(static-render! #:mime-type "application/json"
relative-named-url json-formal-tags)
(static-finish-update!)
(for ((completion-ch pending-completions)) (for ((completion-ch pending-completions))
(channel-put completion-ch (void))) (channel-put completion-ch (void)))
(package-change-handler #f '()))) (package-change-handler #f '())))
@ -1333,21 +1364,23 @@
(lambda (_) (lambda (_)
(match (thread-receive) (match (thread-receive)
['upgrade ;; Happens every time site.rkt is reloaded ['upgrade ;; Happens every time site.rkt is reloaded
(internal:rerender-package-not-found!) (internal:rerender-not-found!)
(package-change-handler index-rerender-needed? (package-change-handler index-rerender-needed?
pending-completions)] pending-completions)]
['rerender-all! ['rerender-all!
(log-info "rerender-all!") (log-info "rerender-all!")
(for ((p (all-package-names))) (for ((p (all-package-names)))
(update-external-package-information! p) (update-external-package-information! p)
(static-render! relative-named-url (static-render! #:mime-type "text/html"
relative-named-url
package-page package-page
(symbol->string p))) (symbol->string p)))
(package-change-handler #t (package-change-handler #t
pending-completions)] pending-completions)]
[(list 'package-changed completion-ch package-name) [(list 'package-changed completion-ch package-name)
(update-external-package-information! package-name) (update-external-package-information! package-name)
(static-render! relative-named-url (static-render! #:mime-type "text/html"
relative-named-url
package-page package-page
(symbol->string package-name)) (symbol->string package-name))
(package-change-handler (package-change-handler

231
src/static.rkt
View File

@ -1,40 +1,76 @@
#lang racket/base #lang racket/base
(provide static-generated-directory (provide rendering-static-page?
rendering-static-page?
static-render! static-render!
finish-static-update! static-put-file!
static-delete-file!
static-finish-update!
extra-files-paths) extra-files-paths)
(require racket/match)
(require racket/system) (require racket/system)
(require racket/path)
(require racket/port)
(require racket/promise) (require racket/promise)
(require racket/file) (require racket/file)
(require web-server/private/servlet) (require web-server/private/servlet)
(require web-server/http/request-structs) (require web-server/http/request-structs)
(require web-server/http/response-structs) (require web-server/http/response-structs)
(require file/md5)
(require xml/path)
(require net/url) (require net/url)
(require aws/s3)
(require reloadable)
(require "config.rkt") (require "config.rkt")
(require "daemon.rkt")
(require "rpc.rkt")
(require "hash-utils.rkt") (require "hash-utils.rkt")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Config
(define static-output-type
;; Either 'aws-s3 or 'file
(or (@ (config) static-output-type)
'file))
(define aws-s3-bucket+path
;; Must end in "/"
(@ (config) aws-s3-bucket+path))
(define static-generated-directory (define static-generated-directory
;; Relevant to static-output-type 'file only
(config-path (or (@ (config) static-generated-directory) (config-path (or (@ (config) static-generated-directory)
(build-path (var-path) "generated-htdocs")))) (build-path (var-path) "generated-htdocs"))))
(define static-content-target-directory (define static-content-target-directory
;; Relevant to static-output-type 'file only
(let ((p (@ (config) static-content-target-directory))) (let ((p (@ (config) static-content-target-directory)))
(and p (config-path p)))) (and p (config-path p))))
(define static-content-update-hook (@ (config) static-content-update-hook)) (define pkg-index-generated-directory
(config-path (@ (config) pkg-index-generated-directory)))
(define extra-static-content-directories ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(map config-path ;; Static rendering daemon -- Interface
(or (@ (config) extra-static-content-directories)
'())))
(define rendering-static-page? (make-parameter #f)) (define rendering-static-page? (make-parameter #f))
(define (assert-absolute! what absolute-path)
(when (not (eqv? (string-ref absolute-path 0) #\/))
(error what "Path must start with /; got ~v" absolute-path)))
(define (static-put-file! absolute-path content-bytes mime-type)
(assert-absolute! 'static-put-file! absolute-path)
(renderer-rpc 'put-file! absolute-path content-bytes mime-type))
(define (static-delete-file! absolute-path)
(assert-absolute! 'static-delete-file! absolute-path)
(renderer-rpc 'delete-file! absolute-path))
(define (static-render! #:filename [base-filename #f] (define (static-render! #:filename [base-filename #f]
#:ignore-response-code? [ignore-response-code? #f] #:ignore-response-code? [ignore-response-code? #f]
#:mime-type mime-type
named-url handler . named-url-args) named-url handler . named-url-args)
(define request-url (apply named-url handler named-url-args)) (define request-url (apply named-url handler named-url-args))
(log-info "Rendering static version of ~a~a" (log-info "Rendering static version of ~a~a"
@ -59,40 +95,167 @@
"127.0.0.1") "127.0.0.1")
named-url-args)) named-url-args))
servlet-prompt))))) servlet-prompt)))))
(define filename (format "~a~a" static-generated-directory (or base-filename request-url))) (define absolute-path (or base-filename request-url))
(assert-absolute! 'static-render! absolute-path)
(define content-bytes (call-with-output-bytes (response-output response)))
(cond (cond
[(or (<= 200 (response-code response) 299) ;; "OKish" range [(or (<= 200 (response-code response) 299) ;; "OKish" range
ignore-response-code?) ignore-response-code?)
(make-parent-directory* filename) (static-put-file! absolute-path content-bytes mime-type)]
(call-with-output-file filename
(response-output response)
#:exists 'replace)]
[(= (response-code response) 404) ;; Not found -> delete the file [(= (response-code response) 404) ;; Not found -> delete the file
(when (file-exists? filename) (static-delete-file! absolute-path)]
(delete-file filename))]
[else [else
(log-warning "Unexpected response code ~v when static-rendering ~v" (log-warning "Unexpected response code ~v when static-rendering ~v"
(response-code response) (response-code response)
(cons handler named-url-args))])) (cons handler named-url-args))]))
(define (finish-static-update!) (define (static-finish-update!)
(when static-content-target-directory (renderer-rpc 'finish-update!))
(make-directory* static-content-target-directory)
(define command ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(append (list (path->string (find-executable-path "rsync")) ;; Static rendering daemon -- Implementation
"-a"
"--delete" (define (static-renderer-main)
(path->string (build-path static-generated-directory ".")) (match static-output-type
(path->string (build-path (config-path "../static") "."))) ['file (static-renderer-file)]
(for/list [(dir extra-static-content-directories)] ['aws-s3 (static-renderer-aws-s3 #f)])
(path->string (build-path dir "."))) (static-renderer-main))
(list (path->string (build-path static-content-target-directory ".")))))
(log-info "Executing rsync to replicate static content; argv: ~v" command) ;;---------------------------------------- 'file
(apply system* command))
(when static-content-update-hook (define (static-renderer-file)
(system static-content-update-hook))) (rpc-handler (sync (rpc-request-evt))
[('reload!)
(values (void) (void))]
[('put-file! absolute-path content-bytes mime-type)
(define filename (format "~a~a" static-generated-directory absolute-path))
(make-parent-directory* filename)
(call-with-output-file filename
(lambda (p) (write-bytes content-bytes p))
#:exists 'replace)
(values (void) (void))]
[('delete-file! absolute-path)
(define filename (format "~a~a" static-generated-directory absolute-path))
(when (file-exists? filename)
(delete-file filename))
(values (void) (void))]
[('finish-update!)
(when static-content-target-directory
(make-directory* static-content-target-directory)
(define command
(append (list (path->string (find-executable-path "rsync"))
"-a"
"--delete"
(path->string (build-path static-generated-directory "."))
(path->string (build-path (config-path "../static") ".")))
(list (path->string (build-path pkg-index-generated-directory ".")))
(list (path->string (build-path static-content-target-directory ".")))))
(log-info "Executing rsync to replicate static content; argv: ~v" command)
(apply system* command))
(values (void) (void))]))
;;---------------------------------------- 'aws-s3
(define (initial-aws-s3-index)
(for/hash [(entry (ls/proc aws-s3-bucket+path append '()))]
(match-define (pregexp "^\"(.*)\"$" (list _ file-md5-str))
(apply string-append (se-path*/list '(ETag) entry)))
(values (se-path* '(Key) entry)
(string->bytes/utf-8 file-md5-str))))
(define (absolute-path->relative-path absolute-path)
(assert-absolute! 'absolute-path->relative-path absolute-path)
(substring absolute-path 1))
(define (aws-put-file! index absolute-path content-bytes mime-type [headers '()])
(define relative-path (absolute-path->relative-path absolute-path))
(define new-md5 (md5 content-bytes))
(if (equal? new-md5 (hash-ref index relative-path #f))
(log-info "Not uploading ~a to S3, since MD5 has not changed" relative-path)
(begin
(log-info "Uploading ~a to S3; new MD5 = ~a" relative-path new-md5)
(put/bytes (string-append aws-s3-bucket+path relative-path)
content-bytes
mime-type
headers)))
(hash-set index relative-path new-md5))
(define (extension-map p)
(match (filename-extension p)
[#"html" "text/html"]
[#"css" "text/css"]
[#"js" "application/javascript"]
[#"json" "application/json"]
[#"png" "image/png"]
[#"svg" "image/svg"]
[#f "application/octet-stream"]
[other ;; (log-info "Unknown extension in extension-map: ~a" other)
"application/octet-stream"]))
(define (upload-directory! index source-directory0 target-absolute-path-prefix)
(define source-directory (simple-form-path source-directory0))
(for/fold [(index index)]
[(filepath (find-files file-exists? source-directory))]
(define absolute-path
(path->string (build-path target-absolute-path-prefix
(find-relative-path source-directory filepath))))
(aws-put-file! index
absolute-path
(file->bytes filepath)
(extension-map filepath))))
(define (static-renderer-aws-s3 index)
(let ((index (or index (initial-aws-s3-index))))
(match
(rpc-handler (sync (rpc-request-evt))
[('reload!)
(values (void) 'reload!)]
[('put-file! absolute-path content-bytes mime-type)
(values (void) (aws-put-file! index absolute-path content-bytes mime-type))]
[('delete-file! absolute-path)
(define relative-path (absolute-path->relative-path absolute-path))
(log-info "Deleting ~a from S3" relative-path)
(delete (string-append aws-s3-bucket+path relative-path))
(values (void) (hash-remove index relative-path))]
[('finish-update!)
(let* ((index (upload-directory! index (build-path (config-path "../static") ".") "/"))
(index (upload-directory! index
(build-path pkg-index-generated-directory "pkg")
"/pkg/")))
(values (void)
(for/fold [(index index)]
[(leaf (in-list `(("atom.xml" "application/atom+xml")
("pkgs" "application/octet-stream")
("pkgs-all" "application/octet-stream")
("pkgs-all.json.gz" "application/json"
(Content-Encoding . "gzip"))
("pkgs.json" "application/json"))))]
(match-define (list* filename mime-type headers) leaf)
(aws-put-file! index
(path->string (build-path "/" filename))
(file->bytes
(build-path pkg-index-generated-directory filename))
mime-type
headers))))])
['reload! (void)] ;; effectively restarts daemon
[next-index (static-renderer-aws-s3 next-index)])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Static rendering daemon -- Startup
(define static-renderer-thread
(make-persistent-state 'static-renderer-thread
(lambda () (daemon-thread 'static-renderer
(lambda () (static-renderer-main))))))
(define (renderer-rpc . request) (apply rpc-call (static-renderer-thread) request))
(renderer-rpc 'reload!)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Interface to web-server static file serving
(define (extra-files-paths) (define (extra-files-paths)
(list* static-generated-directory (list static-generated-directory
(config-path "../static") (config-path "../static")
extra-static-content-directories)) (config-path pkg-index-generated-directory)))

2
static/searchbox.js
View File

@ -1,6 +1,6 @@
$(document).ready(function () { $(document).ready(function () {
$("#q").focus(); $("#q").focus();
PkgSite.getJSON("search-completions", function (searchCompletions) { PkgSite.staticJSON("search-completions", function (searchCompletions) {
searchCompletions.sort(); searchCompletions.sort();
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#q")), searchCompletions); PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#q")), searchCompletions);
}); });

27
static/site.js
View File

@ -25,14 +25,20 @@ PkgSite = (function () {
}); });
} }
function getJSON(relative_url, k) { function dynamicJSON(relative_url, k) {
return $.getJSON(PkgSiteDynamicBaseUrl + '/json/' + relative_url, k); return $.getJSON(PkgSiteDynamicBaseUrl + '/json/' + relative_url, k);
} }
function staticJSON(relative_url, k) {
return $.getJSON((IsStaticPage ? PkgSiteStaticBaseUrl : PkgSiteDynamicBaseUrl)
+ '/json/' + relative_url, k);
}
return { return {
multiTermComplete: multiTermComplete, multiTermComplete: multiTermComplete,
preventTabMovingDuringSelection: preventTabMovingDuringSelection, preventTabMovingDuringSelection: preventTabMovingDuringSelection,
getJSON: getJSON dynamicJSON: dynamicJSON,
staticJSON: staticJSON
}; };
})(); })();
@ -40,13 +46,14 @@ $(document).ready(function () {
$("table.sortable").tablesorter(); $("table.sortable").tablesorter();
if ($("#tags").length) { if ($("#tags").length) {
PkgSite.getJSON((document.body.className === "package-form") PkgSite.staticJSON((document.body.className === "package-form")
? "formal-tags" ? "formal-tags"
: "tag-search-completions", : "tag-search-completions",
function (completions) { function (completions) {
completions.sort(); completions.sort();
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#tags")), PkgSite.multiTermComplete(
completions); PkgSite.preventTabMovingDuringSelection($("#tags")),
}); completions);
});
} }
}); });