Source responder fixes

extra/webapps/file/file.factor

@@ -35,8 +35,9 @@ IN: webapps.file
 SYMBOL: serve-file-hook
 
 [
+    dupd
     file-response
-    stdio get stream-copy
+    <file-reader> stdio get stream-copy
 ] serve-file-hook set-global
 
 : serve-static ( filename mime-type -- )
@@ -46,7 +47,6 @@ SYMBOL: serve-file-hook
         "method" get "head" = [
             file-response
         ] [
-            >r dup <file-reader> swap r>
             serve-file-hook get call
         ] if 
     ] if ;
@@ -118,14 +118,6 @@ SYMBOL: page
     ] if ;
 
 global [
-    ! Serve up our own source code
-    "resources" [
-        [
-            "" resource-path "doc-root" set
-            file-responder
-        ] with-scope
-    ] add-simple-responder
-    
     ! Serves files from a directory stored in the "doc-root"
     ! variable. You can set the variable in the global
     ! namespace, or inside the responder.

extra/webapps/source/source.factor

@@ -1,20 +1,33 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files namespaces webapps.file http.server.responders
-xmode.code2html kernel html ;
+xmode.code2html kernel html sequences ;
 IN: webapps.source
 
+! This responder is a potential security problem. Make sure you
+! don't have sensitive files stored under vm/, core/, extra/
+! or misc/.
+
+: check-source-path ( path -- ? )
+    { "vm/" "core/" "extra/" "misc/" }
+    [ head? ] curry* contains? ;
+
+: source-responder ( path mime-type -- )
+    drop
+    serving-html
+    [ dup <file-reader> htmlize-stream ] with-html-stream ;
+
 global [
     ! Serve up our own source code
     "source" [
-        [
-            "" resource-path "doc-root" set
+        "argument" get check-source-path [
             [
-                drop
-                serving-html
-                [ swap htmlize-stream ] with-html-stream
-            ] serve-file-hook set
-            file-responder
-        ] with-scope
+                "" resource-path "doc-root" set
+                [ source-responder ] serve-file-hook set
+                file-responder
+            ] with-scope
+        ] [
+            "403 forbidden" httpd-error
+        ] if
     ] add-simple-responder
 ] bind