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