unmaintained/scaffold/scaffold.factor

   1 USING: http.server help.markup help.syntax kernel prettyprint
   2 sequences parser namespaces words classes math tuples.private
   3 quotations arrays strings ;
   4
   5 IN: furnace.scaffold
   6
   7 TUPLE: furnace-model model ;
   8 C: <furnace-model> furnace-model
   9
  10 HELP: furnace-model "This definition exists to circumvent a limitation in furnace with regard to sending arbitrary objects as models to .furnace templates." ;
  11
  12 : crud-create ( class string -- word )
  13     swap unparse "-" rot 3append in get create ;
  14
  15 HELP: crud-create
  16 { $values { "class" class } { "string" string } { "word" word } }
  17 { $description "A CRUD utility function - creates a new action word for a given class and suffix string" } ;
  18
  19 : crud-word ( class string -- word )
  20     swap unparse "-" rot 3append parse first ;
  21 HELP: crud-word
  22 { $values { "class" class } { "string" string } { "word" word } }
  23 { $description "A CRUD utility function - looks up a word that has been crud-created" } ;
  24
  25 : crud-index ( tuple -- )
  26     dup class dup "crud-index" word-prop crud-word execute ;
  27
  28 : crud-lookup ( string class -- obj )
  29     get-global [ crud-index = ] curry* subset
  30     dup empty? [ drop f ] [ first ] if ;
  31 HELP: crud-lookup
  32 { $values { "string" string } { "class" class } { "obj" object } }
  33 { $description "A CRUD utility function - looks up an object in the store by the pre-designated index." } ;
  34
  35 : crud-lookup* ( string class -- tuple )
  36     tuck crud-lookup
  37     [ ] [ dup "slot-names" word-prop length 2 + <tuple> ] ?if ;
  38
  39 HELP: crud-lookup*
  40 { $values { "string" string } { "class" class } { "tuple" tuple } }
  41 "A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class.  When the lookup fails, returns a tuple of the given class with all slots set to f." ;
  42
  43 : render-page ( model template title -- )
  44     [
  45         [ render-component ] simple-html-document
  46     ] serve-html ;
  47
  48 : crud-page ( model template title -- )
  49     [ "libs/furnace/crud-templates" template-path set render-page ]
  50     with-scope ;
  51
  52 : define-list ( class -- word )
  53     dup "list" crud-create swap
  54     [ dup get-global dup empty? -rot ? <furnace-model> "list" "List" crud-page ]
  55     curry dupd define-compound ;
  56
  57 : define-show ( class -- word )
  58     dup "show" crud-create swap
  59     [ crud-lookup <furnace-model> "show" "Show" crud-page ]
  60     curry dupd define-compound ;
  61
  62 : define-edit ( class -- word )
  63     dup "edit" crud-create swap
  64     [ crud-lookup* <furnace-model> "edit" "Edit" crud-page ]
  65     curry dupd define-compound ;
  66
  67 : define-new ( class -- word )
  68     dup "new" crud-create swap "edit" crud-word
  69     [ f swap execute ]
  70     curry dupd define-compound ;
  71
  72 : define-update ( class -- word )
  73     dup "update" crud-create swap
  74     [
  75         tuck crud-lookup [ over get-global remove over set-global ] when*
  76         dup >r "constructor" word-prop execute
  77         r> 2dup get-global swap add over set-global swap
  78         crud-index swap "show" crud-word execute
  79     ] curry dupd define-compound ;
  80
  81 : define-delete ( class -- word )
  82     dup "delete" crud-create swap
  83     [
  84         tuck crud-lookup [ over get-global remove over set-global ] when*
  85         "list" crud-word execute
  86     ] curry dupd define-compound ;
  87
  88 : define-lookup ( class -- )
  89     dup "crud-index" word-prop ">" pick unparse 3append in get create
  90     swap [ crud-lookup ] curry define-compound ;
  91
  92 : define-lookup* ( class -- )
  93     dup "crud-index" word-prop ">" pick unparse "*" append 3append
  94     in get create swap [ crud-lookup* ] curry define-compound ;
  95
  96 : scaffold-params ( class -- array )
  97     "crud-index" word-prop 1array 1array ;
  98
  99 : scaffold ( class index realm -- )
 100     -rot dupd "crud-index" set-word-prop
 101     [ define-lookup ] keep [ define-lookup* ] keep
 102     [ get-global [ { } over set-global ] unless ] keep
 103     [ define-list { } rot define-authenticated-action ] 2keep
 104     [ dup define-show swap scaffold-params rot
 105         define-authenticated-action ] 2keep
 106     [ dup define-edit swap scaffold-params rot
 107         define-authenticated-action ] 2keep
 108     [ define-new { } rot define-authenticated-action ] 2keep
 109     [ dup define-update swap "slot-names" word-prop
 110         "crud-index" add [ 1array ] map rot
 111         define-authenticated-action ] 2keep
 112     dup define-delete swap scaffold-params rot
 113     define-authenticated-action ;
 114
 115 HELP: scaffold
 116 { $values { "class" class } { "index" "an index" } { "realm" "a realm" } }
 117 "If realm is not f, then realm is used as the basic authentication realm for the scaffolding actions." ;
 118
 119 ARTICLE: { "furnace" "crud" } "CRUD Scaffolding"
 120 { $code
 121     "\"libs/furnace\" require"
 122     "USING: furnace httpd threads ;"
 123     "IN: furnace:crud-example"
 124     "TUPLE: foo bar baz ;"
 125     "\"crud-example\" \"foo-list\" f web-app"
 126     "foo \"bar\" f scaffold"
 127     "[ 8888 httpd ] in-thread"
 128 } ;