483 lines
15 KiB
Factor
483 lines
15 KiB
Factor
! 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
|
|
USE: cont-responder
|
|
USE: cont-html
|
|
USE: cont-utils
|
|
USE: html
|
|
USE: stdio
|
|
USE: stack
|
|
USE: strings
|
|
USE: namespaces
|
|
USE: inspector
|
|
USE: lists
|
|
USE: combinators
|
|
USE: cont-examples
|
|
USE: regexp
|
|
USE: prettyprint
|
|
USE: todo
|
|
USE: arithmetic
|
|
USE: logic
|
|
USE: kernel
|
|
USE: lazy
|
|
USE: parser-combinators
|
|
|
|
: 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;" %
|
|
"}" %
|
|
%> ;
|
|
|
|
: todo-stylesheet-url ( -- url )
|
|
#! Generate an URL for the stylesheet.
|
|
t [ [ drop todo-stylesheet write ] show ] register-continuation ;
|
|
|
|
: include-todo-stylesheet ( -- )
|
|
#! Generate HTML to include the todo stylesheet
|
|
<link rel= "stylesheet" href= todo-stylesheet-url link/> ;
|
|
|
|
: show-stack-page ( -- )
|
|
#! Debug function to show a page containing the current call stack.
|
|
[ .s ] with-string-stream 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 class= swap tr>
|
|
[ <td> call </td> ] each
|
|
</tr> ;
|
|
|
|
: simple-input ( name -- )
|
|
#! Output a simple HTML input field which will have the
|
|
#! specified name.
|
|
<input type= "text" size= "20" name= input/> ;
|
|
|
|
: simple-input-with-value ( name value -- )
|
|
#! Output a simple HTML input field which will have the
|
|
#! specified name and value.
|
|
<input type= "text" size= "20" value= name= input/> ;
|
|
|
|
: textarea-input ( name -- )
|
|
#! Output a simple HTML textarea field which will have the
|
|
#! specified name.
|
|
<textarea name= rows= "10" cols= "40" 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 name= swap rows= "10" cols= "40" textarea> write </textarea> ;
|
|
|
|
: password-input ( name -- )
|
|
#! Output an HTML password input field which will have the
|
|
#! specified name.
|
|
<input type= "password" size= "20" 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 method= "post" action= swap 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 ;
|
|
|
|
: username-parser ( -- parser )
|
|
#! Return a parser which parses a valid todo username.
|
|
#! That is, it contains only lowercase, uppercase and digits.
|
|
[ letter? ] satisfy
|
|
[ LETTER? ] satisfy <|>
|
|
[ digit? ] satisfy <|> <!+> just ;
|
|
|
|
: is-valid-username? ( password -- bool )
|
|
#! Return true if the username parses correctly
|
|
username-parser call ;
|
|
|
|
: 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" % %> ;
|
|
|
|
: 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
|
|
] ifte ;
|
|
|
|
: 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 class= "required" tr>
|
|
<td class= "lbl" td> "Priority" write </td>
|
|
<td> "priority" simple-input </td>
|
|
</tr>
|
|
<tr class= "required" tr>
|
|
<td class= "lbl" 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 class= "required" tr>
|
|
<td class= "lbl" td> "Priority" write </td>
|
|
<td> "priority" dup get simple-input-with-value </td>
|
|
</tr>
|
|
<tr class= "required" tr>
|
|
<td class= "lbl" td> "Description" write </td>
|
|
<td> "description" dup get textarea-input-with-value </td>
|
|
</tr>
|
|
</table>
|
|
"Save" button
|
|
] form
|
|
] bind ;
|
|
|
|
: priority-parser ( -- parser )
|
|
#! Return a parser for parsing priorities
|
|
[ digit? ] satisfy just ;
|
|
|
|
: todo-details-valid? ( priority description -- bool )
|
|
#! Return true if a valid priority and description were entered.
|
|
str-length 0 > swap priority-parser call and ;
|
|
|
|
: 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
|
|
] ifte ;
|
|
|
|
: write-get-password-form ( url -- )
|
|
#! Display the HTML for a form allowing entry of a
|
|
#! new password.
|
|
[
|
|
<table>
|
|
<tr class= "required" tr>
|
|
<td class= "lbl" td> "Old Password" write </td>
|
|
<td> "old-password" password-input </td>
|
|
</tr>
|
|
<tr class= "required" tr>
|
|
<td class= "lbl" td> "New Password" write </td>
|
|
<td> "new-password" password-input </td>
|
|
</tr>
|
|
<tr class= "required" tr>
|
|
<td class= "lbl" 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
|
|
] ifte
|
|
] [
|
|
"You entered an incorrect old password. The password was NOT changed." show-message-page
|
|
f
|
|
] ifte
|
|
] 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
|
|
] ifte ;
|
|
|
|
: 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
|
|
] ifte ;
|
|
|
|
: 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" ] ifte ;
|
|
|
|
: 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" ] ifte 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
|
|
] ifte ;
|
|
|
|
: show-todo-list ( -- )
|
|
#! Show the current todo list.
|
|
[
|
|
<% "todo" get todo-username % "'s To Do list" % %>
|
|
[ include-todo-stylesheet ]
|
|
[
|
|
drop
|
|
"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 drop ;
|
|
|
|
: 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
|