steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fixing httpd

db4
Slava Pestov 2008-01-11 00:48:04 -05:00
parent 5b3d0c0816
commit eb2a6a7d22
10 changed files with 78 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
extra/crypto/common/common-docs.factor
View File

@ -1,5 +1,6 @@
USING: help.markup help.syntax kernel math sequences quotations USING: help.markup help.syntax kernel math sequences quotations
crypto.common math.private ; math.private ;
IN: crypto.common
HELP: >32-bit HELP: >32-bit
{ $values { "x" "an integer" } { "y" "an integer" } } { $values { "x" "an integer" } { "y" "an integer" } }

15
extra/furnace/furnace.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2006 Slava Pestov, Doug Coleman ! Copyright (C) 2006, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs calendar debugger furnace.sessions furnace.validator USING: arrays assocs calendar debugger furnace.sessions
hashtables heaps html.elements http http.server.responders furnace.validator hashtables heaps html.elements http
http.server.templating io.files kernel math namespaces http.server.responders http.server.templating io.files kernel
quotations sequences splitting words strings vectors math namespaces quotations sequences splitting words strings
webapps.callback ; vectors webapps.callback continuations tuples classes vocabs
USING: continuations io prettyprint ; html io ;
IN: furnace IN: furnace
: code>quotation ( word/quot -- quot ) : code>quotation ( word/quot -- quot )
@ -174,7 +174,6 @@ PREDICATE: word action "action" word-prop ;
[ service-post ] "post" set [ service-post ] "post" set
] make-responder ; ] make-responder ;
USING: classes html tuples vocabs ;
: explode-tuple ( tuple -- ) : explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ; [ set ] 2each ;

2
extra/help/markup/markup.factor
View File

@ -44,7 +44,7 @@ M: f print-element drop ;
: with-default-style ( quot -- ) : with-default-style ( quot -- )
default-style get [ default-style get [
last-element off last-element off
H{ } swap with-nesting default-style get swap with-nesting
] with-style ; inline ] with-style ; inline
: print-content ( element -- ) : print-content ( element -- )

8
extra/html/elements/elements-tests.factor Normal file
View File

@ -0,0 +1,8 @@
IN: temporary
USING: tools.test html html.elements io.streams.string ;
: make-html-string
[ with-html-stream ] string-out ;
[ "<a href='h&amp;o'>" ]
[ [ <a "h&o" =href a> ] make-html-string ] unit-test

89
extra/html/elements/elements.factor
View File

@ -4,17 +4,17 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: io kernel namespaces prettyprint quotations USING: io kernel namespaces prettyprint quotations
sequences strings words xml.writer ; sequences strings words xml.writer compiler.units effects ;
IN: html.elements IN: html.elements
! These words are used to provide a means of writing ! These words are used to provide a means of writing
! formatted HTML to standard output with a familiar 'html' look ! formatted HTML to standard output with a familiar 'html' look
! and feel in the code. ! and feel in the code.
! !
! HTML tags can be used in a number of different ways. The highest ! HTML tags can be used in a number of different ways. The highest
! level involves a similar syntax to HTML: ! level involves a similar syntax to HTML:
! !
! <p> "someoutput" write </p> ! <p> "someoutput" write </p>
! !
! <p> will output the opening tag and </p> will output the closing ! <p> will output the opening tag and </p> will output the closing
@ -28,7 +28,7 @@ IN: html.elements
! in that namespace. Before the attribute word should come the ! in that namespace. Before the attribute word should come the
! value of that attribute. ! value of that attribute.
! The finishing word will print out the operning tag including ! The finishing word will print out the operning tag including
! attributes. ! attributes.
! Any writes after this will appear after the opening tag. ! Any writes after this will appear after the opening tag.
! !
! Values for attributes can be used directly without any stack ! Values for attributes can be used directly without any stack
@ -57,54 +57,59 @@ SYMBOL: html
: print-html ( str -- ) : print-html ( str -- )
write-html "\n" write-html ; write-html "\n" write-html ;
: html-word ( name def -- ) : html-word ( name def effect -- )
#! Define 'word creating' word to allow #! Define 'word creating' word to allow
#! dynamically creating words. #! dynamically creating words.
>r elements-vocab create r> define-compound ; >r >r elements-vocab create r> r> define-declared ;
: <foo> "<" swap ">" 3append ; : <foo> "<" swap ">" 3append ;
: empty-effect T{ effect f 0 0 } ;
: def-for-html-word-<foo> ( name -- ) : def-for-html-word-<foo> ( name -- )
#! Return the name and code for the <foo> patterned #! Return the name and code for the <foo> patterned
#! word. #! word.
dup <foo> swap [ <foo> write-html ] curry html-word ; dup <foo> swap [ <foo> write-html ] curry
empty-effect html-word ;
: <foo "<" swap append ; : <foo "<" swap append ;
: def-for-html-word-<foo ( name -- ) : def-for-html-word-<foo ( name -- )
#! Return the name and code for the <foo patterned #! Return the name and code for the <foo patterned
#! word. #! word.
<foo dup [ write-html ] curry html-word ; <foo dup [ write-html ] curry
empty-effect html-word ;
: foo> ">" append ; : foo> ">" append ;
: def-for-html-word-foo> ( name -- ) : def-for-html-word-foo> ( name -- )
#! Return the name and code for the foo> patterned #! Return the name and code for the foo> patterned
#! word. #! word.
foo> [ ">" write-html ] html-word ; foo> [ ">" write-html ] empty-effect html-word ;
: </foo> [ "</" % % ">" % ] "" make ; : </foo> [ "</" % % ">" % ] "" make ;
: def-for-html-word-</foo> ( name -- ) : def-for-html-word-</foo> ( name -- )
#! Return the name and code for the </foo> patterned #! Return the name and code for the </foo> patterned
#! word. #! word.
</foo> dup [ write-html ] curry html-word ; </foo> dup [ write-html ] curry empty-effect html-word ;
: <foo/> [ "<" % % "/>" % ] "" make ; : <foo/> [ "<" % % "/>" % ] "" make ;
: def-for-html-word-<foo/> ( name -- ) : def-for-html-word-<foo/> ( name -- )
#! Return the name and code for the <foo/> patterned #! Return the name and code for the <foo/> patterned
#! word. #! word.
dup <foo/> swap [ <foo/> write-html ] curry html-word ; dup <foo/> swap [ <foo/> write-html ] curry
empty-effect html-word ;
: foo/> "/>" append ; : foo/> "/>" append ;
: def-for-html-word-foo/> ( name -- ) : def-for-html-word-foo/> ( name -- )
#! Return the name and code for the foo/> patterned #! Return the name and code for the foo/> patterned
#! word. #! word.
foo/> [ "/>" write-html ] html-word ; foo/> [ "/>" write-html ] empty-effect html-word ;
: define-closed-html-word ( name -- ) : define-closed-html-word ( name -- )
#! Given an HTML tag name, define the words for #! Given an HTML tag name, define the words for
#! that closable HTML tag. #! that closable HTML tag.
dup def-for-html-word-<foo> dup def-for-html-word-<foo>
@ -112,7 +117,7 @@ SYMBOL: html
dup def-for-html-word-foo> dup def-for-html-word-foo>
def-for-html-word-</foo> ; def-for-html-word-</foo> ;
: define-open-html-word ( name -- ) : define-open-html-word ( name -- )
#! Given an HTML tag name, define the words for #! Given an HTML tag name, define the words for
#! that open HTML tag. #! that open HTML tag.
dup def-for-html-word-<foo/> dup def-for-html-word-<foo/>
@ -123,34 +128,38 @@ SYMBOL: html
" " write-html " " write-html
write-html write-html
"='" write-html "='" write-html
escape-quoted-string write escape-quoted-string write-html
"'" write-html ; "'" write-html ;
: attribute-effect T{ effect f { "string" } 0 } ;
: define-attribute-word ( name -- ) : define-attribute-word ( name -- )
dup "=" swap append swap dup "=" swap append swap
[ write-attr ] curry html-word ; [ write-attr ] curry attribute-effect html-word ;
! Define some closed HTML tags
[ [
"h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" ! Define some closed HTML tags
"ol" "li" "form" "a" "p" "html" "head" "body" "title" [
"b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea" "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
"script" "div" "span" "select" "option" "style" "ol" "li" "form" "a" "p" "html" "head" "body" "title"
] [ define-closed-html-word ] each "b" "i" "ul" "table" "tbody" "tr" "td" "th" "pre" "textarea"
"script" "div" "span" "select" "option" "style"
] [ define-closed-html-word ] each
! Define some open HTML tags ! Define some open HTML tags
[ [
"input" "input"
"br" "br"
"link" "link"
"img" "img"
] [ define-open-html-word ] each ] [ define-open-html-word ] each
! Define some attributes ! Define some attributes
[ [
"method" "action" "type" "value" "name" "method" "action" "type" "value" "name"
"size" "href" "class" "border" "rows" "cols" "size" "href" "class" "border" "rows" "cols"
"id" "onclick" "style" "valign" "accesskey" "id" "onclick" "style" "valign" "accesskey"
"src" "language" "colspan" "onchange" "rel" "src" "language" "colspan" "onchange" "rel"
"width" "selected" "onsubmit" "xmlns" "lang" "xml:lang" "width" "selected" "onsubmit" "xmlns" "lang" "xml:lang"
] [ define-attribute-word ] each ] [ define-attribute-word ] each
] with-compilation-unit

5
extra/html/html.factor
View File

@ -109,7 +109,10 @@ M: html-span-stream stream-close
page-color [ bg-css, ] apply-style page-color [ bg-css, ] apply-style
border-color [ border-css, ] apply-style border-color [ border-css, ] apply-style
border-width [ padding-css, ] apply-style border-width [ padding-css, ] apply-style
wrap-margin [ pre-css, ] apply-style ! FIXME: This is a hack for webapps.help
building get empty? [
wrap-margin over at pre-css,
] unless
] make-css ; ] make-css ;
: div-tag ( style quot -- ) : div-tag ( style quot -- )

4
extra/http/server/responders/responders.factor
View File

@ -124,6 +124,10 @@ SYMBOL: max-post-request
: header-param ( key -- value ) "header" get at ; : header-param ( key -- value ) "header" get at ;
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
: add-responder ( responder -- ) : add-responder ( responder -- )
#! Add a responder object to the list. #! Add a responder object to the list.
"responder" over at responders get set-at ; "responder" over at responders get set-at ;

4
extra/http/server/server.factor
View File

@ -28,10 +28,6 @@ IN: http.server
{ "HEAD" "head" } { "HEAD" "head" }
} at "bad" or ; } at "bad" or ;
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
: (handle-request) ( arg cmd -- method path host ) : (handle-request) ( arg cmd -- method path host )
request-method dup "method" set swap request-method dup "method" set swap
prepare-url prepare-header host ; prepare-url prepare-header host ;

3
extra/http/server/templating/templating.factor
View File

@ -77,7 +77,6 @@ DEFER: <% delimiter
[ [
[ [
"quiet" on "quiet" on
file-vocabs
parser-notes off parser-notes off
templating-vocab use+ templating-vocab use+
dup source-file file set ! so that reload works properly dup source-file file set ! so that reload works properly
@ -85,7 +84,7 @@ DEFER: <% delimiter
?resource-path file-contents ?resource-path file-contents
[ eval-template ] [ html-error. drop ] recover [ eval-template ] [ html-error. drop ] recover
] keep ] keep
] with-scope ] with-file-vocabs
] assert-depth drop ; ] assert-depth drop ;
: run-relative-template-file ( filename -- ) : run-relative-template-file ( filename -- )

4
extra/webapps/cgi/cgi.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Slava Pestov. ! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: namespaces kernel assocs io.files combinators USING: namespaces kernel assocs io.files combinators
arrays io.launcher io http.server http.server.responders arrays io.launcher io http.server.responders webapps.file
webapps.file sequences strings ; sequences strings ;
IN: webapps.cgi IN: webapps.cgi
SYMBOL: cgi-root SYMBOL: cgi-root