From 24b2777a890522d8a600777cff05bc8192a72b95 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Tue, 15 Feb 2005 02:56:46 +0000 Subject: [PATCH] Remove uneeded files. --- contrib/cont-responder/browser.factor | 246 -------------- contrib/cont-responder/cont-responder.factor | 328 ------------------- contrib/cont-responder/cont-utils.factor | 91 ----- 3 files changed, 665 deletions(-) delete mode 100644 contrib/cont-responder/browser.factor delete mode 100644 contrib/cont-responder/cont-responder.factor delete mode 100644 contrib/cont-responder/cont-utils.factor diff --git a/contrib/cont-responder/browser.factor b/contrib/cont-responder/browser.factor deleted file mode 100644 index 4e7992f9fa..0000000000 --- a/contrib/cont-responder/browser.factor +++ /dev/null @@ -1,246 +0,0 @@ -! 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 - -: ( allow-edit? vocab word -- ) - #! An object for storing the current browser - #! user interface state. - [ - "current-word" set - "current-vocab" set - "allow-edit?" set - ] extend ; - -: write-vocab-list ( -- ) - #! Write out the HTML for the list of vocabularies - ; - -: write-word-list ( vocab -- ) - #! Write out the HTML for the list of words in a vocabulary. - ; - -: write-editable-word-source ( vocab word -- ) - #! Write the source in a manner allowing it to be edited. -
- "Accept" button ; - -: write-word-source ( vocab word -- ) - #! Write the source for the given word from the vocab as HTML. - [ - "responder" "inspect" put - "allow-edit?" get [ "Edit" [ "edit-state" t put ] quot-href
] 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. - 
 room.
; - -: write-browser-body ( -- ) - #! Write out the HTML for the body of the main browser page. - - - - - - - - - - - -
"Vocabularies" write "Words" write "Source" write
write-vocab-list "current-vocab" get write-word-list "current-vocab" get "current-word" get write-word-source
- 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. - [ - "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. - [ - - "Parse error" write - - swap [ write ] with-simple-html-output - "Ok" write - - - ] 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 ( -- ) - #! Display a Smalltalk like browser for exploring/modifying words. - [ - [ - - - "Factor Browser" write - - -
- write-browser-body -
- - - ] 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-responder ( allow-edit? -- ) - #! Start the Smalltalk-like browser. - "query" get dup [ - dup >r "vocab" swap assoc r> "word" swap assoc - ] [ - drop "browser" f - ] ifte browse ; - -"browser" [ f browser-responder ] install-cont-responder -! "browser-edit" [ t browser-responder ] install-cont-responder diff --git a/contrib/cont-responder/cont-responder.factor b/contrib/cont-responder/cont-responder.factor deleted file mode 100644 index a5995e72cc..0000000000 --- a/contrib/cont-responder/cont-responder.factor +++ /dev/null @@ -1,328 +0,0 @@ -! 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 ( -- ) - #! Return the global table of continuations - "continuation-table" get ; - -: reset-continuation-table ( -- ) - #! Create the initial global table - "continuation-table" set ; - -: continuation-item ( expire? quot id -- ) - #! 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. - [ - "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 -- 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 -- ) - #! 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 - - -

"This page has expired." write

- - - ] 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 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 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. - url a> write ; - -: 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. - 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 [ - [ - [ 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 ; - - diff --git a/contrib/cont-responder/cont-utils.factor b/contrib/cont-responder/cont-utils.factor deleted file mode 100644 index 0ed17a4117..0000000000 --- a/contrib/cont-responder/cont-utils.factor +++ /dev/null @@ -1,91 +0,0 @@ -! 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. - - swap write - call - ; - -: 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. - - - rot write - swap call - - call - ; - -: paragraph ( str -- ) - #! Output the string as an html paragraph -

write

; - -: show-message-page ( message -- ) - #! Display the message in an HTML page with an OK button. - [ - "Press OK to Continue" [ - swap paragraph - "OK" write - ] simple-page - ] show 2drop ; - -: vertical-layout ( list -- ) - #! Given a list of HTML components, arrange them vertically. - - [ ] each -
call
; - -: horizontal-layout ( list -- ) - #! Given a list of HTML components, arrange them horizontally. - - [ ] each -
call
; - -: button ( label -- ) - #! Output an HTML submit button with the given label. - ; - -: with-simple-html-output ( quot -- ) - #! Run the quotation inside an HTML stream wrapped - #! around stdio. - 
 
-    stdio get  [
-      call
-    ] with-stream
-
;