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-id
  50     get-aside
  51     set-aside ;
  52
  53 M: asides call-responder*
  54     [ init-asides ] [ call-next-method ] bi ;
  55
  56 : touch-aside ( aside -- )
  57     asides get touch-state ;
  58
  59 : begin-aside ( url -- )
  60     f <aside>
  61         swap >>url
  62         session get id>> >>session
  63         request get method>> >>method
  64         request get post-data>> >>post-data
  65     [ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
  66
  67 : end-aside-post ( aside -- response )
  68     request [
  69         clone
  70             over post-data>> >>post-data
  71             over url>> >>url
  72     ] change
  73     [ [ post-data>> params>> params set ] [ url>> url set ] bi ]
  74     [ url>> path>> split-path asides get responder>> call-responder ] bi ;
  75
  76 \ end-aside-post DEBUG add-input-logging
  77
  78 ERROR: end-aside-in-get-error ;
  79
  80 : move-on ( id -- response )
  81     post-request? [ end-aside-in-get-error ] unless
  82     dup method>> {
  83         { "GET" [ url>> <redirect> ] }
  84         { "HEAD" [ url>> <redirect> ] }
  85         { "POST" [ end-aside-post ] }
  86     } case ;
  87
  88 : end-aside ( default -- response )
  89     aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
  90
  91 M: asides link-attr ( tag -- )
  92     drop
  93     "aside" optional-attr {
  94         { "none" [ aside-id off ] }
  95         { "begin" [ url get begin-aside ] }
  96         { "current" [ ] }
  97         { f [ ] }
  98     } case ;
  99
 100 M: asides modify-query ( query asides -- query' )
 101     drop
 102     aside-id get [
 103         aside-id-key associate assoc-union
 104     ] when* ;
 105
 106 M: asides modify-form ( asides -- )
 107     drop
 108     aside-id get
 109     aside-id-key
 110     hidden-form-field ;