From cf559766b7b2737e9c14cf2aec67db5395cfd6da Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Wed, 30 Sep 2015 01:44:32 -0400 Subject: [PATCH] AWS S3 upload support. --- README.md | 23 ++- configs/tonyg.rkt | 11 +- src/site.rkt | 477 +++++++++++++++++++++++--------------------- src/static.rkt | 231 +++++++++++++++++---- static/searchbox.js | 2 +- static/site.js | 27 ++- 6 files changed, 494 insertions(+), 277 deletions(-) diff --git a/README.md b/README.md index 6a2dbab..7b3c82b 100644 --- a/README.md +++ b/README.md @@ -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: diff --git a/configs/tonyg.rkt b/configs/tonyg.rkt index bf25506..a8ddaa4 100644 --- a/configs/tonyg.rkt +++ b/configs/tonyg.rkt @@ -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") )) diff --git a/src/site.rkt b/src/site.rkt index 3e296b7..06216a0 100644 --- a/src/site.rkt +++ b/src/site.rkt @@ -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 diff --git a/src/static.rkt b/src/static.rkt index 6379e81..c5c2024 100644 --- a/src/static.rkt +++ b/src/static.rkt @@ -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))) diff --git a/static/searchbox.js b/static/searchbox.js index 68ac345..e6e018b 100644 --- a/static/searchbox.js +++ b/static/searchbox.js @@ -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); }); diff --git a/static/site.js b/static/site.js index 574a691..fde8fe5 100644 --- a/static/site.js +++ b/static/site.js @@ -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); + }); } });