HTTPD tools moved to contrib/furnace and updated to use the new framework

contrib/furnace-pastebin/pastebin.factor

@@ -64,8 +64,6 @@ C: pastebin ( -- pastebin )
 
 \ submit-paste [ paste-list ] define-redirect
 
-"pastebin" "paste-list" "contrib/furnace-pastebin" web-app
-
 : annotate-paste ( paste# summary author contents -- )
     <annotation> swap get-paste paste-annotations push ;
 
@@ -77,3 +75,5 @@ C: pastebin ( -- pastebin )
 } define-action
 
 \ annotate-paste [ "n" show-paste ] define-redirect
+
+"pastebin" "paste-list" "contrib/furnace-pastebin" web-app

contrib/furnace/load.factor

@@ -3,6 +3,8 @@ REQUIRES: contrib/httpd ;
 PROVIDE: contrib/furnace {
     "validator.factor"
     "responder.factor"
+    "tools/help.factor"
+    "tools/browser.factor"
 } {
     "test/validator.factor"
     "test/responder.factor"

contrib/furnace/responder.factor

@@ -36,7 +36,9 @@ PREDICATE: word action "action" word-prop ;
 
 : action-link ( query action -- url )
     [
-        "/responder/" % "responder" get % "/" %
+        "/responder/" %
+        dup word-vocabulary "furnace:" ?head drop %
+        "/" %
         word-name %
     ] "" make swap build-url ;
 

contrib/furnace/tools/browser.factor

@@ -1,20 +1,23 @@
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004 Chris Double
+! Copyright (C) 2004, 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-IN: browser-responder
+IN: furnace:browser
 USING: definitions hashtables help html httpd io kernel memory
-namespaces prettyprint sequences words xml ;
+namespaces prettyprint sequences words xml furnace arrays ;
 
 : option ( current text -- )
     #! Output the HTML option tag for the given text. If
     #! it is equal to the current string, make the option selected.
-    <option tuck = [ "yes" =selected ] when option>
+    <option tuck = [ "selected" =selected ] when option>
-        chars>entities write
+        write
     </option> ;
 
 : options ( current seq -- ) [ option ] each-with ;
 
 : list ( current seq name -- )
-    <select =name "width: 200px;" =style "20" =size "document.forms.main.submit()" =onchange select>
+    <select =name "width: 200px;" =style "20" =size
+        "JavaScript:document.getElementById('main').submit();" =onchange
+    select>
         options
     </select> ;
 
@@ -24,18 +27,17 @@ namespaces prettyprint sequences words xml ;
 : current-word ( -- word )
     "word" query-param "vocab" query-param lookup ;
 
-: vocab-list ( -- )
+: vocab-list ( vocab -- ) vocabs "vocab" list ;
-    current-vocab vocabs "vocab" list ;
 
-: word-list ( -- )
+: word-list ( word vocab -- )
-    current-word [ word-name ] [ f ] if*
+    [ lookup [ word-name ] [ f ] if* ] keep
-    current-vocab vocab hash-keys natural-sort "word" list ;
+    vocab hash-keys natural-sort "word" list ;
 
 : word-source ( -- )
     #! Write the source for the given word from the vocab as HTML.
-    current-word [ [ see-help ] with-html-stream ] when* ;
+    current-word [ see-help ] when* ;
 
-: browser-body ( -- )
+: browser-body ( word vocab -- )
     #! Write out the HTML for the body of the main browser page.
     <table "100%" =width table> 
         <tr>
@@ -45,7 +47,7 @@ namespaces prettyprint sequences words xml ;
         </tr>
         <tr>    
             <td "top" =valign "width: 200px;" =style td>
-                vocab-list
+                dup vocab-list
             </td> 
             <td "top" =valign "width: 200px;" =style td>
                 word-list
@@ -54,14 +56,27 @@ namespaces prettyprint sequences words xml ;
         </tr>
     </table> ;
 
-: browser-title ( -- str )
+: browser-title ( word vocab -- str )
-    current-word
+    2dup lookup dup
-    [ summary ] [ "IN: " current-vocab append ] if* ;
+    [ 2nip summary ] [ drop nip "IN: " swap append ] if ;
 
-: browser-responder ( -- )
+: browse ( word vocab -- )
     #! Display a Smalltalk like browser for exploring words.
-    serving-html browser-title [
+    2dup browser-title [
-        <form "main" =name "" =action "get" =method form>
+        [
+            <form "main" =id "browse" =action "get" =method form>
                 browser-body
             </form>
+        ] with-html-stream
     ] html-document ;
+
+\ browse {
+    { "word" }
+    { "vocab" "kernel" v-default }
+} define-action
+
+"browser" "browse" "contrib/furnace" web-app
+
+M: word browser-link-href
+    dup word-name swap word-vocabulary \ browse
+    3array >quotation quot-link ;

contrib/furnace/tools/help.factor

@@ -0,0 +1,26 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: furnace:help
+USING: furnace help html kernel sequences words strings ;
+
+: string>topic ( string -- topic )
+    " " split dup length 1 = [ first ] when ;
+
+: show-help ( topic -- )
+    dup article-title [
+        [ help ] with-html-stream
+    ] html-document ;
+
+\ show-help {
+    { "topic" "handbook" v-default string>topic }
+} define-action
+
+"help" "show-help" "contrib/furnace" web-app
+
+M: link browser-link-href
+    link-name [ \ f ] unless* dup word? [
+        browser-link-href
+    ] [
+        dup [ string? ] all? [ " " join ] when
+        [ show-help ] curry quot-link
+    ] if ;

contrib/httpd/darcs-responder.factor

@@ -1,56 +0,0 @@
-USING: httpd io kernel namespaces sequences xml ;
-
-SYMBOL: darcs-directory
-
-"/var/www/factorcode.org/repos/" darcs-directory set
-
-: darcs-changelog
-    darcs-directory get cd
-    "darcs changes --xml" "r" <process-stream> contents xml ;
-
-: rss-item ( { title date author } -- )
-    "item" [ ] [
-        { "title" "pubDate" "author" } [ [ ] text-tag ] 2each
-    ] tag ;
-
-: ?tag-name ( tag -- name/f )
-    dup tag? [ tag-name ] [ drop f ] if ;
-
-: children-named ( tag name -- seq )
-    swap tag-children [ ?tag-name = ] subset-with ;
-
-: tag-child ( tag name -- tag )
-    children-named first ;
-
-: patch>rss-item ( tag -- { title link author date } )
-    [
-        dup "name" tag-child tag-children %
-        tag-props [ "local_date" get , "author" get , ] bind
-    ] { } make ;
-
-SYMBOL: rss-feed-title
-SYMBOL: rss-feed-link
-SYMBOL: rss-feed-description
-
-"Factor DARCS repository" rss-feed-title set
-"http://factorcode.org/repos/" rss-feed-link set
-"Recent patches applied to the Factor DARCS repository" rss-feed-description set
-
-: rss-metadata ( -- )
-    { rss-feed-title rss-feed-link rss-feed-description }
-    { "title" "link" "description" }
-    [ >r get r> [ ] text-tag ] 2each ;
-
-: rss-feed ( items -- string )
-    [
-        "rss" [ "2.0" "version" set ] [
-            "channel" [ ] [ rss-metadata [ rss-item ] each ] tag
-        ] tag
-    ] make-xml xml>string ;
-
-: changelog>rss-feed ( xml -- string )
-    "patch" children-named [ patch>rss-item ] map rss-feed ;
-
-: darcs-rss-feed darcs-changelog changelog>rss-feed print ;
-
-"darcs" [ darcs-rss-feed ] add-simple-responder

contrib/httpd/default-responders.factor

@@ -1,9 +1,7 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: httpd
-USING: browser-responder callback-responder file-responder
+USING: callback-responder file-responder io kernel namespaces ;
-help-responder inspect-responder io kernel namespaces
-prettyprint ;
 
 #! Remove all existing responders, and create a blank
 #! responder table.
@@ -13,9 +11,6 @@ global [
     ! 404 error message pages are served by this guy
     "404" [ no-such-responder ] add-simple-responder
     
-    ! Online help browsing
-    "help" [ help-responder ] add-simple-responder
-    
     ! Used by other responders
     "callback" [ callback-responder ] add-simple-responder
 
@@ -27,12 +22,6 @@ global [
         ] with-scope
     ] add-simple-responder
 
-    ! Global variables
-    "inspector" [ inspect-responder ] add-simple-responder
-    
-    ! Servers Factor word definitions from the image.
-    "browser" [ browser-responder ] 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.

contrib/httpd/help-responder.factor

@@ -1,13 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: help-responder
-USING: hashtables help html httpd io kernel namespaces sequences ;
-
-: help-topic
-    "topic" query-param dup empty? [ drop "handbook" ] when ;
-
-: help-responder ( -- )
-    serving-html
-    help-topic dup article-title [
-        [ help ] with-html-stream
-    ] html-document ;

contrib/httpd/html-tags.factor

@@ -128,7 +128,7 @@ SYMBOL: html
 
 : define-attribute-word ( name -- )
     dup "=" swap append swap
-    [ , [ write-attr ] % ] [ ] make html-word drop ;
+    [ write-attr ] curry html-word drop ;
 
 ! Define some closed HTML tags
 [

contrib/httpd/html.factor

@@ -88,18 +88,6 @@ GENERIC: browser-link-href ( presented -- href )
 
 M: object browser-link-href drop f ;
 
-M: word browser-link-href
-    "/responder/browser/" swap [
-        dup word-vocabulary "vocab" set word-name "word" set
-    ] make-hash build-url ;
-
-M: link browser-link-href
-    link-name [ \ f ] unless* dup word? [
-        browser-link-href
-    ] [
-        "/responder/help/" swap "topic" associate build-url
-    ] if ;
-
 : resolve-file-link ( path -- link )
     #! The file responder needs relative links not absolute
     #! links.
@@ -201,10 +189,10 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
 
 : default-css ( -- )
   <style "text/css" =type style>
-    "A:link { text-decoration: none; color: black; }" print
+    "a:link { text-decoration: none; color: black; }" print
-    "A:visited { text-decoration: none; color: black; }" print
+    "a:visited { text-decoration: none; color: black; }" print
-    "A:active { text-decoration: none; color: black; }" print
+    "a:active { text-decoration: none; color: black; }" print
-    "A:hover, A:hover { text-decoration: underline; color: black; }" print
+    "a:hover, A:hover { text-decoration: underline; color: black; }" print
   </style> ;
 
 : xhtml-preamble

contrib/httpd/inspect-responder.factor

@@ -1,15 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: inspect-responder
-USING: callback-responder generic hashtables help html httpd
-tools kernel namespaces prettyprint sequences ;
-
-! Mini object inspector
-: http-inspect ( obj -- )
-    dup summary [ describe ] simple-html-document ;
-
-M: general-t browser-link-href
-    [ http-inspect ] curry t register-html-callback ;
-
-: inspect-responder ( url -- )
-    serving-html global http-inspect ;

contrib/httpd/load.factor

@@ -13,9 +13,6 @@ PROVIDE: contrib/httpd {
     "prototype-js.factor"
     "html.factor"
     "file-responder.factor"
-    "help-responder.factor"
-    "inspect-responder.factor"
-    "browser-responder.factor"
     "default-responders.factor"
 } {
     "test/html.factor"