From 357bf31220c860ec6716a58393aad7210810c45a Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Fri, 25 Sep 2015 16:57:29 -0400
Subject: [PATCH] Static 404 page for packages

---
 src/site.rkt   | 43 +++++++++++++++++++++++++++++++++----------
 src/static.rkt |  4 +++-
 2 files changed, 36 insertions(+), 11 deletions(-)

diff --git a/src/site.rkt b/src/site.rkt
index bfeecde..15ffa69 100644
--- a/src/site.rkt
+++ b/src/site.rkt
@@ -75,6 +75,7 @@
    [("search") search-page]
    [("package" (string-arg)) package-page]
    [("package" (string-arg) "edit") edit-package-page]
+   [("package-not-found") package-not-found-page]
    [("create") edit-package-page]
    [("login") login-page]
    [("register-or-reset") register-or-reset-page]
@@ -644,17 +645,26 @@
                    #f]))
               deps))
 
-(define (package-page request package-name-str)
+(define (package-not-found-page request [package-name-str #f])
   (authentication-wrap
    #:request request
-   (define package-name (string->symbol package-name-str))
-   (define pkg (package-detail package-name))
-   (define default-version (package-default-version pkg))
-   (if (not pkg)
-       (bootstrap-response #:code 404
-                           #:message #"No such package"
-                           "Package not found"
-                           `(div "The package " (code ,package-name-str) " does not exist."))
+   (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)))
+                                   "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"))
@@ -1291,6 +1301,18 @@
 (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 (package-change-handler index-rerender-needed? pending-completions)
   (sync/timeout (and index-rerender-needed?
                      (lambda ()
@@ -1302,7 +1324,8 @@
                 (handle-evt (thread-receive-evt)
                             (lambda (_)
                               (match (thread-receive)
-                                ['upgrade
+                                ['upgrade ;; Happens every time site.rkt is reloaded
+                                 (internal:rerender-package-not-found!)
                                  (package-change-handler index-rerender-needed?
                                                          pending-completions)]
                                 ['rerender-all!
diff --git a/src/static.rkt b/src/static.rkt
index 63dd006..6379e81 100644
--- a/src/static.rkt
+++ b/src/static.rkt
@@ -34,6 +34,7 @@
 (define rendering-static-page? (make-parameter #f))
 
 (define (static-render! #:filename [base-filename #f]
+                        #:ignore-response-code? [ignore-response-code? #f]
                         named-url handler . named-url-args)
   (define request-url (apply named-url handler named-url-args))
   (log-info "Rendering static version of ~a~a"
@@ -60,7 +61,8 @@
           servlet-prompt)))))
   (define filename (format "~a~a" static-generated-directory (or base-filename request-url)))
   (cond
-   [(<= 200 (response-code response) 299) ;; "OKish" range
+   [(or (<= 200 (response-code response) 299) ;; "OKish" range
+        ignore-response-code?)
     (make-parent-directory* filename)
     (call-with-output-file filename
       (response-output response)