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
modified fewer than this many seconds ago are considered "recent",
and displayed as such in the UI.
- *static-content-target-directory*: either `#f` or a string denoting
a path to a folder to which the static content of the site will be
copied.
- *static-content-update-hook*: either `#f`, or a string containing a
shell command to invoke every time files are updated in
*static-content-target-directory*.
- *static-output-type*: either `'aws-s3` or `'file`.
- When `'file`,
- *static-content-target-directory*: either `#f` or a string
denoting a path to a folder to which the static content of
the site will be copied.
- 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
URLs targetting dynamic content on the site.
- *static-urlprefix*: string; absolute or relative URL, prepended to
relative URLs referring to static HTML files placed in
`static-generated-directory`.
- *extra-static-content-directories*: list of strings; defaults to
the empty list.
- *pkg-index-generated-directory*: a string pointing to where the
`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:

11
configs/tonyg.rkt
View File

@ -4,11 +4,18 @@
(main (hash 'port 8444
'reloadable? #t
'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)
"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"
'dynamic-urlprefix "https://localhost:8444"
'backend-baseurl "https://localhost:8445"
'extra-static-content-directories (list (build-path (find-system-path 'home-dir)
"public_html/pkg-index-static"))
'pkg-index-generated-directory (build-path (find-system-path 'home-dir)
"public_html/pkg-index-static")
))

477
src/site.rkt
View File

@ -44,9 +44,9 @@
(define nav-index "Package Index")
(define nav-search "Search")
(define navbar-header
(define (navbar-header)
`(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")
(alt "Racket Package Index")))))
@ -75,7 +75,7 @@
[("search") search-page]
[("package" (string-arg)) 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]
[("login") login-page]
[("register-or-reset") register-or-reset-page]
@ -106,6 +106,11 @@
(define (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 ...)
(authentication-wrap* #f request (lambda () body ...)))
@ -113,7 +118,7 @@
(authentication-wrap* #t request (lambda () 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))
(,nav-search ,(named-url search-page))
;; ((div ,(glyphicon 'download-alt)
@ -121,7 +126,12 @@
;; "http://download.racket-lang.org/")
))
(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))
body ...))
@ -595,44 +605,46 @@
(define (main-page request)
(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))))
(authentication-wrap
#:request request
(bootstrap-response "Racket Package Index"
#:title-element ""
#:body-class "main-page"
`(div ((class "jumbotron"))
(h1 "BETA Racket Package Server")
(p "These are the packages in the official "
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
"package catalog") ".")
(p "This is a temporary database instance! While the information "
"in the database is copied from the main Racket catalog, changes "
"will NOT be propagated back to the main Racket catalog.")
(p "Questions? Comments? Bugs? Email "
(a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
" or twitter "
(a ((href "https://twitter.com/leastfixedpoint")) "@leastfixedpoint")
".")
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(kbd "raco pkg install " (var "package-name")))
" installs a package.")
(p "You can "
(a ((id "create-package-link")
(href ,(named-url edit-package-page)))
(span ((class "label label-success"))
,(glyphicon 'plus-sign)
" add your own"))
" packages to the index."))
`(div ((id "search-box"))
(form ((role "form")
(action ,(named-url search-page)))
,(text-input "q" #:placeholder "Search packages")))
`(div
(p ((class "package-count"))
,(format "~a packages" (length package-name-list)))
,(package-summary-table package-name-list))))))
(if (and (not (rendering-static-page?)) (use-cache?))
(bootstrap-redirect (main-page-url))
(bootstrap-response "Racket Package Index"
#:title-element ""
#:body-class "main-page"
`(div ((class "jumbotron"))
(h1 "BETA Racket Package Server")
(p "These are the packages in the official "
(a ((href "http://docs.racket-lang.org/pkg/getting-started.html"))
"package catalog") ".")
(p "This is a temporary database instance! While the information "
"in the database is copied from the main Racket catalog, changes "
"will NOT be propagated back to the main Racket catalog.")
(p "Questions? Comments? Bugs? Email "
(a ((href "mailto:tonyg@ccs.neu.edu")) "tonyg@ccs.neu.edu")
" or twitter "
(a ((href "https://twitter.com/leastfixedpoint")) "@leastfixedpoint")
".")
(p (a ((href "http://docs.racket-lang.org/pkg/cmdline.html"))
(kbd "raco pkg install " (var "package-name")))
" installs a package.")
(p "You can "
(a ((id "create-package-link")
(href ,(named-url edit-package-page)))
(span ((class "label label-success"))
,(glyphicon 'plus-sign)
" add your own"))
" packages to the index."))
`(div ((id "search-box"))
(form ((role "form")
(action ,(named-url search-page)))
,(text-input "q" #:placeholder "Search packages")))
`(div
(p ((class "package-count"))
,(format "~a packages" (length package-name-list)))
,(package-summary-table package-name-list)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -653,186 +665,195 @@
#f]))
deps))
(define (package-not-found-page request [package-name-str #f])
(define (not-found-page request [package-name-str #f])
(authentication-wrap
#:request request
(bootstrap-response #:code 404
#:message #"No such package"
"Package not found"
(if package-name-str
`(div "The package " (code ,package-name-str) " does not exist.")
`(div "The requested package does not exist."))
`(ul (li (a ((href ,(named-url main-page)))
#:message #"Page not found"
"Page not found"
`(div "The page you requested does not exist.")
`(ul (li (a ((href ,(main-page-url)))
"Return to the package index"))))))
(define (package-page request package-name-str)
(define package-name (string->symbol package-name-str))
(define pkg (package-detail package-name))
(if (not pkg)
(package-not-found-page request package-name-str)
(authentication-wrap
#:request request
(define default-version (package-default-version pkg))
(bootstrap-response (~a package-name)
#:title-element ""
`(div ((class "jumbotron"))
(h1 ,(~a package-name))
(p ,(package-description pkg))
,(cond
[(package-build-failure-log pkg)
(build-status (package-build-failure-log pkg)
"failed" "danger" "fire")]
[(and (package-build-success-log pkg)
(package-build-dep-failure-log pkg))
(build-status (package-build-dep-failure-log pkg)
"problems" "warning" "question-sign")]
[(package-build-success-log pkg)
(build-status (package-build-success-log pkg)
"ok" "success" "ok")]
[else
""])
(div ((class "dropdown"))
,@(let ((docs (package-docs pkg)))
(match docs
[(list)
`()]
[(list doc)
(define-values (n u) (doc-destruct doc))
(list (buildhost-link
#: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)))))]))
(authentication-wrap
#:request request
(cond
[(not pkg)
(bootstrap-response #:code 404
#:message #"No such package"
"Package not found"
(if package-name-str
`(div "The package " (code ,package-name-str) " does not exist.")
`(div "The requested package does not exist."))
`(ul (li (a ((href ,(main-page-url)))
"Return to the package index"))))]
[(and (not (rendering-static-page?)) (use-cache?))
(bootstrap-redirect (view-package-url package-name))]
[else
(let ((default-version (package-default-version pkg)))
(bootstrap-response (~a package-name)
#:title-element ""
`(div ((class "jumbotron"))
(h1 ,(~a package-name))
(p ,(package-description pkg))
,(cond
[(package-build-failure-log pkg)
(build-status (package-build-failure-log pkg)
"failed" "danger" "fire")]
[(and (package-build-success-log pkg)
(package-build-dep-failure-log pkg))
(build-status (package-build-dep-failure-log pkg)
"problems" "warning" "question-sign")]
[(package-build-success-log pkg)
(build-status (package-build-success-log pkg)
"ok" "success" "ok")]
[else
""])
(div ((class "dropdown"))
,@(let ((docs (package-docs pkg)))
(match docs
[(list)
`()]
[(list doc)
(define-values (n u) (doc-destruct doc))
(list (buildhost-link
#: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
(package-readme-url pkg)
`(a ((class "btn btn-info btn-lg")
(href ,(package-readme-url pkg)))
,(glyphicon 'eye-open)
" README"))
" "
,@(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.
" "
,(if (equal? (@ default-version source)
(@ default-version source_url))
`(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url)))
,(glyphicon 'download) " Download"
;; ,(if (regexp-match? "(?i:\\.zip$)" (or (@ default-version source_url) ""))
;; " Zip file"
;; " Download")
)
`(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url)))
,(glyphicon 'link) " Code"))
;; Heuristic guess as to whether we should present a "browse"
;; link or a "download" link.
" "
,(if (equal? (@ default-version source)
(@ default-version source_url))
`(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url)))
,(glyphicon 'download) " Download"
;; ,(if (regexp-match? "(?i:\\.zip$)" (or (@ default-version source_url) ""))
;; " Zip file"
;; " Download")
)
`(a ((class "btn btn-default btn-lg")
(href ,(@ default-version source_url)))
,(glyphicon 'link) " Code"))
,@(maybe-splice
(member (current-email) (package-authors pkg))
" "
`(a ((class "btn btn-info btn-lg")
(href ,(named-url edit-package-page package-name-str)))
,(glyphicon 'edit) " Edit this package"))
))
,@(maybe-splice
(member (current-email) (package-authors pkg))
" "
`(a ((class "btn btn-info btn-lg")
(href ,(named-url edit-package-page package-name-str)))
,(glyphicon 'edit) " Edit this package"))
))
(if (package-locally-modified? pkg)
`(div ((class "alert alert-warning")
(role "alert"))
,(glyphicon 'exclamation-sign)
" This package has been modified since the package index was last rebuilt."
" The next index refresh is scheduled for "
,(utc->string (/ (next-fetch-deadline) 1000)) ".")
"")
(if (package-locally-modified? pkg)
`(div ((class "alert alert-warning")
(role "alert"))
,(glyphicon 'exclamation-sign)
" This package has been modified since the package index was last rebuilt."
" The next index refresh is scheduled for "
,(utc->string (/ (next-fetch-deadline) 1000)) ".")
"")
(if (package-checksum-error pkg)
`(div ((class "alert alert-danger")
(role "alert"))
(span ((class "label label-danger"))
"Checksum error")
" The package checksum does not match"
" the package source code.")
"")
(if (package-checksum-error pkg)
`(div ((class "alert alert-danger")
(role "alert"))
(span ((class "label label-danger"))
"Checksum error")
" The package checksum does not match"
" the package source code.")
"")
`(table ((class "package-details"))
(tr (th "Authors")
(td (div ((class "authors-detail"))
,(authors-list #:gravatars? #t (package-authors pkg)))))
(tr (th "Documentation")
(td ,(doc-links (package-docs pkg))))
(tr (th "Tags")
(td ,(tag-links (package-tags pkg))))
(tr (th "Last updated")
(td ,(utc->string (package-last-updated pkg))))
(tr (th "Ring")
(td ,(~a (or (package-ring pkg) "N/A"))))
(tr (th "Conflicts")
(td ,(package-links (package-conflicts pkg))))
(tr (th "Dependencies")
(td ,(package-links
(dependencies->package-names
(package-dependencies pkg)))))
(tr (th "Most recent build results")
(td (ul ((class "build-results"))
,@(maybe-splice
(package-build-success-log pkg)
`(li "Compiled successfully: "
,(buildhost-link (package-build-success-log pkg)
"transcript")))
,@(maybe-splice
(package-build-failure-log pkg)
`(li "Compiled unsuccessfully: "
,(buildhost-link (package-build-failure-log pkg)
"transcript")))
,@(maybe-splice
(package-build-conflicts-log pkg)
`(li "Conflicts: "
,(buildhost-link (package-build-conflicts-log pkg)
"details")))
,@(maybe-splice
(package-build-dep-failure-log pkg)
`(li "Dependency problems: "
,(buildhost-link (package-build-dep-failure-log pkg)
"details")))
)))
,@(let* ((vs (package-versions pkg))
(empty-checksum "9f098dddde7f217879070816090c1e8e74d49432")
(vs (for/hash (((k v) (in-hash vs))
#:when (not (equal? (@ v checksum)
empty-checksum)))
(values k v))))
(maybe-splice
(not (hash-empty? vs))
`(tr (th "Versions")
(td (table ((class "package-versions"))
(tr (th "Version")
(th "Source")
(th "Checksum"))
,@(for/list
(((version-sym v) (in-hash vs)))
`(tr
(td ,(~a version-sym))
(td (a ((href ,(@ v source_url)))
,(@ v source)))
(td ,(@ v checksum)))))))))
(tr (th "Last checked")
(td ,(utc->string (package-last-checked pkg))))
(tr (th "Last edited")
(td ,(utc->string (package-last-edit pkg))))
(tr (th "Modules")
(td (ul ((class "module-list"))
,@(for/list ((mod (package-modules pkg)))
(match-define (list kind path) mod)
`(li ((class ,kind)) ,path)))))
)))))
`(table ((class "package-details"))
(tr (th "Authors")
(td (div ((class "authors-detail"))
,(authors-list #:gravatars? #t (package-authors pkg)))))
(tr (th "Documentation")
(td ,(doc-links (package-docs pkg))))
(tr (th "Tags")
(td ,(tag-links (package-tags pkg))))
(tr (th "Last updated")
(td ,(utc->string (package-last-updated pkg))))
(tr (th "Ring")
(td ,(~a (or (package-ring pkg) "N/A"))))
(tr (th "Conflicts")
(td ,(package-links (package-conflicts pkg))))
(tr (th "Dependencies")
(td ,(package-links
(dependencies->package-names
(package-dependencies pkg)))))
(tr (th "Most recent build results")
(td (ul ((class "build-results"))
,@(maybe-splice
(package-build-success-log pkg)
`(li "Compiled successfully: "
,(buildhost-link (package-build-success-log pkg)
"transcript")))
,@(maybe-splice
(package-build-failure-log pkg)
`(li "Compiled unsuccessfully: "
,(buildhost-link (package-build-failure-log pkg)
"transcript")))
,@(maybe-splice
(package-build-conflicts-log pkg)
`(li "Conflicts: "
,(buildhost-link (package-build-conflicts-log pkg)
"details")))
,@(maybe-splice
(package-build-dep-failure-log pkg)
`(li "Dependency problems: "
,(buildhost-link (package-build-dep-failure-log pkg)
"details")))
)))
,@(let* ((vs (package-versions pkg))
(empty-checksum "9f098dddde7f217879070816090c1e8e74d49432")
(vs (for/hash (((k v) (in-hash vs))
#:when (not (equal? (@ v checksum)
empty-checksum)))
(values k v))))
(maybe-splice
(not (hash-empty? vs))
`(tr (th "Versions")
(td (table ((class "package-versions"))
(tr (th "Version")
(th "Source")
(th "Checksum"))
,@(for/list
(((version-sym v) (in-hash vs)))
`(tr
(td ,(~a version-sym))
(td (a ((href ,(@ v source_url)))
,(@ v source)))
(td ,(@ v checksum)))))))))
(tr (th "Last checked")
(td ,(utc->string (package-last-checked pkg))))
(tr (th "Last edited")
(td ,(utc->string (package-last-edit pkg))))
(tr (th "Modules")
(td (ul ((class "module-list"))
,@(for/list ((mod (package-modules pkg)))
(match-define (list kind path) mod)
`(li ((class ,kind)) ,path)))))
)))])))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -1309,23 +1330,33 @@
(define (rerender-all!)
(thread-send (package-change-handler-thread) 'rerender-all!))
(define (internal:rerender-package-not-found!)
(static-render! relative-named-url package-not-found-page #:ignore-response-code? #t)
(log-info "Generating package/.htaccess")
(call-with-output-file
(format "~a/package/.htaccess" static-generated-directory)
(lambda (p)
(fprintf p "ErrorDocument 404 ~a~a\n"
static-urlprefix
(relative-named-url package-not-found-page)))
#:exists 'replace)
(finish-static-update!))
(define (internal:rerender-not-found!)
;; TODO: general-purpose error page instead.
(static-render! #:mime-type "text/html"
relative-named-url not-found-page
#:ignore-response-code? #t)
(log-info "Generating .htaccess")
(static-put-file! "/.htaccess"
(string->bytes/utf-8
(format "ErrorDocument 404 ~a~a\n"
static-urlprefix
(relative-named-url not-found-page)))
"text/plain")
(static-finish-update!))
(define (package-change-handler index-rerender-needed? pending-completions)
(sync/timeout (and index-rerender-needed?
(lambda ()
(static-render! relative-named-url main-page #:filename "/index.html")
(finish-static-update!)
(static-render! #:mime-type "text/html"
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))
(channel-put completion-ch (void)))
(package-change-handler #f '())))
@ -1333,21 +1364,23 @@
(lambda (_)
(match (thread-receive)
['upgrade ;; Happens every time site.rkt is reloaded
(internal:rerender-package-not-found!)
(internal:rerender-not-found!)
(package-change-handler index-rerender-needed?
pending-completions)]
['rerender-all!
(log-info "rerender-all!")
(for ((p (all-package-names)))
(update-external-package-information! p)
(static-render! relative-named-url
(static-render! #:mime-type "text/html"
relative-named-url
package-page
(symbol->string p)))
(package-change-handler #t
pending-completions)]
[(list 'package-changed completion-ch package-name)
(update-external-package-information! package-name)
(static-render! relative-named-url
(static-render! #:mime-type "text/html"
relative-named-url
package-page
(symbol->string package-name))
(package-change-handler

231
src/static.rkt
View File

@ -1,40 +1,76 @@
#lang racket/base
(provide static-generated-directory
rendering-static-page?
(provide rendering-static-page?
static-render!
finish-static-update!
static-put-file!
static-delete-file!
static-finish-update!
extra-files-paths)
(require racket/match)
(require racket/system)
(require racket/path)
(require racket/port)
(require racket/promise)
(require racket/file)
(require web-server/private/servlet)
(require web-server/http/request-structs)
(require web-server/http/response-structs)
(require file/md5)
(require xml/path)
(require net/url)
(require aws/s3)
(require reloadable)
(require "config.rkt")
(require "daemon.rkt")
(require "rpc.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
;; Relevant to static-output-type 'file only
(config-path (or (@ (config) static-generated-directory)
(build-path (var-path) "generated-htdocs"))))
(define static-content-target-directory
;; Relevant to static-output-type 'file only
(let ((p (@ (config) static-content-target-directory)))
(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
(or (@ (config) extra-static-content-directories)
'())))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Static rendering daemon -- Interface
(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]
#:ignore-response-code? [ignore-response-code? #f]
#:mime-type mime-type
named-url handler . named-url-args)
(define request-url (apply named-url handler named-url-args))
(log-info "Rendering static version of ~a~a"
@ -59,40 +95,167 @@
"127.0.0.1")
named-url-args))
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
[(or (<= 200 (response-code response) 299) ;; "OKish" range
ignore-response-code?)
(make-parent-directory* filename)
(call-with-output-file filename
(response-output response)
#:exists 'replace)]
(static-put-file! absolute-path content-bytes mime-type)]
[(= (response-code response) 404) ;; Not found -> delete the file
(when (file-exists? filename)
(delete-file filename))]
(static-delete-file! absolute-path)]
[else
(log-warning "Unexpected response code ~v when static-rendering ~v"
(response-code response)
(cons handler named-url-args))]))
(define (finish-static-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") ".")))
(for/list [(dir extra-static-content-directories)]
(path->string (build-path dir ".")))
(list (path->string (build-path static-content-target-directory ".")))))
(log-info "Executing rsync to replicate static content; argv: ~v" command)
(apply system* command))
(when static-content-update-hook
(system static-content-update-hook)))
(define (static-finish-update!)
(renderer-rpc 'finish-update!))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Static rendering daemon -- Implementation
(define (static-renderer-main)
(match static-output-type
['file (static-renderer-file)]
['aws-s3 (static-renderer-aws-s3 #f)])
(static-renderer-main))
;;---------------------------------------- 'file
(define (static-renderer-file)
(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)
(list* static-generated-directory
(config-path "../static")
extra-static-content-directories))
(list static-generated-directory
(config-path "../static")
(config-path pkg-index-generated-directory)))

2
static/searchbox.js
View File

@ -1,6 +1,6 @@
$(document).ready(function () {
$("#q").focus();
PkgSite.getJSON("search-completions", function (searchCompletions) {
PkgSite.staticJSON("search-completions", function (searchCompletions) {
searchCompletions.sort();
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);
}
function staticJSON(relative_url, k) {
return $.getJSON((IsStaticPage ? PkgSiteStaticBaseUrl : PkgSiteDynamicBaseUrl)
+ '/json/' + relative_url, k);
}
return {
multiTermComplete: multiTermComplete,
preventTabMovingDuringSelection: preventTabMovingDuringSelection,
getJSON: getJSON
dynamicJSON: dynamicJSON,
staticJSON: staticJSON
};
})();
@ -40,13 +46,14 @@ $(document).ready(function () {
$("table.sortable").tablesorter();
if ($("#tags").length) {
PkgSite.getJSON((document.body.className === "package-form")
? "formal-tags"
: "tag-search-completions",
function (completions) {
completions.sort();
PkgSite.multiTermComplete(PkgSite.preventTabMovingDuringSelection($("#tags")),
completions);
});
PkgSite.staticJSON((document.body.className === "package-form")
? "formal-tags"
: "tag-search-completions",
function (completions) {
completions.sort();
PkgSite.multiTermComplete(
PkgSite.preventTabMovingDuringSelection($("#tags")),
completions);
});
}
});