extra/webapps/todo/todo.factor

   1 ! Copyright (c) 2008 Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors kernel sequences namespaces
   4 db db.types db.tuples validators hashtables urls
   5 html.forms
   6 html.components
   7 html.templates.chloe
   8 http.server
   9 http.server.dispatchers
  10 furnace
  11 furnace.boilerplate
  12 furnace.auth
  13 furnace.actions
  14 furnace.redirection
  15 furnace.db
  16 furnace.auth.login ;
  17 IN: webapps.todo
  18
  19 TUPLE: todo-list < dispatcher ;
  20
  21 TUPLE: todo uid id priority summary description ;
  22
  23 todo "TODO"
  24 {
  25     { "uid" "UID" { VARCHAR 256 } +not-null+ }
  26     { "id" "ID" +db-assigned-id+ }
  27     { "priority" "PRIORITY" INTEGER +not-null+ }
  28     { "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
  29     { "description" "DESCRIPTION" { VARCHAR 256 } }
  30 } define-persistent
  31
  32 : <todo> ( id -- todo )
  33     todo new
  34         swap >>id
  35         username >>uid ;
  36
  37 : <view-action> ( -- action )
  38     <page-action>
  39         [
  40             validate-integer-id
  41             "id" value <todo> select-tuple from-object
  42         ] >>init
  43
  44         { todo-list "view-todo" } >>template ;
  45
  46 : validate-todo ( -- )
  47     {
  48         { "summary" [ v-one-line ] }
  49         { "priority" [ v-integer 0 v-min-value 10 v-max-value ] }
  50         { "description" [ v-required ] }
  51     } validate-params ;
  52
  53 : view-todo-url ( id -- url )
  54     <url> "$todo-list/view" >>path swap "id" set-query-param ;
  55
  56 : <new-action> ( -- action )
  57     <page-action>
  58         [ 0 "priority" set-value ] >>init
  59
  60         { todo-list "new-todo" } >>template
  61
  62         [ validate-todo ] >>validate
  63
  64         [
  65             f <todo>
  66                 dup { "summary" "priority" "description" } to-object
  67             [ insert-tuple ] [ id>> view-todo-url <redirect> ] bi
  68         ] >>submit ;
  69
  70 : <edit-action> ( -- action )
  71     <page-action>
  72         [
  73             validate-integer-id
  74             "id" value <todo> select-tuple from-object
  75         ] >>init
  76
  77         { todo-list "edit-todo" } >>template
  78
  79         [
  80             validate-integer-id
  81             validate-todo
  82         ] >>validate
  83
  84         [
  85             f <todo>
  86                 dup { "id" "summary" "priority" "description" } to-object
  87             [ update-tuple ] [ id>> view-todo-url <redirect> ] bi
  88         ] >>submit ;
  89
  90 : todo-list-url ( -- url )
  91     URL" $todo-list/list" ;
  92
  93 : <delete-action> ( -- action )
  94     <action>
  95         [ validate-integer-id ] >>validate
  96
  97         [
  98             "id" get <todo> delete-tuples
  99             todo-list-url <redirect>
 100         ] >>submit ;
 101
 102 : <list-action> ( -- action )
 103     <page-action>
 104         [ f <todo> select-tuples "items" set-value ] >>init
 105         { todo-list "todo-list" } >>template ;
 106
 107 : <todo-list> ( -- responder )
 108     todo-list new-dispatcher
 109         <list-action>   "list"       add-responder
 110         URL" /list" <redirect-responder> "" add-responder
 111         <view-action>   "view"   add-responder
 112         <new-action>    "new"    add-responder
 113         <edit-action>   "edit"   add-responder
 114         <delete-action> "delete" add-responder
 115     <boilerplate>
 116         { todo-list "todo" } >>template
 117     <protected>
 118         "view your todo list" >>description ;
 119
 120 USING: furnace.auth.features.registration
 121 furnace.auth.features.edit-profile
 122 furnace.auth.features.deactivate-user
 123 db.sqlite
 124 furnace.alloy
 125 io.servers.connection
 126 io.sockets.secure ;
 127
 128 : <login-config> ( responder -- responder' )
 129     "Todo list" <login-realm>
 130         "Todo list" >>name
 131         allow-registration
 132         allow-edit-profile
 133         allow-deactivation ;
 134
 135 : todo-db ( -- db ) "resource:todo.db" <sqlite-db> ;
 136
 137 : init-todo-db ( -- )
 138     todo-db [
 139         init-furnace-tables
 140         todo ensure-table
 141     ] with-db ;
 142
 143 : <todo-secure-config> ( -- config )
 144     ! This is only suitable for testing!
 145     <secure-config>
 146         "vocab:openssl/test/dh1024.pem" >>dh-file
 147         "vocab:openssl/test/server.pem" >>key-file
 148         "password" >>password ;
 149
 150 : <todo-app> ( -- responder )
 151     init-todo-db
 152     <todo-list>
 153         <login-config>
 154         todo-db <alloy> ;
 155
 156 : <todo-website-server> ( -- threaded-server )
 157     <http-server>
 158         <todo-secure-config> >>secure-config
 159         8080 >>insecure
 160         8431 >>secure ;
 161
 162 : run-todo ( -- )
 163     <todo-app> main-responder set-global
 164     todo-db start-expiring
 165     <todo-website-server> start-server ;
 166
 167 MAIN: run-todo