inspect responder

contrib/httpd/cont-responder.factor

@@ -296,14 +296,17 @@ SYMBOL: root-continuation
   #! by returning a quotation that will pass the original 
   #! quotation to the callback continuation.
   [ , callback-cc get , \ continue-with , ] [ ] make ;
-  
+
+: quot-url ( quot -- url )
+  callback-quot expirable register-continuation id>url ;
+
 : quot-href ( text quot -- )
   #! Write to standard output an HTML HREF where the href,
   #! when referenced, will call the quotation and then return
   #! back to the most recent 'show' call (via the callback-cc).
   #! The text of the link will be the 'text' argument on the 
   #! stack.
-  <a callback-quot expirable register-continuation id>url =href a> write </a> ;
+  <a quot-url =href a> write </a> ;
 
 : init-session-namespace ( -- )
   #! Setup the initial session namespace. Currently this only
@@ -376,13 +379,3 @@ SYMBOL: root-continuation
 : button ( label -- )
   #! Output an HTML submit button with the given label.
   <input "submit" =type =value input/> ;
-
-: with-simple-html-output ( quot -- )
-  #! Run the quotation inside an HTML stream wrapped
-  #! around stdio.
-  <pre> 
-    stdio get <html-stream> [
-      call
-    ] with-stream
-  </pre> ;
-

contrib/httpd/default-responders.factor

@@ -20,6 +20,9 @@ global [
         "help" "responder" set
         [ help-responder ] "get" set
     ] make-responder
+
+    ! Global variables
+    "inspector" [ inspect-responder ] install-cont-responder
     
     ! Servers Factor word definitions from the image.
     "browser" [ browser-responder ] install-cont-responder

contrib/httpd/html.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: html
-USING: generic hashtables help http io kernel lists math
-namespaces sequences strings styles words xml ;
+USING: generic hashtables help http inspector io
+kernel lists math namespaces sequences strings styles words xml ;
 
 : hex-color, ( triplet -- )
     3 swap head
@@ -55,16 +55,25 @@ namespaces sequences strings styles words xml ;
         <span =style span> call </span>
     ] if ;
 
+: border-css, ( border -- )
+    "border: 1px solid #" % hex-color, "; " % ;
+
+: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+
+: pre-css, ( -- ) "white-space: pre; " % ;
+
 : div-css-style ( style -- str )
     [
         H{
-            { page-color   [ bg-css,        ] }
-            ! { border-color [ font-css,      ] }
+            { page-color [ bg-css, ] }
+            { border-color [ border-css, ] }
+            { border-width [ padding-css, ] }
+            { wrap-margin [ [ pre-css, ] unless ] }
         } hash-apply
     ] "" make ;
 
 : div-tag ( style quot -- )
-    over div-css-style dup empty? [
+    swap div-css-style dup empty? [
         drop call
     ] [
         <div =style div> call </div>
@@ -92,13 +101,12 @@ namespaces sequences strings styles words xml ;
 
 GENERIC: browser-link-href ( presented -- href )
 
+M: object browser-link-href drop f ;
+
 M: word browser-link-href
-    dup word-name swap word-vocabulary [
-        "/responder/browser/?vocab=" %
-        url-encode %
-        "&word=" %
-        url-encode %
-    ] "" make ;
+    "/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? [
@@ -107,10 +115,7 @@ M: link browser-link-href
         [ "/responder/help/" % url-encode % ] "" make
     ] if ;
 
-M: object browser-link-href
-    drop f ;
-
-: browser-link-tag ( style quot -- style )
+: object-link-tag ( style quot -- )
     presented pick hash browser-link-href
     [ <a =href a> call </a> ] [ call ] if* ;
 
@@ -140,23 +145,16 @@ M: html-stream stream-format ( str style stream -- )
                     do-escaping stdio get delegate-write
                 ] span-tag
             ] file-link-tag
-        ] browser-link-tag
+        ] object-link-tag
     ] with-stream* ;
 
-: pre-tag ( style quot -- )
-    wrap-margin rot hash [
-        call
-    ] [
-        <pre> call </pre>
-    ] if ;
-
 M: html-stream with-nested-stream ( quot style stream -- )
     [
         [
             [
                 stdio get <nested-stream> swap with-stream*
-            ] pre-tag
-        ] div-tag
+            ] div-tag
+        ] object-link-tag
     ] with-stream* ;
 
 M: html-stream stream-terpri [ <br/> ] with-stream* ;
@@ -166,10 +164,10 @@ M: html-stream stream-terpri [ <br/> ] with-stream* ;
 
 : default-css ( -- )
   <style>
-    "A:link { text-decoration:none}" print
-    "A:visited { text-decoration:none}" print
-    "A:active { text-decoration:none}" print
-    "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: -1px }" print
+    "A:link { text-decoration: none; color: black; }" print
+    "A:visited { text-decoration: none; color: black; }" print
+    "A:active { text-decoration: none; color: black; }" print
+    "A:hover, A:hover { text-decoration: none; color: black; }" print
   </style> ;
 
 : html-document ( title quot -- )

contrib/httpd/http-common.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2005 Slava Pestov
 IN: http
-USING: errors kernel lists math namespaces parser sequences
-io strings ;
+USING: errors hashtables io kernel lists math namespaces parser
+sequences strings ;
 
 : header-line ( line -- )
     ": " split1 dup [ swap set ] [ 2drop ] if ;
@@ -62,3 +62,12 @@ io strings ;
 
 : url-decode ( str -- str )
     [ 0 swap url-decode-iter ] "" make ;
+
+: build-url ( path query-params -- str )
+    [
+        swap % dup hash-empty? [
+            "?" %
+            hash>alist
+            [ [ url-encode ] map "=" join ] map "&" join %
+        ] unless drop
+    ] "" make ;

contrib/httpd/inspect-responder.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: inspect-responder
+USING: cont-responder generic hashtables help html inspector
+kernel lists namespaces sequences ;
+
+! Mini object inspector
+: http-inspect ( obj -- )
+    "Inspecting " over summary append
+    [ describe ] simple-html-document ;
+
+M: general-t browser-link-href
+    "/responder/inspector/" swap
+    [ [ http-inspect ] show-final ] curry quot-url
+    append ;
+
+: inspect-responder ( url -- ) drop global http-inspect ;

contrib/httpd/load.factor

@@ -2,16 +2,17 @@ IN: scratchpad
 USING: words kernel parser sequences io compiler ;
 
 { 
+    "mime"
     "xml"
     "http-common"
-    "mime"
     "html-tags"
     "html"
     "responder"
     "httpd"
+    "cont-responder"
     "file-responder"
     "help-responder"
-    "cont-responder"
+    "inspect-responder"
     "browser-responder"
     "default-responders"
     "http-client"

contrib/httpd/test/html.factor

@@ -1,5 +1,11 @@
 IN: temporary
-USING: html io kernel namespaces styles test xml ;
+USING: html http io kernel namespaces styles test xml ;
+
+[
+    "/responder/foo/?z=%20"
+] [
+    "/responder/foo" H{ { "z" " " } } build-url
+]
 
 [
     "<html>&'sgml'"
@@ -45,19 +51,3 @@ USING: html io kernel namespaces styles test xml ;
         html-format
     ] string-out
 ] unit-test
-
-[
-    "<html><head><title>Foo</title></head><body><h1>Foo</h1></body></html>"
-] [
-    [
-        "Foo" [ ] html-document
-    ] string-out
-] unit-test
-
-[
-    "<html><head><title>Foo</title></head><body><h1>Foo</h1><pre>Hi</pre></body></html>"
-] [
-    [
-        "Foo" [ "Hi" write ] simple-html-document
-    ] string-out
-] unit-test