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

.gitignore

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

src/main.rkt

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

src/signals.rkt

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

src/site.rkt

@@ -1,7 +1,8 @@
 #lang racket/base
 
 (provide request-handler
-         on-continuation-expiry)
+         on-continuation-expiry
+         rerender-all!)
 
 (require racket/set)
 (require racket/match)
@@ -20,6 +21,9 @@
 (require "reload.rkt")
 (require "daemon.rkt")
 
+(define static-cached-directory "../static/cached")
+(define static-cached-urlprefix "/cached")
+
 (define nav-index "Package Index")
 (define nav-search "Search")
 
@@ -48,11 +52,14 @@
 
 (define-values (request-handler named-url)
   (dispatch-rules
+   [("index") main-page]
    [("") main-page]
    [("search") search-page]
    [("package" (string-arg)) package-page]
    [("package" (string-arg) "edit") edit-package-page]
    [("create") edit-package-page]
+   [("login") login-page]
+   [("register-or-reset") register-or-reset-page]
    [("logout") logout-page]
    [("json" "search-completions") json-search-completions]
    [("json" "tag-search-completions") json-tag-search-completions]
@@ -65,6 +72,8 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(define static-render (make-parameter #f))
+
 (define-syntax-rule (authentication-wrap #:request request body ...)
   (authentication-wrap* #f request (lambda () body ...)))
 
@@ -82,47 +91,41 @@
                                           #:path "/"
                                           #:expires "Thu, 01 Jan 1970 00:00:00 GMT"))
 
-(define (authentication-wrap* require-login? request body)
+(define-syntax-rule (with-session-cookie cookie-value body ...)
-  (define original-session-cookies
+  (let ((v cookie-value))
+    (parameterize ((bootstrap-cookies
+                    (if v
+                        (list (make-cookie COOKIE v #:path "/" #:secure? #t))
+                        (list clear-session-cookie))))
+      body ...)))
+
+(define (request->session request)
+  (define session-cookies
     (filter (lambda (c) (equal? (client-cookie-name c) COOKIE))
             (request-cookies request)))
-  (define original-session-keys
+  (define session-keys (map client-cookie-value session-cookies))
-    (map client-cookie-value original-session-cookies))
+  ;; (log-info "Session keys from cookie: ~a" session-keys)
-  ;; (log-info "Session keys from cookie: ~a" original-session-keys)
+  (for/or ((k session-keys)) (lookup-session/touch! k)))
-  (let redo ((session-keys original-session-keys))
+
-    (define session (for/or ((k session-keys)) (lookup-session/touch! k)))
+(define (authentication-wrap* require-login? request body)
+  (define session (request->session request))
   ;; (log-info "session: ~a" session)
+  (define requested-url (url->string (request-uri request)))
 
-    ;; If needed in future, we can change this to preserve *all* of
-    ;; the original request by simply calling redo with the new
-    ;; session key, (redo (list new-session-key)).
-    ;;
-    ;; For now, we need to redirect to a clean URL in every case, so
-    ;; just do that.
-    (define (after-login new-session-key)
-      (parameterize ((bootstrap-cookies
-                      (if new-session-key
-                          (list (make-cookie COOKIE new-session-key #:path "/" #:secure? #t))
-                          (list clear-session-cookie))))
-        (with-site-config
-         (bootstrap-redirect (url->string (request-uri request))))))
-
-    (send/suspend/dispatch
-     (lambda (embed-url)
   (if (and require-login? (not session))
-           (after-login (login-page))
+      (login-or-register-flow* requested-url login-form)
       (parameterize ((bootstrap-navbar-extension
                       (cond
                        [(not session)
                         `((a ((id "register-button")
                               (class "btn btn-default navbar-btn navbar-right")
-                                   (href ,(embed-url
+                              (href ,(login-or-register-url requested-url
-                                           (lambda (req) (after-login (register-page))))))
+                                                            (named-url register-or-reset-page))))
                              "Register")
                           (a ((id "sign-in-button")
                               (class "btn btn-success navbar-btn navbar-right")
-                                   (href ,(embed-url
+                              (href ,(login-or-register-url requested-url
-                                           (lambda (req) (after-login (login-page))))))
+                                                            (named-url login-page))))
                              "Sign in"))]
                        [else
                         `((ul ((class "nav navbar-nav navbar-right"))
@@ -144,8 +147,10 @@
                                                                (session-email session))))))
                                              ,(glyphicon 'user) " My packages"))
                                       (li ((class "divider"))
-                                               (li (a ((href ,(embed-url
+                                          (li (a ((href
-                                                               (lambda (req) (after-login #f)))))
+                                                   ,(login-or-register-url
+                                                     requested-url
+                                                     (named-url logout-page))))
                                                  ,(glyphicon 'log-out) " Log out")))))))]))
                      (current-session session)
                      (bootstrap-cookies
@@ -155,7 +160,7 @@
                                              #:path "/"
                                              #:secure? #t))
                           (list))))
-             (with-site-config (body))))))))
+        (with-site-config (body)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -208,7 +213,34 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (login-page [error-message #f])
+(define (login-or-register-url k baseurl)
+  (format "~a?~a"
+          baseurl
+          (alist->form-urlencoded (list (cons 'k k)))))
+
+(define (login-or-register-flow request thunk)
+  (define-form-bindings request ([k (named-url main-page)]))
+  (login-or-register-flow* k thunk))
+
+(define (login-or-register-flow* k thunk)
+  (with-session-cookie (thunk)
+    (with-site-config
+      (bootstrap-redirect k))))
+
+(define (login-page request)
+  (login-or-register-flow request login-form))
+
+(define (register-or-reset-page request)
+  (login-or-register-flow request register-form))
+
+(define (logout-page request)
+  (define session (request->session request))
+  (when session (destroy-session! (session-key session)))
+  (login-or-register-flow request (lambda () #f)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (login-form [error-message #f])
   (with-site-config
    (send/suspend/dispatch
     (lambda (embed-url)
@@ -222,10 +254,10 @@
                             ,(form-group 2 2 (label "password" "Password:")
                                          0 5 (password-input "password"))
                             ,(form-group 4 5
-                                         `(a ((href ,(embed-url (lambda (req) (register-page)))))
+                                         `(a ((href ,(embed-url (lambda (req) (register-form)))))
                                            "Need to reset your password?"))
                             ,(form-group 4 5
-                                         `(a ((href ,(embed-url (lambda (req) (register-page)))))
+                                         `(a ((href ,(embed-url (lambda (req) (register-form)))))
                                            "Register an account"))
                             ,@(maybe-splice
                                error-message
@@ -246,16 +278,16 @@
   (define-form-bindings request (email password))
   (if (or (equal? (string-trim email) "")
           (equal? (string-trim password) ""))
-      (login-page "Please enter your email address and password.")
+      (login-form "Please enter your email address and password.")
       (match (authenticate-with-server! email password "")
         ["wrong-code"
-         (login-page "Something went awry; please try again.")]
+         (login-form "Something went awry; please try again.")]
         [(or "emailed" #f)
          (summarise-code-emailing "Incorrect password, or nonexistent user." email)]
         [else
          (create-session! email password)])))
 
-(define (register-page #:email [email ""]
+(define (register-form #:email [email ""]
                        #:code [code ""]
                        #:error-message [error-message #f])
   (with-site-config
@@ -308,7 +340,7 @@
 (define (apply-account-code request)
   (define-form-bindings request (email code password confirm_password))
   (define (retry msg)
-    (register-page #:email email
+    (register-form #:email email
                    #:code code
                    #:error-message msg))
   (cond
@@ -346,14 +378,24 @@
                             (code ,email) ". Please check your email and then click "
                             "the button to continue:")
                           `(a ((class "btn btn-primary")
-                               (href ,(embed-url (lambda (req) (register-page)))))
+                               (href ,(embed-url (lambda (req) (register-form)))))
                             "Enter your code"))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (package-link package-name)
+(define (main-page-url)
+  (if (current-session)
+      (named-url main-page)
+      (format "~a~a" static-cached-urlprefix (named-url main-page))))
+
+(define (view-package-url package-name)
   (define package-name-str (~a package-name))
-  `(a ((href ,(named-url package-page package-name-str))) ,package-name-str))
+  (if (current-session)
+      (named-url package-page package-name-str)
+      (format "~a~a" static-cached-urlprefix (named-url package-page package-name-str))))
+
+(define (package-link package-name)
+  `(a ((href ,(view-package-url package-name))) ,(~a package-name)))
 
 (define (doc-destruct doc)
   (match doc
@@ -469,6 +511,11 @@
     (define package-name-list (package-search "" '((main-distribution #f))))
     (authentication-wrap
      #:request request
+     (cond
+      [(and (not (current-session)) (not (static-render)))
+       ;; Redirect to static version
+       (bootstrap-redirect (main-page-url))]
+      [else
        (bootstrap-response "Racket Package Index"
                            #:title-element ""
                            #:body-class "main-page"
@@ -494,13 +541,7 @@
                            `(div
                              (p ((class "package-count"))
                                 ,(format "~a packages" (length package-name-list)))
-                           ,(package-summary-table package-name-list))))))
+                             ,(package-summary-table package-name-list)))]))))
-
-(define (logout-page request)
-  (with-site-config
-   (parameterize ((bootstrap-cookies (list clear-session-cookie)))
-     (when (current-session) (destroy-session! (session-key (current-session))))
-     (bootstrap-redirect (named-url main-page)))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -517,11 +558,16 @@
    (define package-name (string->symbol package-name-str))
    (define pkg (package-detail package-name))
    (define default-version (hash-ref (or (@ pkg versions) (hash)) 'default (lambda () #f)))
-   (if (not pkg)
+   (cond
+    [(and (not (current-session)) (not (static-render)))
+     ;; Redirect to static version
+     (bootstrap-redirect (view-package-url package-name))]
+    [(not pkg)
      (bootstrap-response #:code 404
                          #:message #"No such package"
                          "Package not found"
-                           `(div "The package " (code ,package-name-str) " does not exist."))
+                         `(div "The package " (code ,package-name-str) " does not exist."))]
+    [else
      (bootstrap-response (~a package-name)
                          #:title-element ""
                          `(div ((class "jumbotron"))
@@ -666,7 +712,7 @@
                                        ,@(for/list ((mod (or (@ pkg modules) '())))
                                            (match-define (list kind path) mod)
                                            `(li ((class ,kind)) ,path)))))
-                             )))))
+                           ))])))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -678,7 +724,7 @@
    (cond
     [(and pkg (not (member (current-email) (or (@ pkg authors) '()))))
      ;; Not ours. Show it instead.
-     (bootstrap-redirect (named-url package-page package-name-str))]
+     (bootstrap-redirect (view-package-url package-name))]
     [(not pkg)
      ;; Doesn't exist.
      (package-form #f (draft-package ""
@@ -847,7 +893,7 @@
                                                 has-old-name?
                                                 " "
                                                 `(a ((class "btn btn-default")
-                                                     (href ,(named-url package-page old-name)))
+                                                     (href ,(view-package-url old-name)))
                                                   "Cancel changes and return to package page"))))))
                             ))))))
 
@@ -866,7 +912,7 @@
    (define completion-ch (make-channel))
    (delete-package! completion-ch (string->symbol package-name-str))
    (channel-get completion-ch)
-   (bootstrap-redirect (named-url main-page))))
+   (bootstrap-redirect (main-page-url))))
 
 (define ((update-draft draft0) request)
   (define draft (read-draft-form draft0 (request-bindings request)))
@@ -875,7 +921,7 @@
     ["save_changes"
      (if (save-draft! draft)
          (with-site-config
-          (bootstrap-redirect (named-url package-page (~a (draft-package-name draft)))))
+           (bootstrap-redirect (view-package-url (draft-package-name draft))))
          (package-form "Save failed."
                        ;; ^ TODO: This is the worst error message.
                        ;;         Right up there with "parse error".
@@ -1126,18 +1172,46 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (rerender-indexes!)
+(define (static-render! handler . named-url-args)
-  (log-info "Rerendering indexes"))
+  (local-require racket/promise)
+  (local-require racket/file)
+  (local-require web-server/private/servlet)
+  (local-require web-server/http/request-structs)
+  (define request-url (apply named-url handler named-url-args))
+  (log-info "Rendering static version of ~a" request-url)
+  (define response
+    (parameterize ((static-render #t))
+      (call-with-continuation-barrier
+       (lambda ()
+         (call-with-continuation-prompt
+          (lambda ()
+            (apply handler
+                   (request #"GET"
+                            (string->url request-url)
+                            '()
+                            (delay '())
+                            #f
+                            "127.0.0.1"
+                            0
+                            "127.0.0.1")
+                   named-url-args))
+          servlet-prompt)))))
+  (define filename (format "~a~a" static-cached-directory request-url))
+  (make-parent-directory* filename)
+  (call-with-output-file filename
+    (response-output response)
+    #:exists 'replace))
 
-(define (rerender-package! package-name)
+(define (rerender-all!)
-  (log-info "Rerendering package ~a" package-name))
+  (for ((p (all-package-names))) (static-render! package-page (symbol->string p)))
+  (static-render! main-page))
 
 (define (package-change-handler)
   (let loop ((index-rerender-needed? #f)
              (pending-completions '()))
     (sync/timeout (and index-rerender-needed?
                        (lambda ()
-                         (rerender-indexes!)
+                         (static-render! main-page)
                          (for ((completion-ch pending-completions))
                            (channel-put completion-ch (void)))
                          (loop #f '())))
@@ -1145,7 +1219,7 @@
                               (lambda (_)
                                 (match (thread-receive)
                                   [(list completion-ch package-name)
-                                   (rerender-package! package-name)
+                                   (static-render! package-page (symbol->string package-name))
                                    (loop #t (if completion-ch
                                                 (cons completion-ch pending-completions)
                                                 pending-completions))]))))))