+++ /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.
-!
-! An Smalltalk-link browser that runs in the httpd server using
-! cont-responder facilities.
-!
-IN: browser
-USE: html
-USE: cont-responder
-USE: cont-utils
-USE: kernel
-USE: stdio
-USE: namespaces
-USE: words
-USE: lists
-USE: streams
-USE: strings
-USE: inspector
-USE: kernel
-USE: prettyprint
-USE: words
-USE: html
-USE: parser
-USE: errors
-USE: unparser
-USE: logging
-USE: listener
-USE: url-encoding
-USE: hashtables
-
-: <browser> ( allow-edit? vocab word -- )
- #! An object for storing the current browser
- #! user interface state.
- <namespace> [
- "current-word" set
- "current-vocab" set
- "allow-edit?" set
- ] extend ;
-
-: write-vocab-list ( -- )
- #! Write out the HTML for the list of vocabularies
- <select name= "vocabs" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
- vocabs [
- dup "current-vocab" get [ "" ] unless* = [
- "<option selected>" write
- ] [
- "<option>" write
- ] ifte
- chars>entities write
- "</option>\n" write
- ] each
- </select> ;
-
-: write-word-list ( vocab -- )
- #! Write out the HTML for the list of words in a vocabulary.
- <select name= "words" style= "width: 200" size= "20" onchange= "document.forms.main.submit()" select>
- words [
- word-name dup "current-word" get [ "" ] unless* str-compare 0 = [
- "<option selected>" write
- ] [
- "<option>" write
- ] ifte
- chars>entities write
- "</option>\n" write
- ] each
- </select> ;
-
-: write-editable-word-source ( vocab word -- )
- #! Write the source in a manner allowing it to be edited.
- <textarea name= "eval" rows= "30" cols= "80" textarea>
- 1024 <string-output> dup >r [
- >r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop
- ] with-stream r> stream>str chars>entities write
- </textarea> <br/>
- "Accept" button ;
-
-: write-word-source ( vocab word -- )
- #! Write the source for the given word from the vocab as HTML.
- <namespace> [
- "responder" "inspect" put
- "allow-edit?" get [ "Edit" [ "edit-state" t put ] quot-href <br/> ] when
- "edit-state" get [
- write-editable-word-source
- ] [
- 2dup swap unit search [
- [
- >r words r> swap [ over swap dup word-name rot = [ see ] [ drop ] ifte ] each drop
- ] with-simple-html-output
- ] when
- ] ifte
- ] bind drop ;
-
-: write-vm-statistics ( -- )
- #! Display statistics about the vm.
- <pre> room. </pre> ;
-
-: write-browser-body ( -- )
- #! Write out the HTML for the body of the main browser page.
- <table width= "100%" table>
- <tr>
- <td> "<b>Vocabularies</b>" write </td>
- <td> "<b>Words</b>" write </td>
- <td> "<b>Source</b>" write </td>
- </tr>
- <tr>
- <td valign= "top" style= "width: 200" td> write-vocab-list </td>
- <td valign= "top" style= "width: 200" td> "current-vocab" get write-word-list </td>
- <td valign= "top" td> "current-vocab" get "current-word" get write-word-source </td>
- </tr>
- </table>
- write-vm-statistics ;
-
-: flatten ( tree - list )
- #! Flatten a tree into a list.
- dup f = [
- ] [
- dup cons? [
- dup car flatten swap cdr flatten append
- ] [
- [ ] cons
- ] ifte
- ] ifte ;
-
-: word-uses ( word -- list )
- #! Return a list of vocabularies that the given word uses.
- word-parameter flatten [ word? ] subset [
- word-vocabulary
- ] map ;
-
-: vocabulary-uses ( vocab -- list )
- #! Return a list of vocabularies that all words in a vocabulary
- #! uses.
- <namespace> [
- "result" f put
- words [
- word-uses [
- "result" unique@
- ] each
- ] each
- "result" get
- ] bind ;
-
-: build-eval-string ( vocab to-eval -- string )
- #! Build a string that can evaluate the string 'to-eval'
- #! by first doing an 'IN: vocab' and a 'USE:' of all
- #! necessary vocabs for existing words in that vocab.
- [ >r "IN: " , dup , "\n" ,
- vocabulary-uses [ "USE: " , , "\n" , ] each
- r> , "\n" , ] make-string ;
-
-: show-parse-error ( error -- )
- #! Show an error page describing the parse error.
- [
- <html>
- <head> <title> "Parse error" write </title> </head>
- <body>
- swap [ write ] with-simple-html-output
- <a href= a> "Ok" write </a>
- </body>
- </html>
- ] show drop drop ;
-
-: eval-string ( vocab to-eval -- )
- #! Evaluate the 'to-eval' within the given vocabulary.
- build-eval-string [
- parse call
- ] [
- [
- show-parse-error
- drop
- ] when*
- ] catch ;
-
-: browser-url ( vocab word -- url )
- #! Given a vocabulary and word as strings, return a browser
- #! URL which, when requested, will display the source to that
- #! word.
- [
- ".?word=" , url-encode ,
- "&vocab=" , url-encode ,
- ] make-string ;
-
-: browse ( <browser> -- )
- #! Display a Smalltalk like browser for exploring/modifying words.
- [
- [
- <html>
- <head>
- <title> "Factor Browser" write </title>
- </head>
- <body>
- <form name= "main" action= method= "post" form>
- write-browser-body
- </form>
- </body>
- </html>
- ] show [
- "allow-edit?" get [
- "eval" get [
- "eval" f put
- "Editing has been disabled." show-message-page
- ] when
- ] unless
- "allow-edit?" get "allow-edit?" set
- ] extend
- ] bind [
- "allow-edit?" get
- "vocabs" get
- "words" get
- "eval" get dup [ "vocabs" get swap eval-string ] [ drop ] ifte
- [
- "vocabs" get dup [ ] [ drop "unknown" ] ifte "words" get dup [ ] [ drop "unknown" ] ifte browser-url
- forward-to-url
- ] show
- ] bind <browser> ;
-
-: browser-responder ( allow-edit? -- )
- #! Start the Smalltalk-like browser.
- "query" get dup [
- dup >r "vocab" swap assoc r> "word" swap assoc
- ] [
- drop "browser" f
- ] ifte <browser> browse ;
-
-"browser" [ f browser-responder ] install-cont-responder
-! "browser-edit" [ t browser-responder ] install-cont-responder
+++ /dev/null
-! cont-responder
-!
-! 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
-USE: stdio
-USE: httpd
-USE: httpd-responder
-USE: math
-USE: random
-USE: namespaces
-USE: streams
-USE: lists
-USE: strings
-USE: html
-USE: kernel
-USE: html
-USE: logging
-USE: url-encoding
-USE: unparser
-USE: hashtables
-USE: parser
-USE: prettyprint
-USE: inspector
-
-: 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 1 hour for
- #! testing.
- 3600 ;
-
-: redirect-enabled?
- #! Set to true if you want the post-redirect-get pattern
- #! implemented. See the redirect-to-here word for details.
- t ;
-
-: get-random-id ( -- id )
- #! Generate a random id to use for continuation URL's
- [ 32 [ random-digit unparse , ] times ] make-string str>number 36 >base ;
-
-: continuation-table ( -- <namespace> )
- #! Return the global table of continuations
- "continuation-table" get ;
-
-: reset-continuation-table ( -- )
- #! Create the initial global table
- <namespace> "continuation-table" set ;
-
-: 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.
- <namespace> [
- "id" set
- "quot" set
- "expire?" set
- millis "time-added" set
- ] extend ;
-
-: 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).
- [ seconds>millis "time-added" get + millis - 0 <
- "expire?" get and
- ] bind ;
-
-: continuation-items ( -- alist )
- #! Return an alist of all continuation items in the continuation
- #! table with the car as the id and the cdr as the item.
- continuation-table hash>alist ;
-
-: 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-items [ cdr dupd expired? not ] subset nip
- alist>hash "continuation-table" set ;
-
-: 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.
- continuation-table [
- get-random-id -rot pick continuation-item over set
- ] bind ;
-
-: append* ( lists -- list )
- #! Given a list of lists, append the lists together
- #! and return the concatenated list.
- f swap [ append ] each ;
-
-: register-continuation* ( expire? quots -- id )
- #! Like register-continuation but registers a quotation
- #! that will call all quotations in the list, in the order given.
- append* register-continuation ;
-
-: get-continuation-item ( id -- <item> )
- #! Get the continuation item associated with the id.
- continuation-table [ get ] bind ;
-
-: id>url ( id -- string )
- #! Convert the continuation id to an URL suitable for
- #! embedding in an HREF or other HTML.
- url-encode "?id=" swap cat2 ;
-
-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
- [
- drop
- <html>
- <body>
- <p> "This page has expired." write </p>
- </body>
- </html>
- ] show drop ;
-
-: 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 dup [
- [ "quot" get ] bind
- ] [
- drop [ expired-page-handler ]
- ] ifte ;
-
-: resume-continuation ( value id -- )
- #! Call the continuation associated with the given id,
- #! with 'value' on the top of the stack.
- get-registered-continuation call ;
-
-: exit-continuation ( -- exit )
- #! Get the current exit continuation
- "exit" get ;
-
-: call-exit-continuation ( value -- )
- #! Call the exit continuation, passing it the given value on the
- #! top of the stack.
- "exit" get call ;
-
-: with-exit-continuation ( quot -- )
- #! Call the quotation with the variable "exit" 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" set call f call-exit-continuation ] callcc1 nip ;
-
-: 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 -- )
- call
- ] callcc1 ( 0 [ ] == )
- nip
- call
- store-callback-cc
- ] callcc0 ;
-
-: with-string-stream ( quot -- string )
- #! Call the quotation with standard output bound to a string output
- #! stream. Return the string on exit.
- 1024 <string-output> dup >r swap with-stream r> stream>str ;
-
-: 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/plan\n\n" ,
- ] make-string call-exit-continuation ;
-
-: 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.
- "disable-initial-redirect?" get [
- "disable-initial-redirect?" f put
- ] [
- [
- t swap register-continuation
- [ "HTTP/1.1 302 Document Moved\nLocation: " , id>url , "\n" ,
- "Content-Length: 0\nContent-Type: text/plain\n\n" , ] make-string
- call-exit-continuation
- ] callcc1 drop
- ] ifte ;
-
-: 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.
- store-callback-cc
- redirect-enabled? [ redirect-to-here ] when
- [
- t swap register-continuation id>url swap
- [ serving-html ] car swons with-string-stream
- call-exit-continuation
- ] callcc1
- nip ;
-
-
-: cont-get-responder ( id-or-f -- )
- #! httpd responder that retrieves a continuation and calls it.
- drop
- "id" "query" get assoc
- dup f-or-"" [
- #! No continuation id given
- drop "root-continuation" get dup [
- #! Use the root continuation
- [ f swap resume-continuation ] with-exit-continuation
- ] [
- #! No root continuation either
- drop [ f expired-page-handler ] with-exit-continuation
- ] ifte
- ] [
- #! Use the given continuation
- [ f swap resume-continuation ] with-exit-continuation
- ] ifte
- [ write flush ] when* drop ;
-
-: cont-post-responder ( id -- )
- #! httpd responder that retrieves a continuation for the given
- #! id and calls it with the POST data as a hashtable on the top
- #! of the stack.
- [
- drop
- "response" get alist>hash
- "id" "query" get assoc resume-continuation
- ] with-exit-continuation
- print drop ;
-
-: 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.
- unit "callback-cc" get [ call ] cons append ;
-
-: 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 href= callback-quot t swap register-continuation id>url a> write </a> ;
-
-: with-new-session ( quot -- )
- #! Each cont-responder is bound inside their own
- #! namespace for storing session state. Run the given
- #! quotation inside a new namespace for this purpose.
- <namespace> swap bind ;
-
-: init-session-namespace ( -- )
- #! Setup the initial session namespace. Currently this only
- #! copies the global value of whether the initial redirect
- #! will be disabled. It assumes the session namespace is
- #! topmost on the namespace stack.
- "disable-initial-redirect?" get "disable-initial-redirect?" 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 ] swap append unit [ with-new-session ] append
- "httpd-responders" get [
- <responder> [
- [ cont-get-responder ] "get" set
- [ cont-post-responder ] "post" set
- over "responder-name" set
- over "responder" set
- reset-continuation-table
- "disable-initial-redirect?" t put
- ] extend dup >r rot set
- r> [
- f swap register-continuation "root-continuation" set
- ] bind
- ] bind ;
-
-
+++ /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.
-!
-! General purpose words for display pages using the continuation
-! based responder.
-IN: cont-utils
-USE: html
-USE: cont-responder
-USE: lists
-USE: stdio
-USE: kernel
-USE: namespaces
-USE: html
-
-: 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 valign= "top" tr> [ <td> call </td> ] each </tr>
- </table> ;
-
-: button ( label -- )
- #! Output an HTML submit button with the given label.
- <input type= "submit" 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> ;
projects / factor.git / commitdiff