extra/furnace/asides/asides.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors namespaces sequences arrays kernel
   4 assocs assocs.lib hashtables math.parser urls combinators
   5 html.elements html.templates.chloe.syntax db.types db.tuples
   6 http http.server http.server.filters
   7 furnace furnace.cache furnace.sessions furnace.redirection ;
   8 IN: furnace.asides
   9
  10 TUPLE: aside < server-state session method url post-data ;
  11
  12 : <aside> ( id -- aside )
  13     aside new-server-state ;
  14
  15 aside "ASIDES"
  16 {
  17     { "session" "SESSION" BIG-INTEGER +not-null+ }
  18     { "method" "METHOD" { VARCHAR 10 } +not-null+ }
  19     { "url" "URL" URL +not-null+ }
  20     { "post-data" "POST_DATA" FACTOR-BLOB }
  21 } define-persistent
  22
  23 TUPLE: asides < server-state-manager ;
  24
  25 : <asides> ( responder -- responder' )
  26     asides new-server-state-manager ;
  27
  28 : begin-aside* ( -- id )
  29     f <aside>
  30         session get id>> >>session
  31         request get
  32         [ method>> >>method ]
  33         [ url>> >>url ]
  34         [ post-data>> >>post-data ]
  35         tri
  36     [ asides get touch-state ] [ insert-tuple ] [ id>> ] tri ;
  37
  38 : end-aside-post ( aside -- response )
  39     request [
  40         clone
  41             over post-data>> >>post-data
  42             over url>> >>url
  43     ] change
  44     url>> path>> split-path
  45     asides get responder>> call-responder ;
  46
  47 ERROR: end-aside-in-get-error ;
  48
  49 : get-aside ( id -- aside )
  50     dup [ aside get-state ] when
  51     dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
  52
  53 : end-aside* ( url id -- response )
  54     post-request? [ end-aside-in-get-error ] unless
  55     aside get-state [
  56         dup method>> {
  57             { "GET" [ url>> <redirect> ] }
  58             { "HEAD" [ url>> <redirect> ] }
  59             { "POST" [ end-aside-post ] }
  60         } case
  61     ] [ <redirect> ] ?if ;
  62
  63 SYMBOL: aside-id
  64
  65 : aside-id-key "__a" ;
  66
  67 : begin-aside ( -- )
  68     begin-aside* aside-id set ;
  69
  70 : end-aside ( default -- response )
  71     aside-id [ f ] change end-aside* ;
  72
  73 : request-aside-id ( request -- aside-id )
  74     aside-id-key swap request-params at string>number ;
  75
  76 M: asides call-responder*
  77     dup asides set
  78     request get request-aside-id aside-id set
  79     call-next-method ;
  80
  81 M: asides link-attr ( tag -- )
  82     drop
  83     "aside" optional-attr {
  84         { "none" [ aside-id off ] }
  85         { "begin" [ begin-aside ] }
  86         { "current" [ ] }
  87         { f [ ] }
  88     } case ;
  89
  90 M: asides modify-query ( query responder -- query' )
  91     drop
  92     aside-id get [ aside-id-key associate assoc-union ] when* ;
  93
  94 M: asides modify-form ( responder -- )
  95     drop aside-id get aside-id-key hidden-form-field ;