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

@@ -53,8 +53,9 @@ USE: prettyprint
         <input type= "submit" value= "Ok" input/>
       ] </form>
     ] 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.

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 [ <tag> [ ] write-tag ] cons t swons 
-  swap [ <tag> >n f ] cons t swons
+  dup [ <tag> [ ] write-tag ] cons f swons 
+  swap [ <tag> >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

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 <namespace> 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 ;
 

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,6 +38,8 @@ USE: inspector
 USE: lists
 USE: combinators
 USE: cont-examples
+USE: regexp
+USE: prettyprint
 USE: todo
  
 : simple-todo-page ( title quot -- )
@@ -51,6 +54,19 @@ USE: todo
   #! 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-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.
   <input type= "text" size= "20" name= input/> ;
 
+: textarea-input ( name -- )
+  #! Output a simple HTML textarea field which will have the
+  #! specified name.
+  <input type= "text" size= "60" name= input/> ;
+!  <textarea name= textarea> [ "Enter description here." write ] </textarea> ;
+
+: password-input ( name -- )
+  #! Output an HTML password input field which will have the
+  #! specified name.
+  <input type= "password" size= "20" name= input/> ;
+
 : button ( label -- )
   #! Output an HTML submit button with the given label.
   <input type= "submit" value= input/> ;
 
-: 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.
-  <form method= "post" action= form> [ call ] </form> ;
+  <form method= "post" action= swap form> swap </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-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 <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 form them.
-  [ 
-    "Register New TODO List"
-    [
-      [
-        "<table>" write
-          [ [ "Name:" write ] [ "name" simple-input ] ] row
-          [ [ "Password:" write ] [ "password" simple-input ] ] row
-        "</table>" write
-        "Register" button     
-      ] swap form
-    ] simple-todo-page
-  ] show alist>namespace [
-    "name" get dup "password" get 
-  ] bind 
-  <todo> dup "1" "Set up todo list" <todo-item> 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
+  ] [
+    <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"
-    [      
-      <p> [ "Please enter your username and password (" write
-            "Click to Register" [ register-new-user ] quot-href
-            "):" write
-          ] </p>     
-      [
-        "<table>" write 
-          [ [ "Username:" write ] [ "username" simple-input ] ] row
-          [ [ "Password:" write ] [ "password" simple-input ] ] row
-        "</table>" 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 ( -- <todo> )
   #! Prompts for a username or password until a valid combination
   #! is entered then returns the <todo> 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 ( -- <todo-item> )
+: write-new-todo-item-form ( url -- )
+  #! Display the HTML for a form allowing entry of a 
+  #! todo item details.
+  [
+    <table> [
+      [ [ "Priority:" write ]    [ "priority" simple-input ] ] row
+      [ [ "Description:" write ] [ "description" textarea-input ] ] row
+    ] </table>
+    "Add" button
+  ] form ;
+  
+: get-new-todo-item ( -- <todo-item> )
   #! Enter a new item to the current todo list.
   [
-    "Enter New Todo Item"
-    [
-      [
-        "<table>" write
-          [ [ "Priority:" write ]    [ "priority" simple-input ] ] row
-          [ [ "Description:" write ] [ "description" simple-input ] ] row
-        "</table>" 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 <todo-item> 
   ] 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 ( <todo-item> -- )
+  #! 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 ( <todo> -- )
+  #! Write the table of items for the todo list.
+  <table> [
+    [ [ "Priority" write ] [ "Complete?" write ] [ "Description" write ] [ "Action" write ] ] 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 ;
+
+: 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 [
-	"<table>" write 
-          [ [ "Priority" write ] [ "Complete?" write ] [ "Description" write ] ] row
-          [
-            [ [ "priority" get write ] 
-              [ "complete?" get [ "Yes" ] [ "No" ] ifte write ] 
-              [ "description" get write ] ] row
-          ] items-each-bind         
-        "</table>" 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

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 ( <todo> -- username )
+  #! return the username for the todo list item.
+  [ "user" get ] bind ;
+
+: item-priority ( <todo-item> -- priority )
+  #! return the priority for the todo list item.
+  [ "priority" get ] bind ;
+
+: item-complete? ( <todo-item> -- boolean )
+  #! return true if the todo list item is completed.
+  [ "complete?" get ] bind ;
+
+: set-item-completed ( <todo-item> -- )
+  [ t "complete?" set ] bind ;
+
+: item-description ( <todo-item> -- 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 ( <todo> -- )
+  #! Return a list of items for the given todo list.
+  [ "items" get ] bind [ 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