move contrib/cont-responder to httpd/examples
Also tidied up some of the examples (removed need for parser combinators) and removed examples that don't work or don't make good examples.
chris.double
parent
9f5845d09e
commit
1c86d1dc4a
|
|
@ -1,79 +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 httpd responder that demonstrates using XMLHttpRequest to send
|
||||
! asynchronous requests back to the server.
|
||||
!
|
||||
IN: live-updater-responder
|
||||
USE: live-updater
|
||||
USE: namespaces
|
||||
USE: html
|
||||
USE: words
|
||||
USE: io
|
||||
USE: kernel
|
||||
USE: cont-responder
|
||||
USE: prettyprint
|
||||
|
||||
: live-search-apropos-word ( string -- )
|
||||
#! Given a string that is a factor word, show the
|
||||
#! aporpos of that word.
|
||||
[
|
||||
"browser" "responder" set
|
||||
<pre>
|
||||
stdio get <html-stream> [
|
||||
apropos
|
||||
] with-stream
|
||||
</pre>
|
||||
] with-scope ;
|
||||
|
||||
: live-updater-responder ( -- )
|
||||
[
|
||||
drop
|
||||
<html>
|
||||
<head>
|
||||
<title> "Live Updater Example" write </title>
|
||||
include-live-updater-js
|
||||
</head>
|
||||
<body>
|
||||
[
|
||||
[
|
||||
"millis" [ millis pprint ] "Display Server millis" live-anchor
|
||||
<div "millis" =id div>
|
||||
"The millisecond time from the server will appear here" write
|
||||
</div>
|
||||
]
|
||||
[
|
||||
"Enter a word to apropos:" paragraph
|
||||
"apropos" [ live-search-apropos-word ] live-search
|
||||
]
|
||||
[
|
||||
<div "apropos" =id div>
|
||||
"" write
|
||||
</div>
|
||||
]
|
||||
] vertical-layout
|
||||
</body>
|
||||
</html>
|
||||
] show ;
|
||||
|
||||
"live-updater" [ live-updater-responder ] install-cont-responder
|
||||
|
|
@ -1,494 +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.
|
||||
!
|
||||
! A simple 'to-do list' web application.
|
||||
!
|
||||
! Users can register with the system and from there manage a simple
|
||||
! list of things to do. All data is stored in a directory in the
|
||||
! filesystem with the users name.
|
||||
IN: todo-example
|
||||
USING: xml ;
|
||||
USE: cont-responder
|
||||
USE: html
|
||||
USE: io
|
||||
USE: strings
|
||||
USE: namespaces
|
||||
USE: inspector
|
||||
USE: lists
|
||||
USE: cont-examples
|
||||
USE: prettyprint
|
||||
USE: todo
|
||||
USE: math
|
||||
USE: kernel
|
||||
USE: sequences
|
||||
|
||||
: todo-stylesheet ( -- string )
|
||||
#! Return the stylesheet for the todo list
|
||||
{
|
||||
"table.list {"
|
||||
" text-align:center;"
|
||||
" font-family: Verdana;"
|
||||
" font-weight: normal;"
|
||||
" font-size: 11px;"
|
||||
" color: #404040;"
|
||||
" background-color: #fafafa;"
|
||||
" border: 1px #6699cc solid;"
|
||||
" border-collapse: collapse;"
|
||||
" boder-spacing: 0px;"
|
||||
"}"
|
||||
"tr.heading {"
|
||||
" border-bottom: 2px solid #6699cc;"
|
||||
" border-left: 1px solix #6699cc;"
|
||||
" background-color: #BEC8D1;"
|
||||
" text-align: left;"
|
||||
" text-indent: 0px;"
|
||||
" font-family: verdana;"
|
||||
" font-weight: bold;"
|
||||
" color: #404040;"
|
||||
"}"
|
||||
"tr.item {"
|
||||
" border-bottom: 1px solid #9cf;"
|
||||
" border-top: 0px;"
|
||||
" border-left: 1px solid #9cf;"
|
||||
" border-right: 0px;"
|
||||
" text-align: left;"
|
||||
" text-indent: 2px;"
|
||||
" font-family: verdana, sans-serif, arial;"
|
||||
" font-weight: normal;"
|
||||
" color: #404040;"
|
||||
" background-color: #fafafa;"
|
||||
"}"
|
||||
"tr.complete {"
|
||||
" border-bottom: 1px solid #9cf;"
|
||||
" border-top: 0px;"
|
||||
" border-left: 1px solid #9cf;"
|
||||
" border-right: 0px;"
|
||||
" text-align: left;"
|
||||
" text-indent: 2px;"
|
||||
" font-family: verdana, sans-serif, arial;"
|
||||
" font-weight: normal;"
|
||||
" color: #404040;"
|
||||
" background-color: #ccc;"
|
||||
"}"
|
||||
"td.lbl {"
|
||||
" font-weight: bold; text-align: right;"
|
||||
"}"
|
||||
"tr.required {"
|
||||
" background: #FCC;"
|
||||
"}"
|
||||
"input:focus {"
|
||||
" background: yellow;"
|
||||
"}"
|
||||
"textarea:focus {"
|
||||
" background: yellow;"
|
||||
"}"
|
||||
} concat ;
|
||||
|
||||
: todo-stylesheet-url ( -- url )
|
||||
#! Generate an URL for the stylesheet.
|
||||
t [ [ todo-stylesheet write ] show-final ] register-continuation id>url ;
|
||||
|
||||
: include-todo-stylesheet ( -- )
|
||||
#! Generate HTML to include the todo stylesheet
|
||||
<link "stylesheet" =rel todo-stylesheet-url =href link/> ;
|
||||
|
||||
: show-stack-page ( -- )
|
||||
#! Debug function to show a page containing the current call stack.
|
||||
[ .s ] string-out chars>entities show-message-page ;
|
||||
|
||||
: row ( list -- )
|
||||
#! Output an html TR row with each element of the list
|
||||
#! being called to produce the output for each TD.
|
||||
<tr>
|
||||
[ <td> call </td> ] each
|
||||
</tr> ;
|
||||
|
||||
: styled-row ( class list -- )
|
||||
#! Output an html TR row with each element of the list
|
||||
#! being called to produce the output for each TD.
|
||||
<tr swap =class tr>
|
||||
[ <td> call </td> ] each
|
||||
</tr> ;
|
||||
|
||||
: simple-input ( name -- )
|
||||
#! Output a simple HTML input field which will have the
|
||||
#! specified name.
|
||||
<input "text" =type "20" =size =name input/> ;
|
||||
|
||||
: simple-input-with-value ( name value -- )
|
||||
#! Output a simple HTML input field which will have the
|
||||
#! specified name and value.
|
||||
<input "text" =type "20" =size =value =name input/> ;
|
||||
|
||||
: textarea-input ( name -- )
|
||||
#! Output a simple HTML textarea field which will have the
|
||||
#! specified name.
|
||||
<textarea =name "10" =rows "40" =cols textarea> "Enter description here." write </textarea> ;
|
||||
|
||||
: textarea-input-with-value ( name value -- )
|
||||
#! Output a simple HTML textarea field which will have the
|
||||
#! specified name and value.
|
||||
<textarea swap =name "10" =rows "40" =cols textarea> write </textarea> ;
|
||||
|
||||
: password-input ( name -- )
|
||||
#! Output an HTML password input field which will have the
|
||||
#! specified name.
|
||||
<input "password" =type "20" =size =name input/> ;
|
||||
|
||||
: form ( action quot -- )
|
||||
#! Call quot with any output appearing inside an HTML form.
|
||||
#! The form is a POST form where the action is as specified.
|
||||
<form "post" =method swap =action form> call </form> ;
|
||||
|
||||
: input-value ( name -- value )
|
||||
#! Get the value of the variable "name". If it is f
|
||||
#! return "" else return the value.
|
||||
get [ "" ] unless* ;
|
||||
|
||||
: login-form ( url button-text -- )
|
||||
#! Write the HTML for an HTML form requesting a username
|
||||
#! and password. The 'accept' button has the text given
|
||||
#! in 'button-text'. The form will go to the given URL on
|
||||
#! submission.
|
||||
swap [
|
||||
<table>
|
||||
[ [ "Name:" write ] [ "name" simple-input ] ] row
|
||||
[ [ "Password:" write ] [ "password" password-input ] ] row
|
||||
</table>
|
||||
button
|
||||
] form ;
|
||||
|
||||
: registration-page ( submit-url -- )
|
||||
#! Write the HTML for the registration page to std output.
|
||||
"Register New TODO List" [
|
||||
"Enter the username and password for your new todo list:" paragraph
|
||||
"Register" login-form
|
||||
] simple-page ;
|
||||
|
||||
: valid-username-char ( ch -- b )
|
||||
#! Return true if the character is valid to appear in a username.
|
||||
dup letter? [
|
||||
drop t
|
||||
] [
|
||||
dup LETTER? [
|
||||
drop t
|
||||
] [
|
||||
digit? [
|
||||
t
|
||||
] [
|
||||
f
|
||||
] if
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: replace-invalid-username-chars ( str -- str )
|
||||
#! Return a string with invalid username characters mapped to underscores.
|
||||
[
|
||||
dup valid-username-char [
|
||||
] [
|
||||
drop CHAR: _
|
||||
] if
|
||||
] map ;
|
||||
|
||||
: is-valid-username? ( username -- bool )
|
||||
#! Return true if the username parses correctly
|
||||
dup replace-invalid-username-chars = ;
|
||||
|
||||
: login-details-valid? ( name password -- )
|
||||
#! Ensure that a valid username and password were
|
||||
#! entered. In particular, ensure that only alphanumeric
|
||||
#! data was entered to prevent security problems by
|
||||
#! using .., etc in the name.
|
||||
drop is-valid-username? ;
|
||||
|
||||
: get-registration-details ( -- name password )
|
||||
#! Get the registration details from the user putting
|
||||
#! the name and password on the stack.
|
||||
[ registration-page ] show [
|
||||
"name" get "password" get
|
||||
] bind 2dup login-details-valid? [
|
||||
2drop
|
||||
"Please ensure you enter a username containing letters and numbers only." show-message-page
|
||||
get-registration-details
|
||||
] unless ;
|
||||
|
||||
: get-todo-filename ( database-path <todo> -- filename )
|
||||
#! Get the filename containing the todo list details.
|
||||
[ swap % todo-username % ".todo" % ] "" make ;
|
||||
|
||||
: add-default-todo-item ( <todo> -- )
|
||||
#! Add a default todo item. This is a workaround for the
|
||||
#! currently hackish method of saving todo lists which can't
|
||||
#! handle empty lists.
|
||||
"1" "Set up todo list" <todo-item> add-todo-item ;
|
||||
|
||||
: init-new-todo ( <todo> -- )
|
||||
#! Add the default todo item and store the todo list to
|
||||
#! persistent storage.
|
||||
dup add-default-todo-item
|
||||
dup "database-path" get swap get-todo-filename store-todo ;
|
||||
|
||||
: register-new-user ( -- )
|
||||
#! Get registration details for a new user and add a
|
||||
#! todo list for them.
|
||||
get-registration-details
|
||||
2dup "database-path" get -rot user-exists? [
|
||||
2drop
|
||||
"That user already exists in the system, sorry. Please use another name."
|
||||
show-message-page
|
||||
register-new-user
|
||||
] [
|
||||
<todo> init-new-todo
|
||||
"You have successfully registered your todo list." show-message-page
|
||||
] if ;
|
||||
|
||||
: login-request-paragraph ( -- )
|
||||
#! Display the paragraph requesting the user to login or register.
|
||||
<p>
|
||||
"Please enter your username and password (" write
|
||||
"Click to Register" [ register-new-user ] quot-href
|
||||
"):" write
|
||||
</p> ;
|
||||
|
||||
: get-login-information ( -- user password )
|
||||
[
|
||||
"Login" [
|
||||
login-request-paragraph
|
||||
"Login" login-form
|
||||
] simple-page
|
||||
] show [
|
||||
"name" get "password" get
|
||||
] bind ;
|
||||
|
||||
: ensure-login-valid ( user password -- user password )
|
||||
2dup login-details-valid? [
|
||||
"Please ensure you enter a username containing letters and numbers only." show-message-page
|
||||
get-login-information
|
||||
] unless ;
|
||||
|
||||
: get-todo-list ( -- <todo> )
|
||||
#! Prompts for a username or password until a valid combination
|
||||
#! is entered then returns the <todo> list for that user.
|
||||
get-login-information ensure-login-valid
|
||||
"database-path" get -rot user-exists? [
|
||||
"Sorry, your username or password was incorrect." show-message-page
|
||||
get-todo-list
|
||||
] unless* ;
|
||||
|
||||
: write-new-todo-item-form ( url -- )
|
||||
#! Display the HTML for a form allowing entry of a
|
||||
#! todo item details.
|
||||
[
|
||||
<table>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Priority" write </td>
|
||||
<td> "priority" simple-input </td>
|
||||
</tr>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Description" write </td>
|
||||
<td> "description" textarea-input </td>
|
||||
</tr>
|
||||
</table>
|
||||
"Add" button
|
||||
] form ;
|
||||
|
||||
: write-edit-todo-item-form ( item url -- )
|
||||
#! Display the HTML for a form allowing editing of a
|
||||
#! todo item details.
|
||||
swap [
|
||||
[
|
||||
<table>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Priority" write </td>
|
||||
<td> "priority" dup get simple-input-with-value </td>
|
||||
</tr>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Description" write </td>
|
||||
<td> "description" dup get textarea-input-with-value </td>
|
||||
</tr>
|
||||
</table>
|
||||
"Save" button
|
||||
] form
|
||||
] bind ;
|
||||
|
||||
: priority-valid? ( string -- bool )
|
||||
#! Test the string containing a priority to see if it is
|
||||
#! valid. It should be a single digit from 0-9.
|
||||
dup length 1 = [ 0 swap nth digit? ] [ drop f ] if ;
|
||||
|
||||
: todo-details-valid? ( priority description -- bool )
|
||||
#! Return true if a valid priority and description were entered.
|
||||
length 0 > [ priority-valid? ] [ drop f ] if ;
|
||||
|
||||
: get-new-todo-item ( -- <todo-item> )
|
||||
#! Enter a new item to the current todo list.
|
||||
[
|
||||
"Enter New Todo Item" [ include-todo-stylesheet ] [ write-new-todo-item-form ] styled-page
|
||||
] show [
|
||||
"priority" get "description" get
|
||||
] bind 2dup todo-details-valid? [
|
||||
<todo-item>
|
||||
] [
|
||||
2drop
|
||||
"Please ensure you enter a Priority from 0-9 and a description." show-message-page
|
||||
get-new-todo-item
|
||||
] if ;
|
||||
|
||||
: write-get-password-form ( url -- )
|
||||
#! Display the HTML for a form allowing entry of a
|
||||
#! new password.
|
||||
[
|
||||
<table>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Old Password" write </td>
|
||||
<td> "old-password" password-input </td>
|
||||
</tr>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "New Password" write </td>
|
||||
<td> "new-password" password-input </td>
|
||||
</tr>
|
||||
<tr "required" =class tr>
|
||||
<td "lbl" =class td> "Verify Password" write </td>
|
||||
<td> "verify-password" password-input </td>
|
||||
</tr>
|
||||
</table>
|
||||
"Change Password" button
|
||||
] form ;
|
||||
|
||||
: get-new-password ( <todo> -- password )
|
||||
#! Get a new password for the todo list.
|
||||
[
|
||||
"Enter New Password" [ include-todo-stylesheet ] [ write-get-password-form ] styled-page
|
||||
] show [
|
||||
"old-password" get
|
||||
swap password-matches? [
|
||||
"new-password" get
|
||||
"verify-password" get = [
|
||||
"new-password" get
|
||||
] [
|
||||
"Your new password did not match. The password was NOT changed." show-message-page
|
||||
f
|
||||
] if
|
||||
] [
|
||||
"You entered an incorrect old password. The password was NOT changed." show-message-page
|
||||
f
|
||||
] if
|
||||
] bind ;
|
||||
|
||||
: edit-item-details ( item -- )
|
||||
#! Allow editing of an existing items details.
|
||||
[
|
||||
"Edit Item" [ include-todo-stylesheet ] [ write-edit-todo-item-form ] styled-page
|
||||
] show [
|
||||
"priority" get "description" get
|
||||
] bind 2dup todo-details-valid? [
|
||||
rot [ "description" set "priority" set ] bind
|
||||
] [
|
||||
drop drop
|
||||
"Please ensure you enter a Priority from 0-9 and a description." show-message-page
|
||||
edit-item-details
|
||||
] if ;
|
||||
|
||||
: save-current-todo ( -- )
|
||||
#! Save the current todo list
|
||||
"database-path" get "todo" get get-todo-filename "todo" get swap store-todo ;
|
||||
|
||||
: lcurry1 ( value quot -- quot )
|
||||
#! Return a quotation that when called will have 'value'
|
||||
#! as the first item on the stack.
|
||||
cons ;
|
||||
|
||||
: write-mark-complete-action ( item -- )
|
||||
#! Write out HTML to perform a mark complete
|
||||
#! action on an item (or other appropriate
|
||||
#! action if already complete).
|
||||
dup item-complete? [
|
||||
"Delete" swap [ "todo" get swap delete-item save-current-todo ] lcurry1 quot-href
|
||||
] [
|
||||
"Complete" swap [ set-item-completed save-current-todo ] lcurry1 quot-href
|
||||
] if ;
|
||||
|
||||
: write-edit-action ( item -- )
|
||||
#! Write out html to allow editing an item.
|
||||
"Edit" swap [ edit-item-details save-current-todo ] lcurry1 quot-href ;
|
||||
|
||||
: item-class ( <todo-item> -- string )
|
||||
#! Return the class to use for displaying the row for the
|
||||
#! item.
|
||||
item-complete? [ "complete" ] [ "item" ] if ;
|
||||
|
||||
: write-item-row ( <todo-item> -- )
|
||||
#! Write the todo list item as an HTML row.
|
||||
dup dup dup dup
|
||||
dup item-class [
|
||||
[ item-priority write ]
|
||||
[ item-complete? [ "Yes" ] [ "No" ] if write ]
|
||||
[ item-description write ]
|
||||
[ write-mark-complete-action ]
|
||||
[ write-edit-action ]
|
||||
] styled-row ;
|
||||
|
||||
: write-item-table ( <todo> -- )
|
||||
#! Write the table of items for the todo list.
|
||||
<table>
|
||||
"heading" [
|
||||
[ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] [ " " write ]
|
||||
] styled-row
|
||||
todo-items [ write-item-row ] each
|
||||
</table> ;
|
||||
|
||||
: do-add-new-item ( -- )
|
||||
#! Request a new item from the user and add it to the current todo list.
|
||||
"todo" get get-new-todo-item add-todo-item save-current-todo ;
|
||||
|
||||
: do-change-password ( -- )
|
||||
#! Allow changing the password for the todo list.
|
||||
"todo" get get-new-password dup [
|
||||
"todo" get [ "password" set ] bind save-current-todo
|
||||
"Your password has been changed." show-message-page
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: show-todo-list ( -- )
|
||||
#! Show the current todo list.
|
||||
[
|
||||
[ "todo" get todo-username % "'s To Do list" % ] "" make
|
||||
[ include-todo-stylesheet ]
|
||||
[
|
||||
"todo" get write-item-table
|
||||
[
|
||||
[ "Add Item" [ do-add-new-item ] quot-href ]
|
||||
[ "Change Password" [ do-change-password ] quot-href ]
|
||||
] horizontal-layout
|
||||
] styled-page
|
||||
] show-final ;
|
||||
|
||||
: todo-example ( path -- )
|
||||
#! Startup the todo list example using the given path as the
|
||||
#! directory holding the todo files.
|
||||
"database-path" set
|
||||
get-todo-list "todo" set
|
||||
show-todo-list ;
|
||||
|
||||
"todo" [ drop "todo/" todo-example ] install-cont-responder
|
||||
|
|
@ -1,165 +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.
|
||||
!
|
||||
! Routines for managing a simple "To Do list". A todo list has a 'user',
|
||||
! 'password' and list of items. Each item has a priority, description,
|
||||
! and indication if it is complete.
|
||||
IN: todo
|
||||
USE: strings
|
||||
USE: io
|
||||
USE: namespaces
|
||||
USE: lists
|
||||
USE: math
|
||||
USE: kernel
|
||||
USE: prettyprint
|
||||
USE: hashtables
|
||||
USE: sequences
|
||||
USE: http
|
||||
|
||||
: <todo> ( user password -- <todo> )
|
||||
#! Create an empty todo list
|
||||
[
|
||||
"password" set
|
||||
"user" set
|
||||
f "items" set
|
||||
] make-hash ;
|
||||
|
||||
: <todo-item> ( priority description -- )
|
||||
#! Create a todo item
|
||||
[
|
||||
"description" set
|
||||
"priority" set
|
||||
f "complete?" set
|
||||
] make-hash ;
|
||||
|
||||
: add-todo-item ( <todo> <item> -- )
|
||||
#! Add the item to the todo list
|
||||
swap [
|
||||
"items" get swap add "items" set
|
||||
] bind ;
|
||||
|
||||
: >yes/no ( bool -- str )
|
||||
#! Return the string "yes" if the boolean is true, else
|
||||
#! return "no".
|
||||
"yes" "no" ? ;
|
||||
|
||||
: write-item ( <todo-item> -- )
|
||||
#! write the item in a manner that can be later re-read
|
||||
[
|
||||
"complete?" get >yes/no url-encode print
|
||||
"priority" get url-encode print
|
||||
"description" get url-encode print
|
||||
] bind ;
|
||||
|
||||
: write-items ( list -- )
|
||||
#! write the todo list items
|
||||
dup length .
|
||||
[ write-item ] each ;
|
||||
|
||||
: write-todo ( <todo> -- )
|
||||
#! Write the todo list to the current output stream
|
||||
#! in a format that if loaded by the parser will result
|
||||
#! in a <todo> again.
|
||||
[
|
||||
"user" get url-encode print
|
||||
"password" get url-encode print
|
||||
"items" get write-items
|
||||
] bind ;
|
||||
|
||||
: store-todo ( <todo> filename -- )
|
||||
#! store the todo list in the given file.
|
||||
<file-writer> [ write-todo ] with-stream ;
|
||||
|
||||
: read-todo ( -- <todo> )
|
||||
#! Read a todo list from the current input stream.
|
||||
readln url-decode readln url-decode <todo>
|
||||
readln string>number [
|
||||
dup
|
||||
[
|
||||
readln url-decode "yes" = "complete?" set
|
||||
readln url-decode "priority" set
|
||||
readln url-decode "description" set
|
||||
] make-hash add-todo-item
|
||||
] times ;
|
||||
|
||||
: load-todo ( filename -- <todo> )
|
||||
<file-reader> [ read-todo ] with-stream ;
|
||||
|
||||
: password-matches? ( password <todo> -- <todo> )
|
||||
#! Returns the <todo> if the password matches otherwise
|
||||
#! returns false.
|
||||
tuck [ "password" get ] bind = [ drop f ] unless ;
|
||||
|
||||
: user-exists? ( db-path name password -- <todo> )
|
||||
#! Returns a <todo> if a user with the given name exists
|
||||
#! otherwise returns false.
|
||||
-rot ".todo" append3 dup exists? [
|
||||
load-todo password-matches?
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: each-bind ( quot list -- )
|
||||
[ swap [ bind ] keep ] each drop ;
|
||||
|
||||
: items-each-bind ( quot -- )
|
||||
#! For each item in the currently bound todo list, call the quotation
|
||||
#! with that item bound.
|
||||
"items" get each-bind ;
|
||||
|
||||
: todo-username ( <todo> -- username )
|
||||
#! return the username for the todo list item.
|
||||
"user" swap hash ;
|
||||
|
||||
: item-priority ( <todo-item> -- priority )
|
||||
#! return the priority for the todo list item.
|
||||
"priority" swap hash ;
|
||||
|
||||
: item-complete? ( <todo-item> -- boolean )
|
||||
#! return true if the todo list item is completed.
|
||||
"complete?" swap hash ;
|
||||
|
||||
: set-item-completed ( <todo-item> -- )
|
||||
t "complete?" rot set-hash ;
|
||||
|
||||
: item-description ( <todo-item> -- description )
|
||||
#! return the description for the todo list item.
|
||||
"description" swap hash ;
|
||||
|
||||
: priority-comparator ( item1 item2 -- number )
|
||||
#! Return 0 if item equals item2, -1 if item1 < item2 and
|
||||
#! 1 if item1 > item2.
|
||||
>r item-priority r> item-priority <=> ;
|
||||
|
||||
: todo-items ( <todo> -- alist )
|
||||
#! Return a list of items for the given todo list.
|
||||
"items" swap hash [ priority-comparator ] sort ;
|
||||
|
||||
: delete-item ( <todo> <todo-item> -- )
|
||||
#! Delete the item from the todo list
|
||||
swap dup >r todo-items remove r> [ "items" set ] bind ;
|
||||
|
||||
: test-todo
|
||||
"user" "password" <todo>
|
||||
dup "1" "item1" <todo-item> add-todo-item
|
||||
dup "2" "item2" <todo-item> add-todo-item ;
|
||||
|
|
@ -32,7 +32,6 @@
|
|||
!
|
||||
! The result is not that pretty but it shows the basic idea.
|
||||
IN: numbers-game
|
||||
USE: parser-combinators
|
||||
USE: kernel
|
||||
USE: math
|
||||
USE: parser
|
||||
|
|
@ -87,7 +87,6 @@
|
|||
IN: cont-responder
|
||||
USE: namespaces
|
||||
USE: kernel
|
||||
USE: parser-combinators
|
||||
USE: io
|
||||
|
||||
: <cont-test-state> ( -- <state> )
|
||||
|
|
@ -33,7 +33,6 @@ USE: parser
|
|||
USE: lists
|
||||
USE: errors
|
||||
USE: strings
|
||||
USE: live-updater
|
||||
USE: prettyprint
|
||||
USE: words
|
||||
USE: vectors
|
||||
|
|
@ -125,20 +124,6 @@ USE: hashtables
|
|||
</table>
|
||||
] make-hash ;
|
||||
|
||||
: display-word-see-form ( url -- )
|
||||
#! Write out the html for code that accepts
|
||||
#! the name of a word, and displays the source
|
||||
#! code of that word.
|
||||
[
|
||||
[
|
||||
"Enter the name of a word: " write
|
||||
"see" [ html-for-word-source ] live-search
|
||||
]
|
||||
[
|
||||
<div "see" =id div> "" write </div>
|
||||
]
|
||||
] vertical-layout ;
|
||||
|
||||
: display-last-output ( string -- )
|
||||
#! Write out html to display the last output.
|
||||
<table "1" =border table>
|
||||
|
|
@ -155,7 +140,6 @@ USE: hashtables
|
|||
<html>
|
||||
<head>
|
||||
<title> "Factor Evaluator" write </title>
|
||||
include-live-updater-js
|
||||
</head>
|
||||
<body>
|
||||
"Use Alt+E to evaluate, or press 'Evaluate'" paragraph
|
||||
|
|
@ -164,7 +148,6 @@ USE: hashtables
|
|||
[ "stack" get display-stack ]
|
||||
[ "history" get display-history ]
|
||||
] horizontal-layout
|
||||
display-word-see-form
|
||||
"output" get display-last-output
|
||||
</body>
|
||||
</html>
|
||||
|
|
@ -2,14 +2,10 @@ IN: scratchpad
|
|||
USING: words kernel parser sequences io compiler ;
|
||||
|
||||
"/contrib/httpd/load.factor" run-resource
|
||||
"/contrib/parser-combinators/load.factor" run-resource
|
||||
|
||||
{
|
||||
"cont-examples"
|
||||
"cont-numbers-game"
|
||||
"todo"
|
||||
"todo-example"
|
||||
"eval-responder"
|
||||
"live-updater-responder"
|
||||
"cont-testing"
|
||||
} [ "/contrib/cont-responder/" swap ".factor" append3 run-resource ] each
|
||||
} [ "/contrib/httpd/examples/" swap ".factor" append3 run-resource ] each
|
||||
Loading…
Reference in New Issue