- off-by-one error in pick-up?\r
- closing ui does not stop timers\r
- adding/removing timers automatically for animated gadgets\r
-- pane should not scroll all the way to the right if long lines are present\r
-- multi-part gradients\r
- tabular output\r
- debugger should use outlining\r
- support nested incremental layouts more efficiently\r
- get stuff in examples dir running in the ui\r
- text selection\r
- clipboard support\r
-- get things working without the [ >fixnum ] map hack\r
\r
+ tutorial:\r
\r
\r
+ ffi:\r
\r
-- powerpc: ffi call a function that calls printf, segfault\r
- C structs, enums, unions: use new-style string mode parsing\r
- alien/c-types.factor is ugly\r
- smarter out parameter handling\r
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+!
+! A Smalltalk-like browser that runs in the httpd server using
+! cont-responder facilities.
+!
+IN: browser-responder
+USING: html cont-responder kernel io namespaces words lists prettyprint
+ memory sequences ;
+
+: option ( current text -- )
+ #! Output the HTML option tag for the given text. If
+ #! it is equal to the current string, make the option selected.
+ 2dup = [
+ "<option selected>" write
+ ] [
+ "<option>" write
+ ] if
+ chars>entities write
+ "</option>\n" write drop ;
+
+: vocab-list ( vocab -- )
+ #! Write out the HTML for the list of vocabularies. Make the currently
+ #! selected vocab be 'vocab'.
+ <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
+ vocabs [ over swap option ] each drop
+ </select> ;
+
+: word-list ( vocab word -- )
+ #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
+ #! the currently selected option.
+ <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
+ swap words word-sort [ word-name over swap option ] each drop
+ </select> ;
+
+: word-source ( vocab word -- )
+ #! Write the source for the given word from the vocab as HTML.
+ swap lookup [
+ [ see ] with-simple-html-output
+ ] when* ;
+
+: vm-statistics ( -- )
+ #! Display statistics about the vm.
+ <pre> room. </pre> ;
+
+: browser-body ( vocab word -- )
+ #! Write out the HTML for the body of the main browser page.
+ <table "100%" =width table>
+ <tr>
+ <td> <b> "Vocabularies" write </b> </td>
+ <td> <b> "Words" write </b> </td>
+ <td> <b> "Source" write </b> </td>
+ </tr>
+ <tr>
+ <td "top" =valign "width: 200" =style td> over vocab-list </td>
+ <td "top" =valign "width: 200" =style td> 2dup word-list </td>
+ <td "top" =valign td> word-source </td>
+ </tr>
+ </table>
+ vm-statistics ;
+
+: browser-title ( vocab word -- )
+ #! Output the HTML title for the browser.
+ <title>
+ "Factor Browser - " write
+ swap write
+ " - " write
+ write
+ </title> ;
+
+: browser-style ( -- )
+ #! Stylesheet for browser pages
+ <style>
+ "A:link { text-decoration:none}\n" write
+ "A:visited { text-decoration:none}\n" write
+ "A:active { text-decoration:none}\n" write
+ "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: 0px }\n" write
+ "A { margin: 1px }" write
+ </style> ;
+
+: browse ( vocab word -- )
+ #! Display a Smalltalk like browser for exploring words.
+ [
+ <html>
+ <head> 2dup browser-title browser-style </head>
+ <body>
+ <form "main" =name "" =action "get" =method form> browser-body </form>
+ </body>
+ </html>
+ ] show-final ;
+
+: browser-responder ( -- )
+ #! Start the Smalltalk-like browser.
+ "query" get [
+ [ "vocab" swap assoc ] keep
+ "word" swap assoc
+ ] [
+ "browser-responder" "browse"
+ ] if* browse ;
--- /dev/null
+! Copyright (C) 2004 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+IN: cont-responder
+USING: http httpd math random namespaces io
+ lists strings kernel html hashtables
+ parser generic sequences ;
+
+#! Used inside the session state of responders to indicate whether the
+#! next request should use the post-refresh-get pattern. It is set to
+#! true after each request.
+SYMBOL: post-refresh-get?
+
+: expiry-timeout ( -- timeout-seconds )
+ #! Number of seconds to timeout continuations in
+ #! continuation table. This value will need to be
+ #! tuned. I leave it at 24 hours but it can be
+ #! higher/lower as needed. Default to 15 minutes for
+ #! testing.
+ 900 ;
+
+: get-random-id ( -- id )
+ #! Generate a random id to use for continuation URL's
+ [ 32 [ 9 random-int CHAR: 0 + , ] times ] "" make
+ string>number 36 >base ;
+
+SYMBOL: table
+
+: continuation-table ( -- <hashtable> )
+ #! Return the global table of continuations
+ table global hash ;
+
+: reset-continuation-table ( -- )
+ #! Create the initial global table
+ continuation-table hash-clear ;
+
+{{ }} clone table global set-hash
+
+#! Tuple for holding data related to a continuation.
+TUPLE: item expire? quot id time-added ;
+
+: continuation-item ( expire? quot id -- <item> )
+ #! A continuation item is the actual item stored
+ #! in the continuation table. It contains the id,
+ #! quotation/continuation, time added, etc. If
+ #! expire? is true then the continuation will
+ #! be expired after a certain amount of time.
+ millis <item> ;
+
+: seconds>millis ( seconds -- millis )
+ #! Convert a number of seconds to milliseconds
+ 1000 * ;
+
+: expired? ( timeout-seconds <item> -- bool )
+ #! Return true if the continuation item is expirable
+ #! and has expired (ie. was added to the table more than
+ #! timeout milliseconds ago).
+ [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
+
+: expire-continuations ( timeout-seconds -- )
+ #! Expire all continuations in the continuation table
+ #! if they are 'timeout-seconds' old (ie. were added
+ #! more than 'timeout-seconds' ago.
+ continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
+ uncons swapd expired? [
+ continuation-table remove-hash
+ ] [
+ drop
+ ] if
+ ] hash-each-with ;
+
+: expirable ( quot -- t quot )
+ #! Set the stack up for a register-continuation call
+ #! so that the given quotation is registered that it can
+ #! be expired.
+ t swap ;
+
+: permanent ( quot -- f quot )
+ #! Set the stack up for a register-continuation call
+ #! so that the given quotation is never expired after
+ #! registration.
+ f swap ;
+
+: register-continuation ( expire? quot -- id )
+ #! Store a continuation in the table and associate it with
+ #! a random id. That continuation will be expired after
+ #! a certain period of time if 'expire?' is true.
+ get-random-id
+ [ continuation-item ] keep ( item id -- )
+ [ continuation-table set-hash ] keep ;
+
+: register-continuation* ( expire? quots -- id )
+ #! Like register-continuation but registers a quotation
+ #! that will call all quotations in the list, in the order given.
+ concat register-continuation ;
+
+: get-continuation-item ( id -- <item> )
+ #! Get the continuation item associated with the id.
+ continuation-table hash ;
+
+: id>url ( id -- string )
+ #! Convert the continuation id to an URL suitable for
+ #! embedding in an HREF or other HTML.
+ url-encode "?id=" swap append ;
+
+DEFER: show-final
+DEFER: show
+
+: expired-page-handler ( alist -- )
+ #! Display a page has expired message.
+ #! TODO: Need to handle this better to enable
+ #! returning back to root continuation.
+ drop
+ [
+ <html>
+ <body>
+ <p> "This page has expired." write </p>
+ </body>
+ </html>
+ ] show-final ;
+
+: >callable ( quot|interp|f -- interp )
+ dup continuation? [
+ [ continue-with ] cons
+ ] when ;
+
+: get-registered-continuation ( id -- cont )
+ #! Return the continuation or quotation
+ #! associated with the given id.
+ #! TODO: handle expired pages better.
+ expiry-timeout expire-continuations
+ get-continuation-item [
+ item-quot
+ ] [
+ [ expired-page-handler ]
+ ] if* >callable ;
+
+: resume-continuation ( value id -- )
+ #! Call the continuation associated with the given id,
+ #! with 'value' on the top of the stack.
+ get-registered-continuation call ;
+
+#! Name of the variable holding the continuation used to exit
+#! back to the httpd responder, returning any generated HTML.
+SYMBOL: exit-cc
+
+: exit-continuation ( -- exit )
+ #! Get the current exit continuation
+ exit-cc get ;
+
+: call-exit-continuation ( value -- )
+ #! Call the exit continuation, passing it the given value on the
+ #! top of the stack.
+ exit-cc get continue-with ;
+
+: with-exit-continuation ( quot -- )
+ #! Call the quotation with the variable exit-cc bound such that when
+ #! the exit continuation is called, computation will resume from the
+ #! end of this 'with-exit-continuation' call, with the value passed
+ #! to the exit continuation on the top of the stack.
+ [ exit-cc set call f call-exit-continuation ] callcc1 nip ;
+
+#! Name of variable holding the 'callback' continuation, used for
+#! returning back to previous 'show' calls.
+SYMBOL: callback-cc
+
+: store-callback-cc ( -- )
+ #! Store the current continuation in the variable 'callback-cc'
+ #! so it can be returned to later by callbacks. Note that it
+ #! recalls itself when the continuation is called to ensure that
+ #! it resets its value back to the most recent show call.
+ [ ( 0 -- )
+ [ ( 0 1 -- )
+ callback-cc set ( 0 -- )
+ continue
+ ] callcc1 ( 0 [ ] == )
+ nip
+ call
+ store-callback-cc
+ ] callcc0 ;
+
+: forward-to-url ( url -- )
+ #! When executed inside a 'show' call, this will force a
+ #! HTTP 302 to occur to instruct the browser to forward to
+ #! the request URL.
+ [
+ "HTTP/1.1 302 Document Moved\nLocation: " % %
+ "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
+ ] "" make call-exit-continuation ;
+
+: forward-to-id ( id -- )
+ #! When executed inside a 'show' call, this will force a
+ #! HTTP 302 to occur to instruct the browser to forward to
+ #! the request URL.
+ >r "request" get r> id>url append forward-to-url ;
+
+: redirect-to-here ( -- )
+ #! Force a redirect to the client browser so that the browser
+ #! goes to the current point in the code. This forces an URL
+ #! change on the browser so that refreshing that URL will
+ #! immediately run from this code point. This prevents the
+ #! "this request will issue a POST" warning from the browser
+ #! and prevents re-running the previous POST logic. This is
+ #! known as the 'post-refresh-get' pattern.
+ post-refresh-get? get [
+ [
+ expirable register-continuation forward-to-id
+ ] callcc1 drop
+ ] [
+ t post-refresh-get? set
+ ] if ;
+
+: (show) ( quot -- namespace )
+ #! See comments for show. The difference is the
+ #! quotation MUST set the content-type using 'serving-html'
+ #! or similar.
+ store-callback-cc redirect-to-here
+ [
+ expirable register-continuation id>url swap
+ string-out call-exit-continuation
+ ] callcc1
+ nip ;
+
+: show ( quot -- namespace )
+ #! Call the quotation with the URL associated with the current
+ #! continuation. Return the HTML string generated by that code
+ #! to the exit continuation. When the URL is later referenced then
+ #! computation will resume from this 'show' call with a namespace on
+ #! the stack containing any query or post parameters.
+ #! NOTE: On return from 'show' the stack is exactly the same as
+ #! initial entry with 'quot' popped off an <namespace> put on. Even
+ #! if the quotation consumes items on the stack.
+ \ serving-html swons (show) ;
+
+: (show-final) ( quot -- namespace )
+ #! See comments for show-final. The difference is the
+ #! quotation MUST set the content-type using 'serving-html'
+ #! or similar.
+ store-callback-cc redirect-to-here
+ string-out call-exit-continuation ;
+
+: show-final ( quot -- namespace )
+ #! Similar to 'show', except the quotation does not receive the URL
+ #! to resume computation following 'show-final'. No continuation is
+ #! stored for this resumption. As a result, 'show-final' is for use
+ #! when a page is to be displayed with no further action to occur. Its
+ #! use is an optimisation to save having to generate and save a continuation
+ #! in that special case.
+ \ serving-html swons (show-final) ;
+
+#! Name of variable for holding initial continuation id that starts
+#! the responder.
+SYMBOL: root-continuation
+
+: id-or-root ( -- id )
+ #! Return the continuation id for the current requested continuation
+ #! or the root continuation if no id is supplied.
+ "id" "query" get assoc [ root-continuation get ] unless* ;
+
+: cont-get/post-responder ( id-or-f -- )
+ #! httpd responder that retrieves a continuation and calls it.
+ #! The continuation id must be in a query parameter called 'id'.
+ #! If it does not exist the root continuation is called. If
+ #! no root continuation exists the expired continuation handler
+ #! should be called.
+ drop [
+ "response" get alist>hash
+ id-or-root [
+ resume-continuation
+ ] [
+ expired-page-handler
+ ] if*
+ ] with-exit-continuation [ write flush ] when* ;
+
+: callback-quot ( quot -- quot )
+ #! Convert the given quotation so it works as a callback
+ #! by returning a quotation that will pass the original
+ #! quotation to the callback continuation.
+ [ , callback-cc get , \ continue-with , ] [ ] make ;
+
+: 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> ;
+
+: init-session-namespace ( -- )
+ #! Setup the initial session namespace. Currently this only
+ #! sets the redirect flag so that the initial request of the
+ #! responder will not do a post-refresh-get style redirect.
+ #! This prevents the initial request to a responder from redirecting
+ #! to an URL with a continuation id. This word must be run from
+ #! within the session namespace.
+ f post-refresh-get? set ;
+
+: install-cont-responder ( name quot -- )
+ #! Install a cont-responder with the given name
+ #! that will initially run the given quotation.
+ #!
+ #! Convert the quotation so it is run within a session namespace
+ #! and that namespace is initialized first.
+ \ init-session-namespace swons [ , \ with-scope , ] [ ] make
+ [
+ [ cont-get/post-responder ] "get" set
+ [ cont-get/post-responder ] "post" set
+ swap "responder" set
+ permanent register-continuation root-continuation set
+ ] make-responder ;
+
+: simple-page ( title quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title.
+ <html>
+ <head> <title> swap write </title> </head>
+ <body> call </body>
+ </html> ;
+
+: styled-page ( title stylesheet-quot quot -- )
+ #! Call the quotation, with all output going to the
+ #! body of an html page with the given title. stylesheet-quot
+ #! is called to generate the required stylesheet.
+ <html>
+ <head>
+ <title> rot write </title>
+ swap call
+ </head>
+ <body> call </body>
+ </html> ;
+
+: paragraph ( str -- )
+ #! Output the string as an html paragraph
+ <p> write </p> ;
+
+: show-message-page ( message -- )
+ #! Display the message in an HTML page with an OK button.
+ [
+ "Press OK to Continue" [
+ swap paragraph
+ <a =href a> "OK" write </a>
+ ] simple-page
+ ] show 2drop ;
+
+: vertical-layout ( list -- )
+ #! Given a list of HTML components, arrange them vertically.
+ <table>
+ [ <tr> <td> call </td> </tr> ] each
+ </table> ;
+
+: horizontal-layout ( list -- )
+ #! Given a list of HTML components, arrange them horizontally.
+ <table>
+ <tr "top" =valign tr> [ <td> call </td> ] each </tr>
+ </table> ;
+
+: 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> ;
+
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: httpd
+USING: browser-responder cont-responder file-responder kernel
+namespaces prettyprint quit-responder resource-responder
+test-responder ;
+
+#! Remove all existing responders, and create a blank
+#! responder table.
+global [
+ {{ }} clone responders set
+
+ ! 404 error message pages are served by this guy
+ [
+ "404" "responder" set
+ [ drop no-such-responder ] "get" set
+ ] make-responder
+
+ ! Servers Factor word definitions from the image.
+ "browser" [ browser-responder ] install-cont-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.
+ [
+ ! "/var/www/" "doc-root" set
+ "file" "responder" set
+ [ file-responder ] "get" set
+ [ file-responder ] "post" set
+ [ file-responder ] "head" set
+ ] make-responder
+
+ ! The root directory is served by...
+ "file" set-default-responder
+
+ vhosts nest [ {{ }} clone "default" set ] bind
+] bind
--- /dev/null
+! Copyright (C) 2004,2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: file-responder
+USING: html httpd kernel lists math namespaces parser sequences
+io strings ;
+
+: serving-path ( filename -- filename )
+ [ "" ] unless* "doc-root" get swap append ;
+
+: file-response ( mime-type length -- )
+ [
+ number>string "Content-Length" swons ,
+ "Content-Type" swons ,
+ ] [ ] make "200 OK" response terpri ;
+
+: serve-static ( filename mime-type -- )
+ over file-length file-response "method" get "head" = [
+ drop
+ ] [
+ <file-reader> stdio get stream-copy
+ ] if ;
+
+: serve-file ( filename -- )
+ dup mime-type dup "application/x-factor-server-page" = [
+ drop run-file
+ ] [
+ serve-static
+ ] if ;
+
+: list-directory ( directory -- )
+ serving-html
+ "method" get "head" = [
+ drop
+ ] [
+ "request" get [ directory. ] simple-html-document
+ ] if ;
+
+: serve-directory ( filename -- )
+ "/" ?tail [
+ dup "/index.html" append dup exists? [
+ nip serve-file
+ ] [
+ drop list-directory
+ ] if
+ ] [
+ drop directory-no/
+ ] if ;
+
+: serve-object ( filename -- )
+ dup directory? [ serve-directory ] [ serve-file ] if ;
+
+: file-responder ( filename -- )
+ "doc-root" get [
+ serving-path dup exists? [
+ serve-object
+ ] [
+ drop "404 not found" httpd-error
+ ] if
+ ] [
+ drop "404 doc-root not set" httpd-error
+ ] if ;
--- /dev/null
+! cont-html v0.6
+!
+! Copyright (C) 2004 Chris Double.
+!
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+!
+! 1. Redistributions of source code must retain the above copyright notice,
+! this list of conditions and the following disclaimer.
+!
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+! this list of conditions and the following disclaimer in the documentation
+! and/or other materials provided with the distribution.
+!
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: html
+USING: prettyprint ;
+USE: strings
+USE: lists
+USE: kernel
+USE: io
+USE: namespaces
+USE: words
+USE: sequences
+
+! These words are used to provide a means of writing
+! formatted HTML to standard output with a familiar 'html' look
+! and feel in the code.
+!
+! HTML tags can be used in a number of different ways. The highest
+! level involves a similar syntax to HTML:
+!
+! <p> "someoutput" write </p>
+!
+! <p> will output the opening tag and </p> will output the closing
+! tag with no attributes.
+!
+! <p "red" =class p> "someoutput" write </p>
+!
+! This time the opening tag does not have the '>'. It pushes
+! a namespace on the stack to hold the attributes and values.
+! Any attribute words used will store the attribute and values
+! in that namespace. Before the attribute word should come the
+! value of that attribute.
+! The finishing word will print out the operning tag including
+! attributes.
+! Any writes after this will appear after the opening tag.
+!
+! Values for attributes can be used directly without any stack
+! operations:
+!
+! (url -- )
+! <a =href a> "Click me" write </a>
+!
+! (url -- )
+! <a "http://" swap append =href a> "click" write </a>
+!
+! (url -- )
+! <a [ "http://" % % ] "" make =href a> "click" write </a>
+!
+! Tags that have no 'closing' equivalent have a trailing tag/> form:
+!
+! <input "text" =type "name" =name "20" =size input/>
+
+: attrs>string ( alist -- string )
+ #! Convert the attrs alist to a string
+ #! suitable for embedding in an html tag.
+ [ [ " " % dup car % "='" % cdr % "'" % ] each ] "" make ;
+
+: write-attributes ( n: namespace -- )
+ #! With the attribute namespace on the stack, get the attributes
+ #! and write them to standard output. If no attributes exist, write
+ #! nothing.
+ "attrs" get attrs>string write ;
+
+: html-word ( name def -- )
+ #! Define 'word creating' word to allow
+ #! dynamically creating words.
+ >r "html" create dup r> define-compound ;
+
+: <foo> "<" swap ">" append3 ;
+
+: do-<foo> <foo> write ;
+
+: def-for-html-word-<foo> ( name -- )
+ #! Return the name and code for the <foo> patterned
+ #! word.
+ dup <foo> swap [ do-<foo> ] cons html-word define-open ;
+
+: <foo "<" swap append ;
+
+: do-<foo write {{ }} clone >n { } clone "attrs" set ;
+
+: def-for-html-word-<foo ( name -- )
+ #! Return the name and code for the <foo patterned
+ #! word.
+ <foo dup [ do-<foo ] cons html-word drop ;
+
+: foo> ">" append ;
+
+: do-foo> write-attributes n> drop ">" write ;
+
+: def-for-html-word-foo> ( name -- )
+ #! Return the name and code for the foo> patterned
+ #! word.
+ foo> [ do-foo> ] html-word define-open ;
+
+: </foo> [ "</" % % ">" % ] "" make ;
+
+: def-for-html-word-</foo> ( name -- )
+ #! Return the name and code for the </foo> patterned
+ #! word.
+ </foo> dup [ write ] cons html-word define-close ;
+
+: <foo/> [ "<" % % "/>" % ] "" make ;
+
+: def-for-html-word-<foo/> ( name -- )
+ #! Return the name and code for the <foo/> patterned
+ #! word.
+ dup <foo/> swap [ do-<foo> ] cons html-word drop ;
+
+: foo/> "/>" append ;
+
+: def-for-html-word-foo/> ( name -- )
+ #! Return the name and code for the foo/> patterned
+ #! word.
+ foo/> [ do-foo> ] html-word define-close ;
+
+: define-closed-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that closable HTML tag.
+ dup def-for-html-word-<foo>
+ dup def-for-html-word-<foo
+ dup def-for-html-word-foo>
+ def-for-html-word-</foo> ;
+
+: define-open-html-word ( name -- )
+ #! Given an HTML tag name, define the words for
+ #! that open HTML tag.
+ dup def-for-html-word-<foo/>
+ dup def-for-html-word-<foo
+ def-for-html-word-foo/> ;
+
+: define-attribute-word ( name -- )
+ dup "=" swap append swap [
+ , [ swons "attrs" get push ] %
+ ] [ ] make html-word drop ;
+
+! Define some closed HTML tags
+[
+ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
+ "ol" "li" "form" "a" "p" "html" "head" "body" "title"
+ "b" "i" "ul" "table" "tr" "td" "th" "pre" "textarea"
+ "script" "div" "span" "select" "option" "style"
+] [ define-closed-html-word ] each
+
+! Define some open HTML tags
+[
+ "input"
+ "br"
+ "link"
+ "img"
+] [ define-open-html-word ] each
+
+! Define some attributes
+[
+ "method" "action" "type" "value" "name"
+ "size" "href" "class" "border" "rows" "cols"
+ "id" "onclick" "style" "valign" "accesskey"
+ "src" "language" "colspan" "onchange" "rel"
+ "width"
+] [ define-attribute-word ] each
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: html
+USING: generic http io kernel lists math namespaces
+presentation sequences strings styles words ;
+
+: html-entities ( -- alist )
+ [
+ [[ CHAR: < "<" ]]
+ [[ CHAR: > ">" ]]
+ [[ CHAR: & "&" ]]
+ [[ CHAR: ' "'" ]]
+ [[ CHAR: " """ ]]
+ ] ;
+
+: chars>entities ( str -- str )
+ #! Convert <, >, &, ' and " to HTML entities.
+ [
+ [ dup html-entities assoc [ % ] [ , ] ?if ] each
+ ] "" make ;
+
+: hex-color, ( triplet -- )
+ [ >hex 2 CHAR: 0 pad-left % ] each ;
+
+: fg-css, ( color -- )
+ "color: #" % hex-color, "; " % ;
+
+: style-css, ( flag -- )
+ dup [ italic bold-italic ] member?
+ [ "font-style: italic; " % ] when
+ [ bold bold-italic ] member?
+ [ "font-weight: bold; " % ] when ;
+
+: underline-css, ( flag -- )
+ [ "text-decoration: underline; " % ] when ;
+
+: size-css, ( size -- )
+ "font-size: " % # "; " % ;
+
+: font-css, ( font -- )
+ "font-family: " % % "; " % ;
+
+: css-style ( style -- )
+ [
+ [
+ [ foreground fg-css, ]
+ [ font font-css, ]
+ [ font-style style-css, ]
+ [ font-size size-css, ]
+ [ underline underline-css, ]
+ ] assoc-apply
+ ] "" make ;
+
+: span-tag ( style quot -- )
+ over css-style dup "" = [
+ drop call
+ ] [
+ <span =style span> call </span>
+ ] if ;
+
+: resolve-file-link ( path -- link )
+ #! The file responder needs relative links not absolute
+ #! links.
+ "doc-root" get [
+ ?head [ "/" ?head drop ] when
+ ] when* "/" ?tail drop ;
+
+: file-link-href ( path -- href )
+ [ "/" % resolve-file-link url-encode % ] "" make ;
+
+: file-link-tag ( style quot -- )
+ over file swap assoc [
+ <a file-link-href =href a> call </a>
+ ] [
+ call
+ ] if* ;
+
+: browser-link-href ( word -- href )
+ dup word-name swap word-vocabulary
+ [
+ "/responder/browser/?vocab=" %
+ url-encode %
+ "&word=" %
+ url-encode %
+ ] "" make ;
+
+: browser-link-tag ( style quot -- style )
+ over presented swap assoc dup word? [
+ <a browser-link-href =href a> call </a>
+ ] [
+ drop call
+ ] if ;
+
+TUPLE: html-stream ;
+
+M: html-stream stream-write1 ( char stream -- )
+ [
+ dup html-entities assoc [ write ] [ write1 ] ?if
+ ] with-wrapper ;
+
+M: html-stream stream-format ( str style stream -- )
+ [
+ [
+ [
+ [ drop chars>entities write ] span-tag
+ ] file-link-tag
+ ] browser-link-tag
+ ] with-wrapper ;
+
+C: html-stream ( stream -- stream )
+ #! Wraps the given stream in an HTML stream. An HTML stream
+ #! converts special characters to entities when being
+ #! written, and supports writing attributed strings with
+ #! the following attributes:
+ #!
+ #! foreground - an rgb triplet in a list
+ #! background - an rgb triplet in a list
+ #! font
+ #! font-style
+ #! font-size
+ #! underline
+ #! file
+ #! word
+ #! vocab
+ [ >r <wrapper-stream> r> set-delegate ] keep ;
+
+: with-html-stream ( quot -- )
+ [ stdio [ <html-stream> ] change call ] with-scope ;
+
+: html-document ( title quot -- )
+ swap chars>entities dup
+ <html>
+ <head>
+ <title> write </title>
+ </head>
+ <body>
+ <h1> write </h1>
+ call
+ </body>
+ </html> ;
+
+: simple-html-document ( title quot -- )
+ swap [ <pre> with-html-stream </pre> ] html-document ;
--- /dev/null
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: http-client
+USING: errors http kernel lists math namespaces parser sequences
+io strings ;
+
+: parse-host ( url -- host port )
+ #! Extract the host name and port number from an HTTP URL.
+ ":" split1 [ string>number ] [ 80 ] if* ;
+
+: parse-url ( url -- host resource )
+ "http://" ?head [
+ "URL must begin with http://" throw
+ ] unless
+ "/" split1 [ "/" swap append ] [ "/" ] if* ;
+
+: parse-response ( line -- code )
+ "HTTP/" ?head [ " " split1 nip ] when
+ " " split1 drop string>number ;
+
+: read-response ( -- code header )
+ #! After sending a GET oR POST we read a response line and
+ #! header.
+ flush readln parse-response read-header ;
+
+: crlf "\r\n" write ;
+
+: http-request ( host resource method -- )
+ write " " write write " HTTP/1.0" write crlf
+ "Host: " write write crlf ;
+
+: get-request ( host resource -- )
+ "GET" http-request crlf ;
+
+DEFER: http-get
+
+: do-redirect ( code headers stream -- code headers stream )
+ #! Should this support Location: headers that are
+ #! relative URLs?
+ pick 302 = [
+ stream-close "Location" swap assoc nip http-get
+ ] when ;
+
+: http-get ( url -- code headers stream )
+ #! Opens a stream for reading from an HTTP URL.
+ parse-url over parse-host <client> [
+ [ get-request read-response ] with-stream*
+ ] keep do-redirect ;
+
+: download ( url file -- )
+ #! Downloads the contents of a URL to a file.
+ >r http-get 2nip r> <file-writer> stream-copy ;
+
+: post-request ( content-type content host resource -- )
+ #! Note: It is up to the caller to url encode the content if
+ #! it is required according to the content-type.
+ "POST" http-request [
+ "Content-Length: " write length number>string write crlf
+ "Content-Type: " write url-encode write crlf
+ crlf
+ ] keep write ;
+
+: http-post ( content-type content url -- code headers stream )
+ #! Make a POST request. The content is URL encoded for you.
+ parse-url over parse-host <client> [
+ [ post-request flush read-response ] with-stream*
+ ] keep ;
--- /dev/null
+! Copyright (C) 2003, 2005 Slava Pestov
+IN: http
+USING: errors kernel lists math namespaces parser sequences
+io strings ;
+
+: header-line ( alist line -- alist )
+ ": " split1 dup [ cons swons ] [ 2drop ] if ;
+
+: (read-header) ( alist -- alist )
+ readln dup
+ empty? [ drop ] [ header-line (read-header) ] if ;
+
+: read-header ( -- alist )
+ [ ] (read-header) ;
+
+: url-encode ( str -- str )
+ [
+ [
+ dup url-quotable? [
+ ,
+ ] [
+ CHAR: % , >hex 2 CHAR: 0 pad-left %
+ ] if
+ ] each
+ ] "" make ;
+
+: catch-hex> ( str -- n/f )
+ #! Push f if string is not a valid hex literal.
+ [ hex> ] catch [ drop f ] when ;
+
+: url-decode-hex ( index str -- )
+ 2dup length 2 - >= [
+ 2drop
+ ] [
+ >r 1+ dup 2 + r> subseq catch-hex> [ , ] when*
+ ] if ;
+
+: url-decode-% ( index str -- index str )
+ 2dup url-decode-hex >r 3 + r> ;
+
+: url-decode-+-or-other ( index str ch -- index str )
+ dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
+
+: url-decode-iter ( index str -- )
+ 2dup length >= [
+ 2drop
+ ] [
+ 2dup nth dup CHAR: % = [
+ drop url-decode-%
+ ] [
+ url-decode-+-or-other
+ ] if url-decode-iter
+ ] if ;
+
+: url-decode ( str -- str )
+ [ 0 swap url-decode-iter ] "" make ;
--- /dev/null
+! Copyright (C) 2003, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: httpd
+USING: errors kernel lists namespaces io strings threads http
+sequences ;
+
+: (url>path) ( uri -- path )
+ url-decode "http://" ?head [
+ "/" split1 dup "" ? nip
+ ] when ;
+
+: url>path ( uri -- path )
+ "?" split1 dup [
+ >r (url>path) "?" r> append3
+ ] [
+ drop (url>path)
+ ] if ;
+
+: secure-path ( path -- path )
+ ".." over subseq? [ drop f ] when ;
+
+: request-method ( cmd -- method )
+ [
+ [[ "GET" "get" ]]
+ [[ "POST" "post" ]]
+ [[ "HEAD" "head" ]]
+ ] assoc [ "bad" ] unless* ;
+
+: host ( -- string )
+ #! The host the current responder was called from.
+ "Host" "header" get assoc ":" split1 drop ;
+
+: (handle-request) ( arg cmd -- method path host )
+ request-method dup "method" set swap
+ prepare-url prepare-header host ;
+
+: handle-request ( arg cmd -- )
+ [ (handle-request) serve-responder ] with-scope ;
+
+: parse-request ( request -- )
+ dup log-message
+ " " split1 dup [
+ " HTTP" split1 drop url>path secure-path dup [
+ swap handle-request
+ ] [
+ 2drop bad-request
+ ] if
+ ] [
+ 2drop bad-request
+ ] if ;
+
+: httpd ( port -- )
+ \ httpd [
+ 60000 stdio get set-timeout
+ readln [ parse-request ] when*
+ ] with-server ;
+
+: stop-httpd ( -- )
+ #! Stop the server.
+ \ httpd get stream-close ;
--- /dev/null
+USING: kernel parser sequences io ;
+[
+ "contrib/httpd/http-common.factor"
+ "contrib/httpd/mime.factor"
+ "contrib/httpd/html-tags.factor"
+ "contrib/httpd/html.factor"
+ "contrib/httpd/responder.factor"
+ "contrib/httpd/httpd.factor"
+ "contrib/httpd/file-responder.factor"
+ "contrib/httpd/cont-responder.factor"
+ "contrib/httpd/browser-responder.factor"
+ "contrib/httpd/default-responders.factor"
+ "contrib/httpd/http-client.factor"
+] [
+ dup print run-file
+] each
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: httpd
+USING: io hashtables kernel lists namespaces ;
+
+: set-mime-types ( assoc -- )
+ "mime-types" global set-hash ;
+
+: mime-types ( -- assoc )
+ "mime-types" global hash ;
+
+: mime-type ( filename -- mime-type )
+ file-extension mime-types assoc [ "text/plain" ] unless* ;
+
+[
+ [[ "html" "text/html" ]]
+ [[ "txt" "text/plain" ]]
+ [[ "xml" "text/xml" ]]
+ [[ "css" "text/css" ]]
+
+ [[ "gif" "image/gif" ]]
+ [[ "png" "image/png" ]]
+ [[ "jpg" "image/jpeg" ]]
+ [[ "jpeg" "image/jpeg" ]]
+
+ [[ "jar" "application/octet-stream" ]]
+ [[ "zip" "application/octet-stream" ]]
+ [[ "tgz" "application/octet-stream" ]]
+ [[ "tar.gz" "application/octet-stream" ]]
+ [[ "gz" "application/octet-stream" ]]
+
+ [[ "factor" "application/x-factor" ]]
+ [[ "factsp" "application/x-factor-server-page" ]]
+] set-mime-types
--- /dev/null
+! Copyright (C) 2004, 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: httpd
+USING: hashtables http kernel lists math namespaces parser
+sequences io strings ;
+
+! Variables
+SYMBOL: vhosts
+SYMBOL: responders
+
+: print-header ( alist -- )
+ [ unswons write ": " write url-encode print ] each ;
+
+: response ( header msg -- )
+ "HTTP/1.0 " write print print-header ;
+
+: error-body ( error -- body )
+ "<html><body><h1>" swap "</h1></body></html>" append3 print ;
+
+: error-head ( error -- )
+ dup log-error
+ [ [[ "Content-Type" "text/html" ]] ] over response ;
+
+: httpd-error ( error -- )
+ #! This must be run from handle-request
+ error-head
+ "head" "method" get = [ drop ] [ terpri error-body ] if ;
+
+: bad-request ( -- )
+ [
+ ! Make httpd-error print a body
+ "get" "method" set
+ "400 Bad request" httpd-error
+ ] with-scope ;
+
+: serving-content ( mime -- )
+ "Content-Type" swons unit
+ "200 Document follows" response terpri ;
+
+: serving-html "text/html" serving-content ;
+
+: serving-text "text/plain" serving-content ;
+
+: redirect ( to -- )
+ "Location" swons unit
+ "301 Moved Permanently" response terpri ;
+
+: directory-no/ ( -- )
+ [
+ "request" get % CHAR: / ,
+ "raw-query" get [ CHAR: ? , % ] when*
+ ] "" make redirect ;
+
+: query>alist ( query -- alist )
+ dup [
+ "&" split [
+ "=" split1
+ dup [ url-decode ] when swap
+ dup [ url-decode ] when swap cons
+ ] map
+ ] when ;
+
+: read-post-request ( header -- alist )
+ "Content-Length" swap assoc dup
+ [ string>number read query>alist ] when ;
+
+: log-user-agent ( alist -- )
+ "User-Agent" swap assoc* [
+ unswons [ % ": " % % ] "" make log-message
+ ] when* ;
+
+: prepare-url ( url -- url )
+ #! This is executed in the with-request namespace.
+ "?" split1
+ dup "raw-query" set query>alist "query" set
+ dup "request" set ;
+
+: prepare-header ( -- )
+ read-header dup "header" set
+ dup log-user-agent
+ read-post-request "response" set ;
+
+! Responders are called in a new namespace with these
+! variables:
+
+! - method -- one of get, post, or head.
+! - request -- the entire URL requested, including responder
+! name
+! - raw-query -- raw query string
+! - query -- an alist of query parameters, eg
+! foo.bar?a=b&c=d becomes
+! [ [[ "a" "b" ]] [[ "c" "d" ]] ]
+! - header -- an alist of headers from the user's client
+! - response -- an alist of the POST request response
+
+: add-responder ( responder -- )
+ #! Add a responder object to the list.
+ "responder" over hash responders get set-hash ;
+
+: make-responder ( quot -- responder )
+ [
+ ( url -- )
+ [
+ drop "GET method not implemented" httpd-error
+ ] "get" set
+ ( url -- )
+ [
+ drop "POST method not implemented" httpd-error
+ ] "post" set
+ ( url -- )
+ [
+ drop "HEAD method not implemented" httpd-error
+ ] "head" set
+ ( url -- )
+ [
+ drop bad-request
+ ] "bad" set
+
+ call
+ ] make-hash add-responder ;
+
+: vhost ( name -- responder )
+ vhosts get hash [ "default" vhost ] unless* ;
+
+: responder ( name -- responder )
+ responders get hash [ "404" responder ] unless* ;
+
+: set-default-responder ( name -- )
+ responder "default" responders get set-hash ;
+
+: responder-argument ( argument -- argument )
+ dup empty? [ drop "default-argument" get ] when ;
+
+: call-responder ( method argument responder -- )
+ [ responder-argument swap get call ] bind ;
+
+: serve-default-responder ( method url -- )
+ "default" responder call-responder ;
+
+: log-responder ( path -- )
+ "Calling responder " swap append log-message ;
+
+: trim-/ ( url -- url )
+ #! Trim a leading /, if there is one.
+ "/" ?head drop ;
+
+: serve-explicit-responder ( method url -- )
+ "/" split1 dup [
+ swap responder call-responder
+ ] [
+ ! Just a responder name by itself
+ drop "request" get "/" append redirect drop
+ ] if ;
+
+: serve-responder ( method path host -- )
+ #! Responder paths come in two forms:
+ #! /foo/bar... - default responder used
+ #! /responder/foo/bar - responder foo, argument bar
+ vhost [
+ dup log-responder trim-/ "responder/" ?head [
+ serve-explicit-responder
+ ] [
+ serve-default-responder
+ ] if
+ ] bind ;
+
+: no-such-responder ( -- )
+ "404 No such responder" httpd-error ;
"/library/alien/malloc.factor"\r
"/library/io/buffer.factor"\r
\r
- "/library/httpd/load.factor"\r
"/library/sdl/load.factor"\r
"/library/opengl/load.factor"\r
"/library/freetype/load.factor"\r
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! A Smalltalk-like browser that runs in the httpd server using
-! cont-responder facilities.
-!
-IN: browser-responder
-USING: html cont-responder kernel io namespaces words lists prettyprint
- memory sequences ;
-
-: option ( current text -- )
- #! Output the HTML option tag for the given text. If
- #! it is equal to the current string, make the option selected.
- 2dup = [
- "<option selected>" write
- ] [
- "<option>" write
- ] if
- chars>entities write
- "</option>\n" write drop ;
-
-: vocab-list ( vocab -- )
- #! Write out the HTML for the list of vocabularies. Make the currently
- #! selected vocab be 'vocab'.
- <select "vocab" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
- vocabs [ over swap option ] each drop
- </select> ;
-
-: word-list ( vocab word -- )
- #! Write out the HTML for the list of words in a vocabulary. Make the 'word' item
- #! the currently selected option.
- <select "word" =name "width: 200" =style "20" =size "document.forms.main.submit()" =onchange select>
- swap words word-sort [ word-name over swap option ] each drop
- </select> ;
-
-: word-source ( vocab word -- )
- #! Write the source for the given word from the vocab as HTML.
- swap lookup [
- [ see ] with-simple-html-output
- ] when* ;
-
-: vm-statistics ( -- )
- #! Display statistics about the vm.
- <pre> room. </pre> ;
-
-: browser-body ( vocab word -- )
- #! Write out the HTML for the body of the main browser page.
- <table "100%" =width table>
- <tr>
- <td> <b> "Vocabularies" write </b> </td>
- <td> <b> "Words" write </b> </td>
- <td> <b> "Source" write </b> </td>
- </tr>
- <tr>
- <td "top" =valign "width: 200" =style td> over vocab-list </td>
- <td "top" =valign "width: 200" =style td> 2dup word-list </td>
- <td "top" =valign td> word-source </td>
- </tr>
- </table>
- vm-statistics ;
-
-: browser-title ( vocab word -- )
- #! Output the HTML title for the browser.
- <title>
- "Factor Browser - " write
- swap write
- " - " write
- write
- </title> ;
-
-: browser-style ( -- )
- #! Stylesheet for browser pages
- <style>
- "A:link { text-decoration:none}\n" write
- "A:visited { text-decoration:none}\n" write
- "A:active { text-decoration:none}\n" write
- "A:hover, A.nav:hover { border: 1px solid black; text-decoration: none; margin: 0px }\n" write
- "A { margin: 1px }" write
- </style> ;
-
-: browse ( vocab word -- )
- #! Display a Smalltalk like browser for exploring words.
- [
- <html>
- <head> 2dup browser-title browser-style </head>
- <body>
- <form "main" =name "" =action "get" =method form> browser-body </form>
- </body>
- </html>
- ] show-final ;
-
-: browser-responder ( -- )
- #! Start the Smalltalk-like browser.
- "query" get [
- [ "vocab" swap assoc ] keep
- "word" swap assoc
- ] [
- "browser-responder" "browse"
- ] if* browse ;
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-IN: cont-responder
-USING: http httpd math random namespaces io
- lists strings kernel html hashtables
- parser generic sequences ;
-
-#! Used inside the session state of responders to indicate whether the
-#! next request should use the post-refresh-get pattern. It is set to
-#! true after each request.
-SYMBOL: post-refresh-get?
-
-: expiry-timeout ( -- timeout-seconds )
- #! Number of seconds to timeout continuations in
- #! continuation table. This value will need to be
- #! tuned. I leave it at 24 hours but it can be
- #! higher/lower as needed. Default to 15 minutes for
- #! testing.
- 900 ;
-
-: get-random-id ( -- id )
- #! Generate a random id to use for continuation URL's
- [ 32 [ 9 random-int CHAR: 0 + , ] times ] "" make
- string>number 36 >base ;
-
-SYMBOL: table
-
-: continuation-table ( -- <hashtable> )
- #! Return the global table of continuations
- table global hash ;
-
-: reset-continuation-table ( -- )
- #! Create the initial global table
- continuation-table hash-clear ;
-
-{{ }} clone table global set-hash
-
-#! Tuple for holding data related to a continuation.
-TUPLE: item expire? quot id time-added ;
-
-: continuation-item ( expire? quot id -- <item> )
- #! A continuation item is the actual item stored
- #! in the continuation table. It contains the id,
- #! quotation/continuation, time added, etc. If
- #! expire? is true then the continuation will
- #! be expired after a certain amount of time.
- millis <item> ;
-
-: seconds>millis ( seconds -- millis )
- #! Convert a number of seconds to milliseconds
- 1000 * ;
-
-: expired? ( timeout-seconds <item> -- bool )
- #! Return true if the continuation item is expirable
- #! and has expired (ie. was added to the table more than
- #! timeout milliseconds ago).
- [ item-time-added swap seconds>millis + millis - 0 < ] keep item-expire? and ;
-
-: expire-continuations ( timeout-seconds -- )
- #! Expire all continuations in the continuation table
- #! if they are 'timeout-seconds' old (ie. were added
- #! more than 'timeout-seconds' ago.
- continuation-table clone [ ( timeout-seconds [[ id item ]] -- )
- uncons swapd expired? [
- continuation-table remove-hash
- ] [
- drop
- ] if
- ] hash-each-with ;
-
-: expirable ( quot -- t quot )
- #! Set the stack up for a register-continuation call
- #! so that the given quotation is registered that it can
- #! be expired.
- t swap ;
-
-: permanent ( quot -- f quot )
- #! Set the stack up for a register-continuation call
- #! so that the given quotation is never expired after
- #! registration.
- f swap ;
-
-: register-continuation ( expire? quot -- id )
- #! Store a continuation in the table and associate it with
- #! a random id. That continuation will be expired after
- #! a certain period of time if 'expire?' is true.
- get-random-id
- [ continuation-item ] keep ( item id -- )
- [ continuation-table set-hash ] keep ;
-
-: register-continuation* ( expire? quots -- id )
- #! Like register-continuation but registers a quotation
- #! that will call all quotations in the list, in the order given.
- concat register-continuation ;
-
-: get-continuation-item ( id -- <item> )
- #! Get the continuation item associated with the id.
- continuation-table hash ;
-
-: id>url ( id -- string )
- #! Convert the continuation id to an URL suitable for
- #! embedding in an HREF or other HTML.
- url-encode "?id=" swap append ;
-
-DEFER: show-final
-DEFER: show
-
-: expired-page-handler ( alist -- )
- #! Display a page has expired message.
- #! TODO: Need to handle this better to enable
- #! returning back to root continuation.
- drop
- [
- <html>
- <body>
- <p> "This page has expired." write </p>
- </body>
- </html>
- ] show-final ;
-
-: >callable ( quot|interp|f -- interp )
- dup continuation? [
- [ continue-with ] cons
- ] when ;
-
-: get-registered-continuation ( id -- cont )
- #! Return the continuation or quotation
- #! associated with the given id.
- #! TODO: handle expired pages better.
- expiry-timeout expire-continuations
- get-continuation-item [
- item-quot
- ] [
- [ expired-page-handler ]
- ] if* >callable ;
-
-: resume-continuation ( value id -- )
- #! Call the continuation associated with the given id,
- #! with 'value' on the top of the stack.
- get-registered-continuation call ;
-
-#! Name of the variable holding the continuation used to exit
-#! back to the httpd responder, returning any generated HTML.
-SYMBOL: exit-cc
-
-: exit-continuation ( -- exit )
- #! Get the current exit continuation
- exit-cc get ;
-
-: call-exit-continuation ( value -- )
- #! Call the exit continuation, passing it the given value on the
- #! top of the stack.
- exit-cc get continue-with ;
-
-: with-exit-continuation ( quot -- )
- #! Call the quotation with the variable exit-cc bound such that when
- #! the exit continuation is called, computation will resume from the
- #! end of this 'with-exit-continuation' call, with the value passed
- #! to the exit continuation on the top of the stack.
- [ exit-cc set call f call-exit-continuation ] callcc1 nip ;
-
-#! Name of variable holding the 'callback' continuation, used for
-#! returning back to previous 'show' calls.
-SYMBOL: callback-cc
-
-: store-callback-cc ( -- )
- #! Store the current continuation in the variable 'callback-cc'
- #! so it can be returned to later by callbacks. Note that it
- #! recalls itself when the continuation is called to ensure that
- #! it resets its value back to the most recent show call.
- [ ( 0 -- )
- [ ( 0 1 -- )
- callback-cc set ( 0 -- )
- continue
- ] callcc1 ( 0 [ ] == )
- nip
- call
- store-callback-cc
- ] callcc0 ;
-
-: forward-to-url ( url -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- [
- "HTTP/1.1 302 Document Moved\nLocation: " % %
- "\nContent-Length: 0\nContent-Type: text/plain\n\n" %
- ] "" make call-exit-continuation ;
-
-: forward-to-id ( id -- )
- #! When executed inside a 'show' call, this will force a
- #! HTTP 302 to occur to instruct the browser to forward to
- #! the request URL.
- >r "request" get r> id>url append forward-to-url ;
-
-: redirect-to-here ( -- )
- #! Force a redirect to the client browser so that the browser
- #! goes to the current point in the code. This forces an URL
- #! change on the browser so that refreshing that URL will
- #! immediately run from this code point. This prevents the
- #! "this request will issue a POST" warning from the browser
- #! and prevents re-running the previous POST logic. This is
- #! known as the 'post-refresh-get' pattern.
- post-refresh-get? get [
- [
- expirable register-continuation forward-to-id
- ] callcc1 drop
- ] [
- t post-refresh-get? set
- ] if ;
-
-: (show) ( quot -- namespace )
- #! See comments for show. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-callback-cc redirect-to-here
- [
- expirable register-continuation id>url swap
- string-out call-exit-continuation
- ] callcc1
- nip ;
-
-: show ( quot -- namespace )
- #! Call the quotation with the URL associated with the current
- #! continuation. Return the HTML string generated by that code
- #! to the exit continuation. When the URL is later referenced then
- #! computation will resume from this 'show' call with a namespace on
- #! the stack containing any query or post parameters.
- #! NOTE: On return from 'show' the stack is exactly the same as
- #! initial entry with 'quot' popped off an <namespace> put on. Even
- #! if the quotation consumes items on the stack.
- \ serving-html swons (show) ;
-
-: (show-final) ( quot -- namespace )
- #! See comments for show-final. The difference is the
- #! quotation MUST set the content-type using 'serving-html'
- #! or similar.
- store-callback-cc redirect-to-here
- string-out call-exit-continuation ;
-
-: show-final ( quot -- namespace )
- #! Similar to 'show', except the quotation does not receive the URL
- #! to resume computation following 'show-final'. No continuation is
- #! stored for this resumption. As a result, 'show-final' is for use
- #! when a page is to be displayed with no further action to occur. Its
- #! use is an optimisation to save having to generate and save a continuation
- #! in that special case.
- \ serving-html swons (show-final) ;
-
-#! Name of variable for holding initial continuation id that starts
-#! the responder.
-SYMBOL: root-continuation
-
-: id-or-root ( -- id )
- #! Return the continuation id for the current requested continuation
- #! or the root continuation if no id is supplied.
- "id" "query" get assoc [ root-continuation get ] unless* ;
-
-: cont-get/post-responder ( id-or-f -- )
- #! httpd responder that retrieves a continuation and calls it.
- #! The continuation id must be in a query parameter called 'id'.
- #! If it does not exist the root continuation is called. If
- #! no root continuation exists the expired continuation handler
- #! should be called.
- drop [
- "response" get alist>hash
- id-or-root [
- resume-continuation
- ] [
- expired-page-handler
- ] if*
- ] with-exit-continuation [ write flush ] when* ;
-
-: callback-quot ( quot -- quot )
- #! Convert the given quotation so it works as a callback
- #! by returning a quotation that will pass the original
- #! quotation to the callback continuation.
- [ , callback-cc get , \ continue-with , ] [ ] make ;
-
-: 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> ;
-
-: init-session-namespace ( -- )
- #! Setup the initial session namespace. Currently this only
- #! sets the redirect flag so that the initial request of the
- #! responder will not do a post-refresh-get style redirect.
- #! This prevents the initial request to a responder from redirecting
- #! to an URL with a continuation id. This word must be run from
- #! within the session namespace.
- f post-refresh-get? set ;
-
-: install-cont-responder ( name quot -- )
- #! Install a cont-responder with the given name
- #! that will initially run the given quotation.
- #!
- #! Convert the quotation so it is run within a session namespace
- #! and that namespace is initialized first.
- \ init-session-namespace swons [ , \ with-scope , ] [ ] make
- [
- [ cont-get/post-responder ] "get" set
- [ cont-get/post-responder ] "post" set
- swap "responder" set
- permanent register-continuation root-continuation set
- ] make-responder ;
-
-: simple-page ( title quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title.
- <html>
- <head> <title> swap write </title> </head>
- <body> call </body>
- </html> ;
-
-: styled-page ( title stylesheet-quot quot -- )
- #! Call the quotation, with all output going to the
- #! body of an html page with the given title. stylesheet-quot
- #! is called to generate the required stylesheet.
- <html>
- <head>
- <title> rot write </title>
- swap call
- </head>
- <body> call </body>
- </html> ;
-
-: paragraph ( str -- )
- #! Output the string as an html paragraph
- <p> write </p> ;
-
-: show-message-page ( message -- )
- #! Display the message in an HTML page with an OK button.
- [
- "Press OK to Continue" [
- swap paragraph
- <a =href a> "OK" write </a>
- ] simple-page
- ] show 2drop ;
-
-: vertical-layout ( list -- )
- #! Given a list of HTML components, arrange them vertically.
- <table>
- [ <tr> <td> call </td> </tr> ] each
- </table> ;
-
-: horizontal-layout ( list -- )
- #! Given a list of HTML components, arrange them horizontally.
- <table>
- <tr "top" =valign tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: 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> ;
-
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: httpd
-USING: browser-responder cont-responder file-responder kernel
-namespaces prettyprint quit-responder resource-responder
-test-responder ;
-
-#! Remove all existing responders, and create a blank
-#! responder table.
-global [
- {{ }} clone responders set
-
- ! 404 error message pages are served by this guy
- [
- "404" "responder" set
- [ drop no-such-responder ] "get" set
- ] make-responder
-
- ! Servers Factor word definitions from the image.
- "browser" [ browser-responder ] install-cont-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.
- [
- ! "/var/www/" "doc-root" set
- "file" "responder" set
- [ file-responder ] "get" set
- [ file-responder ] "post" set
- [ file-responder ] "head" set
- ] make-responder
-
- ! The root directory is served by...
- "file" set-default-responder
-
- vhosts nest [ {{ }} clone "default" set ] bind
-] bind
+++ /dev/null
-! Copyright (C) 2004,2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: file-responder
-USING: html httpd kernel lists math namespaces parser sequences
-io strings ;
-
-: serving-path ( filename -- filename )
- [ "" ] unless* "doc-root" get swap append ;
-
-: file-response ( mime-type length -- )
- [
- number>string "Content-Length" swons ,
- "Content-Type" swons ,
- ] [ ] make "200 OK" response terpri ;
-
-: serve-static ( filename mime-type -- )
- over file-length file-response "method" get "head" = [
- drop
- ] [
- <file-reader> stdio get stream-copy
- ] if ;
-
-: serve-file ( filename -- )
- dup mime-type dup "application/x-factor-server-page" = [
- drop run-file
- ] [
- serve-static
- ] if ;
-
-: list-directory ( directory -- )
- serving-html
- "method" get "head" = [
- drop
- ] [
- "request" get [ directory. ] simple-html-document
- ] if ;
-
-: serve-directory ( filename -- )
- "/" ?tail [
- dup "/index.html" append dup exists? [
- nip serve-file
- ] [
- drop list-directory
- ] if
- ] [
- drop directory-no/
- ] if ;
-
-: serve-object ( filename -- )
- dup directory? [ serve-directory ] [ serve-file ] if ;
-
-: file-responder ( filename -- )
- "doc-root" get [
- serving-path dup exists? [
- serve-object
- ] [
- drop "404 not found" httpd-error
- ] if
- ] [
- drop "404 doc-root not set" httpd-error
- ] if ;
+++ /dev/null
-! cont-html v0.6
-!
-! Copyright (C) 2004 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-
-IN: html
-USING: prettyprint ;
-USE: strings
-USE: lists
-USE: kernel
-USE: io
-USE: namespaces
-USE: words
-USE: sequences
-
-! These words are used to provide a means of writing
-! formatted HTML to standard output with a familiar 'html' look
-! and feel in the code.
-!
-! HTML tags can be used in a number of different ways. The highest
-! level involves a similar syntax to HTML:
-!
-! <p> "someoutput" write </p>
-!
-! <p> will output the opening tag and </p> will output the closing
-! tag with no attributes.
-!
-! <p "red" =class p> "someoutput" write </p>
-!
-! This time the opening tag does not have the '>'. It pushes
-! a namespace on the stack to hold the attributes and values.
-! Any attribute words used will store the attribute and values
-! in that namespace. Before the attribute word should come the
-! value of that attribute.
-! The finishing word will print out the operning tag including
-! attributes.
-! Any writes after this will appear after the opening tag.
-!
-! Values for attributes can be used directly without any stack
-! operations:
-!
-! (url -- )
-! <a =href a> "Click me" write </a>
-!
-! (url -- )
-! <a "http://" swap append =href a> "click" write </a>
-!
-! (url -- )
-! <a [ "http://" % % ] "" make =href a> "click" write </a>
-!
-! Tags that have no 'closing' equivalent have a trailing tag/> form:
-!
-! <input "text" =type "name" =name "20" =size input/>
-
-: attrs>string ( alist -- string )
- #! Convert the attrs alist to a string
- #! suitable for embedding in an html tag.
- [ [ " " % dup car % "='" % cdr % "'" % ] each ] "" make ;
-
-: write-attributes ( n: namespace -- )
- #! With the attribute namespace on the stack, get the attributes
- #! and write them to standard output. If no attributes exist, write
- #! nothing.
- "attrs" get attrs>string write ;
-
-: html-word ( name def -- )
- #! Define 'word creating' word to allow
- #! dynamically creating words.
- >r "html" create dup r> define-compound ;
-
-: <foo> "<" swap ">" append3 ;
-
-: do-<foo> <foo> write ;
-
-: def-for-html-word-<foo> ( name -- )
- #! Return the name and code for the <foo> patterned
- #! word.
- dup <foo> swap [ do-<foo> ] cons html-word define-open ;
-
-: <foo "<" swap append ;
-
-: do-<foo write {{ }} clone >n { } clone "attrs" set ;
-
-: def-for-html-word-<foo ( name -- )
- #! Return the name and code for the <foo patterned
- #! word.
- <foo dup [ do-<foo ] cons html-word drop ;
-
-: foo> ">" append ;
-
-: do-foo> write-attributes n> drop ">" write ;
-
-: def-for-html-word-foo> ( name -- )
- #! Return the name and code for the foo> patterned
- #! word.
- foo> [ do-foo> ] html-word define-open ;
-
-: </foo> [ "</" % % ">" % ] "" make ;
-
-: def-for-html-word-</foo> ( name -- )
- #! Return the name and code for the </foo> patterned
- #! word.
- </foo> dup [ write ] cons html-word define-close ;
-
-: <foo/> [ "<" % % "/>" % ] "" make ;
-
-: def-for-html-word-<foo/> ( name -- )
- #! Return the name and code for the <foo/> patterned
- #! word.
- dup <foo/> swap [ do-<foo> ] cons html-word drop ;
-
-: foo/> "/>" append ;
-
-: def-for-html-word-foo/> ( name -- )
- #! Return the name and code for the foo/> patterned
- #! word.
- foo/> [ do-foo> ] html-word define-close ;
-
-: define-closed-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that closable HTML tag.
- dup def-for-html-word-<foo>
- dup def-for-html-word-<foo
- dup def-for-html-word-foo>
- def-for-html-word-</foo> ;
-
-: define-open-html-word ( name -- )
- #! Given an HTML tag name, define the words for
- #! that open HTML tag.
- dup def-for-html-word-<foo/>
- dup def-for-html-word-<foo
- def-for-html-word-foo/> ;
-
-: define-attribute-word ( name -- )
- dup "=" swap append swap [
- , [ swons "attrs" get push ] %
- ] [ ] make html-word drop ;
-
-! Define some closed HTML tags
-[
- "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9"
- "ol" "li" "form" "a" "p" "html" "head" "body" "title"
- "b" "i" "ul" "table" "tr" "td" "th" "pre" "textarea"
- "script" "div" "span" "select" "option" "style"
-] [ define-closed-html-word ] each
-
-! Define some open HTML tags
-[
- "input"
- "br"
- "link"
- "img"
-] [ define-open-html-word ] each
-
-! Define some attributes
-[
- "method" "action" "type" "value" "name"
- "size" "href" "class" "border" "rows" "cols"
- "id" "onclick" "style" "valign" "accesskey"
- "src" "language" "colspan" "onchange" "rel"
- "width"
-] [ define-attribute-word ] each
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: html
-USING: generic http io kernel lists math namespaces
-presentation sequences strings styles words ;
-
-: html-entities ( -- alist )
- [
- [[ CHAR: < "<" ]]
- [[ CHAR: > ">" ]]
- [[ CHAR: & "&" ]]
- [[ CHAR: ' "'" ]]
- [[ CHAR: " """ ]]
- ] ;
-
-: chars>entities ( str -- str )
- #! Convert <, >, &, ' and " to HTML entities.
- [
- [ dup html-entities assoc [ % ] [ , ] ?if ] each
- ] "" make ;
-
-: hex-color, ( triplet -- )
- [ >hex 2 CHAR: 0 pad-left % ] each ;
-
-: fg-css, ( color -- )
- "color: #" % hex-color, "; " % ;
-
-: style-css, ( flag -- )
- dup [ italic bold-italic ] member?
- [ "font-style: italic; " % ] when
- [ bold bold-italic ] member?
- [ "font-weight: bold; " % ] when ;
-
-: underline-css, ( flag -- )
- [ "text-decoration: underline; " % ] when ;
-
-: size-css, ( size -- )
- "font-size: " % # "; " % ;
-
-: font-css, ( font -- )
- "font-family: " % % "; " % ;
-
-: css-style ( style -- )
- [
- [
- [ foreground fg-css, ]
- [ font font-css, ]
- [ font-style style-css, ]
- [ font-size size-css, ]
- [ underline underline-css, ]
- ] assoc-apply
- ] "" make ;
-
-: span-tag ( style quot -- )
- over css-style dup "" = [
- drop call
- ] [
- <span =style span> call </span>
- ] if ;
-
-: resolve-file-link ( path -- link )
- #! The file responder needs relative links not absolute
- #! links.
- "doc-root" get [
- ?head [ "/" ?head drop ] when
- ] when* "/" ?tail drop ;
-
-: file-link-href ( path -- href )
- [ "/" % resolve-file-link url-encode % ] "" make ;
-
-: file-link-tag ( style quot -- )
- over file swap assoc [
- <a file-link-href =href a> call </a>
- ] [
- call
- ] if* ;
-
-: browser-link-href ( word -- href )
- dup word-name swap word-vocabulary
- [
- "/responder/browser/?vocab=" %
- url-encode %
- "&word=" %
- url-encode %
- ] "" make ;
-
-: browser-link-tag ( style quot -- style )
- over presented swap assoc dup word? [
- <a browser-link-href =href a> call </a>
- ] [
- drop call
- ] if ;
-
-TUPLE: html-stream ;
-
-M: html-stream stream-write1 ( char stream -- )
- [
- dup html-entities assoc [ write ] [ write1 ] ?if
- ] with-wrapper ;
-
-M: html-stream stream-format ( str style stream -- )
- [
- [
- [
- [ drop chars>entities write ] span-tag
- ] file-link-tag
- ] browser-link-tag
- ] with-wrapper ;
-
-C: html-stream ( stream -- stream )
- #! Wraps the given stream in an HTML stream. An HTML stream
- #! converts special characters to entities when being
- #! written, and supports writing attributed strings with
- #! the following attributes:
- #!
- #! foreground - an rgb triplet in a list
- #! background - an rgb triplet in a list
- #! font
- #! font-style
- #! font-size
- #! underline
- #! file
- #! word
- #! vocab
- [ >r <wrapper-stream> r> set-delegate ] keep ;
-
-: with-html-stream ( quot -- )
- [ stdio [ <html-stream> ] change call ] with-scope ;
-
-: html-document ( title quot -- )
- swap chars>entities dup
- <html>
- <head>
- <title> write </title>
- </head>
- <body>
- <h1> write </h1>
- call
- </body>
- </html> ;
-
-: simple-html-document ( title quot -- )
- swap [ <pre> with-html-stream </pre> ] html-document ;
+++ /dev/null
-! Copyright (C) 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: http-client
-USING: errors http kernel lists math namespaces parser sequences
-io strings ;
-
-: parse-host ( url -- host port )
- #! Extract the host name and port number from an HTTP URL.
- ":" split1 [ string>number ] [ 80 ] if* ;
-
-: parse-url ( url -- host resource )
- "http://" ?head [
- "URL must begin with http://" throw
- ] unless
- "/" split1 [ "/" swap append ] [ "/" ] if* ;
-
-: parse-response ( line -- code )
- "HTTP/" ?head [ " " split1 nip ] when
- " " split1 drop string>number ;
-
-: read-response ( -- code header )
- #! After sending a GET oR POST we read a response line and
- #! header.
- flush readln parse-response read-header ;
-
-: crlf "\r\n" write ;
-
-: http-request ( host resource method -- )
- write " " write write " HTTP/1.0" write crlf
- "Host: " write write crlf ;
-
-: get-request ( host resource -- )
- "GET" http-request crlf ;
-
-DEFER: http-get
-
-: do-redirect ( code headers stream -- code headers stream )
- #! Should this support Location: headers that are
- #! relative URLs?
- pick 302 = [
- stream-close "Location" swap assoc nip http-get
- ] when ;
-
-: http-get ( url -- code headers stream )
- #! Opens a stream for reading from an HTTP URL.
- parse-url over parse-host <client> [
- [ get-request read-response ] with-stream*
- ] keep do-redirect ;
-
-: download ( url file -- )
- #! Downloads the contents of a URL to a file.
- >r http-get 2nip r> <file-writer> stream-copy ;
-
-: post-request ( content-type content host resource -- )
- #! Note: It is up to the caller to url encode the content if
- #! it is required according to the content-type.
- "POST" http-request [
- "Content-Length: " write length number>string write crlf
- "Content-Type: " write url-encode write crlf
- crlf
- ] keep write ;
-
-: http-post ( content-type content url -- code headers stream )
- #! Make a POST request. The content is URL encoded for you.
- parse-url over parse-host <client> [
- [ post-request flush read-response ] with-stream*
- ] keep ;
+++ /dev/null
-! Copyright (C) 2003, 2005 Slava Pestov
-IN: http
-USING: errors kernel lists math namespaces parser sequences
-io strings ;
-
-: header-line ( alist line -- alist )
- ": " split1 dup [ cons swons ] [ 2drop ] if ;
-
-: (read-header) ( alist -- alist )
- readln dup
- empty? [ drop ] [ header-line (read-header) ] if ;
-
-: read-header ( -- alist )
- [ ] (read-header) ;
-
-: url-encode ( str -- str )
- [
- [
- dup url-quotable? [
- ,
- ] [
- CHAR: % , >hex 2 CHAR: 0 pad-left %
- ] if
- ] each
- ] "" make ;
-
-: catch-hex> ( str -- n/f )
- #! Push f if string is not a valid hex literal.
- [ hex> ] catch [ drop f ] when ;
-
-: url-decode-hex ( index str -- )
- 2dup length 2 - >= [
- 2drop
- ] [
- >r 1+ dup 2 + r> subseq catch-hex> [ , ] when*
- ] if ;
-
-: url-decode-% ( index str -- index str )
- 2dup url-decode-hex >r 3 + r> ;
-
-: url-decode-+-or-other ( index str ch -- index str )
- dup CHAR: + = [ drop CHAR: \s ] when , >r 1+ r> ;
-
-: url-decode-iter ( index str -- )
- 2dup length >= [
- 2drop
- ] [
- 2dup nth dup CHAR: % = [
- drop url-decode-%
- ] [
- url-decode-+-or-other
- ] if url-decode-iter
- ] if ;
-
-: url-decode ( str -- str )
- [ 0 swap url-decode-iter ] "" make ;
+++ /dev/null
-! Copyright (C) 2003, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: httpd
-USING: errors kernel lists namespaces io strings threads http
-sequences ;
-
-: (url>path) ( uri -- path )
- url-decode "http://" ?head [
- "/" split1 dup "" ? nip
- ] when ;
-
-: url>path ( uri -- path )
- "?" split1 dup [
- >r (url>path) "?" r> append3
- ] [
- drop (url>path)
- ] if ;
-
-: secure-path ( path -- path )
- ".." over subseq? [ drop f ] when ;
-
-: request-method ( cmd -- method )
- [
- [[ "GET" "get" ]]
- [[ "POST" "post" ]]
- [[ "HEAD" "head" ]]
- ] assoc [ "bad" ] unless* ;
-
-: host ( -- string )
- #! The host the current responder was called from.
- "Host" "header" get assoc ":" split1 drop ;
-
-: (handle-request) ( arg cmd -- method path host )
- request-method dup "method" set swap
- prepare-url prepare-header host ;
-
-: handle-request ( arg cmd -- )
- [ (handle-request) serve-responder ] with-scope ;
-
-: parse-request ( request -- )
- dup log-message
- " " split1 dup [
- " HTTP" split1 drop url>path secure-path dup [
- swap handle-request
- ] [
- 2drop bad-request
- ] if
- ] [
- 2drop bad-request
- ] if ;
-
-: httpd ( port -- )
- \ httpd [
- 60000 stdio get set-timeout
- readln [ parse-request ] when*
- ] with-server ;
-
-: stop-httpd ( -- )
- #! Stop the server.
- \ httpd get stream-close ;
+++ /dev/null
-USING: kernel parser sequences io ;
-[
- "/library/httpd/http-common.factor"
- "/library/httpd/mime.factor"
- "/library/httpd/html-tags.factor"
- "/library/httpd/html.factor"
- "/library/httpd/responder.factor"
- "/library/httpd/httpd.factor"
- "/library/httpd/file-responder.factor"
- "/library/httpd/cont-responder.factor"
- "/library/httpd/browser-responder.factor"
- "/library/httpd/default-responders.factor"
- "/library/httpd/http-client.factor"
-] [
- dup print run-resource
-] each
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: httpd
-USING: io hashtables kernel lists namespaces ;
-
-: set-mime-types ( assoc -- )
- "mime-types" global set-hash ;
-
-: mime-types ( -- assoc )
- "mime-types" global hash ;
-
-: mime-type ( filename -- mime-type )
- file-extension mime-types assoc [ "text/plain" ] unless* ;
-
-[
- [[ "html" "text/html" ]]
- [[ "txt" "text/plain" ]]
- [[ "xml" "text/xml" ]]
- [[ "css" "text/css" ]]
-
- [[ "gif" "image/gif" ]]
- [[ "png" "image/png" ]]
- [[ "jpg" "image/jpeg" ]]
- [[ "jpeg" "image/jpeg" ]]
-
- [[ "jar" "application/octet-stream" ]]
- [[ "zip" "application/octet-stream" ]]
- [[ "tgz" "application/octet-stream" ]]
- [[ "tar.gz" "application/octet-stream" ]]
- [[ "gz" "application/octet-stream" ]]
-
- [[ "factor" "application/x-factor" ]]
- [[ "factsp" "application/x-factor-server-page" ]]
-] set-mime-types
+++ /dev/null
-! Copyright (C) 2004, 2005 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
-IN: httpd
-USING: hashtables http kernel lists math namespaces parser
-sequences io strings ;
-
-! Variables
-SYMBOL: vhosts
-SYMBOL: responders
-
-: print-header ( alist -- )
- [ unswons write ": " write url-encode print ] each ;
-
-: response ( header msg -- )
- "HTTP/1.0 " write print print-header ;
-
-: error-body ( error -- body )
- "<html><body><h1>" swap "</h1></body></html>" append3 print ;
-
-: error-head ( error -- )
- dup log-error
- [ [[ "Content-Type" "text/html" ]] ] over response ;
-
-: httpd-error ( error -- )
- #! This must be run from handle-request
- error-head
- "head" "method" get = [ drop ] [ terpri error-body ] if ;
-
-: bad-request ( -- )
- [
- ! Make httpd-error print a body
- "get" "method" set
- "400 Bad request" httpd-error
- ] with-scope ;
-
-: serving-content ( mime -- )
- "Content-Type" swons unit
- "200 Document follows" response terpri ;
-
-: serving-html "text/html" serving-content ;
-
-: serving-text "text/plain" serving-content ;
-
-: redirect ( to -- )
- "Location" swons unit
- "301 Moved Permanently" response terpri ;
-
-: directory-no/ ( -- )
- [
- "request" get % CHAR: / ,
- "raw-query" get [ CHAR: ? , % ] when*
- ] "" make redirect ;
-
-: query>alist ( query -- alist )
- dup [
- "&" split [
- "=" split1
- dup [ url-decode ] when swap
- dup [ url-decode ] when swap cons
- ] map
- ] when ;
-
-: read-post-request ( header -- alist )
- "Content-Length" swap assoc dup
- [ string>number read query>alist ] when ;
-
-: log-user-agent ( alist -- )
- "User-Agent" swap assoc* [
- unswons [ % ": " % % ] "" make log-message
- ] when* ;
-
-: prepare-url ( url -- url )
- #! This is executed in the with-request namespace.
- "?" split1
- dup "raw-query" set query>alist "query" set
- dup "request" set ;
-
-: prepare-header ( -- )
- read-header dup "header" set
- dup log-user-agent
- read-post-request "response" set ;
-
-! Responders are called in a new namespace with these
-! variables:
-
-! - method -- one of get, post, or head.
-! - request -- the entire URL requested, including responder
-! name
-! - raw-query -- raw query string
-! - query -- an alist of query parameters, eg
-! foo.bar?a=b&c=d becomes
-! [ [[ "a" "b" ]] [[ "c" "d" ]] ]
-! - header -- an alist of headers from the user's client
-! - response -- an alist of the POST request response
-
-: add-responder ( responder -- )
- #! Add a responder object to the list.
- "responder" over hash responders get set-hash ;
-
-: make-responder ( quot -- responder )
- [
- ( url -- )
- [
- drop "GET method not implemented" httpd-error
- ] "get" set
- ( url -- )
- [
- drop "POST method not implemented" httpd-error
- ] "post" set
- ( url -- )
- [
- drop "HEAD method not implemented" httpd-error
- ] "head" set
- ( url -- )
- [
- drop bad-request
- ] "bad" set
-
- call
- ] make-hash add-responder ;
-
-: vhost ( name -- responder )
- vhosts get hash [ "default" vhost ] unless* ;
-
-: responder ( name -- responder )
- responders get hash [ "404" responder ] unless* ;
-
-: set-default-responder ( name -- )
- responder "default" responders get set-hash ;
-
-: responder-argument ( argument -- argument )
- dup empty? [ drop "default-argument" get ] when ;
-
-: call-responder ( method argument responder -- )
- [ responder-argument swap get call ] bind ;
-
-: serve-default-responder ( method url -- )
- "default" responder call-responder ;
-
-: log-responder ( path -- )
- "Calling responder " swap append log-message ;
-
-: trim-/ ( url -- url )
- #! Trim a leading /, if there is one.
- "/" ?head drop ;
-
-: serve-explicit-responder ( method url -- )
- "/" split1 dup [
- swap responder call-responder
- ] [
- ! Just a responder name by itself
- drop "request" get "/" append redirect drop
- ] if ;
-
-: serve-responder ( method path host -- )
- #! Responder paths come in two forms:
- #! /foo/bar... - default responder used
- #! /responder/foo/bar - responder foo, argument bar
- vhost [
- dup log-responder trim-/ "responder/" ?head [
- serve-explicit-responder
- ] [
- serve-default-responder
- ] if
- ] bind ;
-
-: no-such-responder ( -- )
- "404 No such responder" httpd-error ;
projects / factor.git / commitdiff