extra/webapps/todo/todo.factor

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