From 098b32b0afd79ca33510ab297662b1f8278ecc80 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Wed, 16 Jun 2010 02:01:03 -0400
Subject: [PATCH] Add template files for browsing the installer dirs directly.

---
 collects/meta/web/common/layout.rkt | 13 +++++++++----
 collects/meta/web/config.rkt        | 11 ++++++-----
 collects/meta/web/stubs/dirlist.rkt | 23 +++++++++++++++++++++++
 collects/meta/web/stubs/main.rkt    |  4 ++--
 4 files changed, 40 insertions(+), 11 deletions(-)
 create mode 100644 collects/meta/web/stubs/dirlist.rkt

diff --git a/collects/meta/web/common/layout.rkt b/collects/meta/web/common/layout.rkt
index 7b1c2ee7cd..b18ef268f4 100644
--- a/collects/meta/web/common/layout.rkt
+++ b/collects/meta/web/common/layout.rkt
@@ -53,6 +53,10 @@
 (define-syntax (page stx)
   (syntax-case stx () [(_ . xs) (process-contents 'page #'page* stx #'xs)]))
 (define (page* #:id [id #f] #:dir [dir #f] #:file [file #f]
+               ;; if this is true, return only the html -- don't create
+               ;; a resource -- therefore no file is made, and no links
+               ;; to it can be made (useful only for stub templates)
+               #:html-only [html-only? #f]
                #:title [label (if id
                                 (let* ([id (->string (force id))]
                                        [id (regexp-replace #rx"^.*/" id "")]
@@ -81,10 +85,11 @@
              @(if body-attrs
                 (apply body `(,@body-attrs ,content))
                 (body content))}))
-  (define this (resource (get-path 'plain id file "html" dir)
-                         (file-writer output-xml page)
-                         referrer))
-  this)
+  (define this (and (not html-only?)
+                    (resource (get-path 'plain id file "html" dir)
+                              (file-writer output-xml page)
+                              referrer)))
+  (if html-only? page this))
 
 (provide set-navbar!)
 (define-syntax-rule (set-navbar! pages help)
diff --git a/collects/meta/web/config.rkt b/collects/meta/web/config.rkt
index 20e5fb9dc3..8abdd7c8d5 100644
--- a/collects/meta/web/config.rkt
+++ b/collects/meta/web/config.rkt
@@ -7,11 +7,12 @@
     ("lists"         "http://lists.racket-lang.org/")
     ;; stubs usually use absolute paths for resources, since they're
     ;; templates that often get used in sub-dir pages too
-    ("stubs/planet"  "http://planet.racket-lang.org/" abs)
-    ("stubs/pre"     "http://pre.racket-lang.org/"    abs)
-    ("stubs/git"     "http://git.racket-lang.org/"    abs)
-    ("stubs/blog"    "http://blog.racket-lang.org/"   abs)
-    ("stubs/mailman" "http://lists.racket-lang.org/"  abs)))
+    ("stubs/planet"  "http://planet.racket-lang.org/"   abs)
+    ("stubs/pre"     "http://pre.racket-lang.org/"      abs)
+    ("stubs/git"     "http://git.racket-lang.org/"      abs)
+    ("stubs/blog"    "http://blog.racket-lang.org/"     abs)
+    ("stubs/mailman" "http://lists.racket-lang.org/"    abs)
+    ("stubs/dirlist" "http://download.racket-lang.org/" abs)))
 
 (provide distributions)
 (define distributions
diff --git a/collects/meta/web/stubs/dirlist.rkt b/collects/meta/web/stubs/dirlist.rkt
new file mode 100644
index 0000000000..d1d112f15a
--- /dev/null
+++ b/collects/meta/web/stubs/dirlist.rkt
@@ -0,0 +1,23 @@
+#lang at-exp s-exp "../common.rkt"
+
+;; This stub is to generate fancy directory listings with the Racket style
+
+(define-context "stubs/dirlist")
+
+(require racket/port)
+(define (xml->string content)
+  (regexp-replace* #rx"&nbsp;"
+                   (with-output-to-string (lambda () (output-xml content)))
+                   "\\&#160;"))
+
+;; (define (racket-navbar)  (xml->string (www:the-resources 'navbar #f)))
+;; (define (racket-favicon) (xml->string (www:the-resources 'favicon-headers)))
+
+(define header+footer
+  (delay (regexp-split #rx"{{{BODY}}}"
+                       (xml->string @page[#:id 'browse-downloads
+                                          #:html-only #t
+                                          "{{{BODY}}}"]))))
+
+(define header @plain[#:file "header.html" (car  (force header+footer))])
+(define footer @plain[#:file "footer.html" (cadr (force header+footer))])
diff --git a/collects/meta/web/stubs/main.rkt b/collects/meta/web/stubs/main.rkt
index ca797470d8..a4606af872 100644
--- a/collects/meta/web/stubs/main.rkt
+++ b/collects/meta/web/stubs/main.rkt
@@ -2,6 +2,6 @@
 
 (provide planet)
 
-(require "planet.rkt" "blog.rkt"
+(require "planet.rkt" "blog.rkt"      ; these need to be copied to the service
          "pre.rkt" "git.rkt"
-         "mailman.rkt")
+         "mailman.rkt" "dirlist.rkt") ; these are used on the server directly