--- /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
+USE: html
+USE: cont-responder
+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" "browser" 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-responder" "<browser>"
+ ] ifte <browser> browse ;
+
+! "browser-edit" [ t browser-responder ] install-cont-responder
--- /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
+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 12 hours for
+ #! testing.
+ 12 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 ;
+
+: 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