From 04880642c71045e02ea6a4ab9ccb94330dcf42e7 Mon Sep 17 00:00:00 2001 From: Chris Double Date: Thu, 22 Jul 2004 22:04:53 +0000 Subject: [PATCH] making todo list more complete Fixed security issue if user entered certain characters in username field. Added 'mark complete' Added 'delete item' Refactored into smaller words. refactoring of registration form in todo list show now returns a namespace open html words were acting like closed words and generating a close tag. This is fixed in this patch. convert table writes to use table word. --- contrib/cont-responder/cont-examples.factor | 5 +- contrib/cont-responder/cont-html.factor | 6 +- contrib/cont-responder/cont-responder.factor | 14 +- contrib/cont-responder/todo-example.factor | 251 ++++++++++++++----- contrib/cont-responder/todo.factor | 36 ++- 5 files changed, 234 insertions(+), 78 deletions(-) diff --git a/contrib/cont-responder/cont-examples.factor b/contrib/cont-responder/cont-examples.factor index 7b948fbfe7..cb79a4910d 100644 --- a/contrib/cont-responder/cont-examples.factor +++ b/contrib/cont-responder/cont-examples.factor @@ -53,8 +53,9 @@ USE: prettyprint ] ] html-document - ] show - "name" swap assoc ; + ] show [ + "name" get + ] bind ; : test-cont-responder ( - ) #! Test the cont-responder responder by displaying a few pages in a row. diff --git a/contrib/cont-responder/cont-html.factor b/contrib/cont-responder/cont-html.factor index 6e94ebe4e5..2afb772022 100644 --- a/contrib/cont-responder/cont-html.factor +++ b/contrib/cont-responder/cont-html.factor @@ -236,8 +236,8 @@ USE: logic : open-html-word-code ( name -- ) #! Return a list of the code for the words #! used for the open only HTML tag. - dup [ [ ] write-tag ] cons t swons - swap [ >n f ] cons t swons + dup [ [ ] write-tag ] cons f swons + swap [ >n f ] cons f swons [ "last-name" get n> -rot swap attribute-assign [ ] write-tag ] 2list cons ; @@ -262,7 +262,7 @@ USE: logic [ "h1" "h2" "h3" "h4" "h5" "h6" "h7" "h8" "h9" "ol" "li" "form" "a" "p" "html" "head" "body" "title" - "b" "i" "ul" "table" "tr" "td" "pre" + "b" "i" "ul" "table" "tr" "td" "pre" "textarea" ] [ define-closed-html-word ] each ! Define some closed HTML tags diff --git a/contrib/cont-responder/cont-responder.factor b/contrib/cont-responder/cont-responder.factor index 64246c220f..1f1ee2c06d 100644 --- a/contrib/cont-responder/cont-responder.factor +++ b/contrib/cont-responder/cont-responder.factor @@ -215,12 +215,15 @@ DEFER: show ] callcc1 drop ] ifte ; -: show ( quot -- alist ) +: 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 alist on + #! 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 [ @@ -256,12 +259,17 @@ DEFER: show "(.+)=(.+)" groups uncons car cons unit ] ifte ; +: post-request>namespace ( post-request -- namespace ) + #! Return a namespace containing the name/value's from the + #! post data. + post-request>alist alist>namespace ; + : cont-post-responder ( id -- ) #! httpd responder that retrieves a continuation for the given #! id and calls it with the POST data as an alist on the top #! of the stack. [ - read-post-request post-request>alist swap resume-continuation + read-post-request post-request>namespace swap resume-continuation ] with-exit-continuation print drop ; diff --git a/contrib/cont-responder/todo-example.factor b/contrib/cont-responder/todo-example.factor index 61fbcc3b19..1988b4f485 100644 --- a/contrib/cont-responder/todo-example.factor +++ b/contrib/cont-responder/todo-example.factor @@ -29,6 +29,7 @@ IN: todo-example USE: cont-responder USE: cont-html +USE: html USE: stdio USE: stack USE: strings @@ -37,8 +38,10 @@ USE: inspector USE: lists USE: combinators USE: cont-examples +USE: regexp +USE: prettyprint USE: todo - + : simple-todo-page ( title quot -- ) #! Call the quotation, with all output going to the #! body of an html page with the given title. @@ -51,6 +54,19 @@ USE: todo #! 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-todo-page + ] show 2drop ; + +: 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. @@ -63,107 +79,206 @@ USE: todo #! specified name. ; +: textarea-input ( name -- ) + #! Output a simple HTML textarea field which will have the + #! specified name. + ; +! ; + +: password-input ( name -- ) + #! Output an HTML password input field which will have the + #! specified name. + ; + : button ( label -- ) #! Output an HTML submit button with the given label. ; -: form ( quot action -- ) +: 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. -
[ call ]
; +
swap
; : 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 [ + [ + [ [ "Name:" write ] [ "name" simple-input ] ] row + [ [ "Password:" write ] [ "password" password-input ] ] row + ]
+ 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-todo-page ; + +: 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 "[a-zA-Z0-9]*" re-matches ; + +: 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 -- filename ) + #! Get the filename containing the todo list details. + <% swap % todo-username % ".todo" % %> ; + +: add-default-todo-item ( -- ) + #! 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" add-todo-item ; + +: init-new-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 form them. - [ - "Register New TODO List" - [ - [ - "" write - [ [ "Name:" write ] [ "name" simple-input ] ] row - [ [ "Password:" write ] [ "password" simple-input ] ] row - "
" write - "Register" button - ] swap form - ] simple-todo-page - ] show alist>namespace [ - "name" get dup "password" get - ] bind - dup "1" "Set up todo list" add-todo-item - swap "database-path" get swap ".todo" cat3 store-todo ; + #! 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 + ] [ + init-new-todo + "You have successfully registered your todo list." show-message-page + ] ifte ; -: get-login-information ( -- user password ) +: login-request-paragraph ( -- ) + #! Display the paragraph requesting the user to login or register. +

[ + "Please enter your username and password (" write + "Click to Register" [ register-new-user ] quot-href + "):" write + ]

; + +: get-login-information ( -- user password ) [ - "Login" - [ -

[ "Please enter your username and password (" write - "Click to Register" [ register-new-user ] quot-href - "):" write - ]

- [ - "" write - [ [ "Username:" write ] [ "username" simple-input ] ] row - [ [ "Password:" write ] [ "password" simple-input ] ] row - "
" write - "Login" button - ] swap form + "Login" [ + login-request-paragraph + "Login" login-form ] simple-todo-page - ] show alist>namespace [ "username" input-value "password" input-value ] bind ; + ] 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 ( -- ) #! Prompts for a username or password until a valid combination #! is entered then returns the list for that user. - get-login-information "database-path" get -rot user-exists? [ get-todo-list ] unless* ; + 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* ; -: enter-new-todo-item ( -- ) +: write-new-todo-item-form ( url -- ) + #! Display the HTML for a form allowing entry of a + #! todo item details. + [ + [ + [ [ "Priority:" write ] [ "priority" simple-input ] ] row + [ [ "Description:" write ] [ "description" textarea-input ] ] row + ]
+ "Add" button + ] form ; + +: get-new-todo-item ( -- ) #! Enter a new item to the current todo list. [ - "Enter New Todo Item" - [ - [ - "" write - [ [ "Priority:" write ] [ "priority" simple-input ] ] row - [ [ "Description:" write ] [ "description" simple-input ] ] row - "
" write - "Add" button - ] swap form - ] simple-todo-page - ] show alist>namespace [ + "Enter New Todo Item" [ write-new-todo-item-form ] simple-todo-page + ] show [ "priority" get "description" get ] bind ; : save-current-todo ( -- ) #! Save the current todo list - "todo" get dup "database-path" get swap [ "user" get ] bind ".todo" cat3 store-todo ; + "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 + ] [ + "Mark Completed" swap [ set-item-completed save-current-todo ] lcurry1 quot-href + ] ifte ; + +: write-item-row ( -- ) + #! Write the todo list item as an HTML row. + dup dup dup + [ [ item-priority write ] + [ item-complete? [ "Yes" ] [ "No" ] ifte write ] + [ item-description write ] + [ write-mark-complete-action ] + ] row ; + +: write-item-table ( -- ) + #! Write the table of items for the todo list. + [ + [ [ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] ] row + todo-items [ write-item-row ] each + ]
; + +: 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 ; + +: show-todo-list ( -- ) + #! Show the current todo list. + [ + <% "todo" get todo-username % "'s To Do list" % %> + [ + drop + "todo" get write-item-table + "Add Item" [ do-add-new-item ] quot-href + ] simple-todo-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 - [ - "todo" get [ "user" get ] bind "'s" "To Do list" cat3 - [ - drop - "todo" get [ - "" write - [ [ "Priority" write ] [ "Complete?" write ] [ "Description" write ] ] row - [ - [ [ "priority" get write ] - [ "complete?" get [ "Yes" ] [ "No" ] ifte write ] - [ "description" get write ] ] row - ] items-each-bind - "
" write - "Add Item" [ - "todo" get enter-new-todo-item add-todo-item save-current-todo - ] quot-href - ] bind - ] simple-todo-page - ] show drop ; + show-todo-list ; "todo" [ drop "todo/" todo-example ] install-cont-responder \ No newline at end of file diff --git a/contrib/cont-responder/todo.factor b/contrib/cont-responder/todo.factor index c031329797..ea5ee53eba 100644 --- a/contrib/cont-responder/todo.factor +++ b/contrib/cont-responder/todo.factor @@ -31,6 +31,7 @@ USE: strings USE: streams USE: namespaces USE: lists +USE: arithmetic USE: stdio USE: kernel @@ -76,8 +77,8 @@ USE: kernel "password" print-quoted "set" print "user" get print-quoted "user" print-quoted "set" print - "items" get [ namespace>alist ] map print - "[ alist>namespace ] map" print + "items" get [ namespace>alist ] map "items" swons print + "cdr [ alist>namespace ] map" print "items" print-quoted "set" print "] extend" print ] bind ; @@ -108,6 +109,37 @@ USE: kernel #! with that item bound. unit [ bind ] append "items" get swap each ; +: todo-username ( -- username ) + #! return the username for the todo list item. + [ "user" get ] bind ; + +: item-priority ( -- priority ) + #! return the priority for the todo list item. + [ "priority" get ] bind ; + +: item-complete? ( -- boolean ) + #! return true if the todo list item is completed. + [ "complete?" get ] bind ; + +: set-item-completed ( -- ) + [ t "complete?" set ] bind ; + +: item-description ( -- description ) + #! return the description for the todo list item. + [ "description" get ] bind ; + +: priority-comparator ( item1 item2 -- bool ) + #! Return true if item1 is a higher priority than item2 + >r item-priority r> item-priority > ; + +: todo-items ( -- ) + #! Return a list of items for the given todo list. + [ "items" get ] bind [ priority-comparator ] sort ; + +: delete-item ( -- ) + #! Delete the item from the todo list + swap dup >r todo-items remove r> [ "items" set ] bind ; + : test-todo "user" "password" dup "1" "item1" add-todo-item