basis/furnace/asides/asides.factor

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