basis/furnace/asides/asides.factor

   1 ! Copyright (C) 2008 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 ] [ asides set ] [ call-next-method ] tri ;
  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     [ url>> ] [ post-data>> ] bi
  69     request [
  70         clone
  71             swap >>post-data
  72             over >>url
  73     ] change
  74     [ url set ] [ path>> split-path ] bi
  75     asides get responder>> call-responder ;
  76
  77 \ end-aside-post DEBUG add-input-logging
  78
  79 ERROR: end-aside-in-get-error ;
  80
  81 : move-on ( id -- response )
  82     post-request? [ end-aside-in-get-error ] unless
  83     dup method>> {
  84         { "GET" [ url>> <redirect> ] }
  85         { "HEAD" [ url>> <redirect> ] }
  86         { "POST" [ end-aside-post ] }
  87     } case ;
  88
  89 : end-aside ( default -- response )
  90     aside-id get aside-id off get-aside [ move-on ] [ <redirect> ] ?if ;
  91
  92 M: asides link-attr ( tag -- )
  93     drop
  94     "aside" optional-attr {
  95         { "none" [ aside-id off ] }
  96         { "begin" [ url get begin-aside ] }
  97         { "current" [ ] }
  98         { f [ ] }
  99     } case ;
 100
 101 M: asides modify-query ( query asides -- query' )
 102     drop
 103     aside-id get [
 104         aside-id-key associate assoc-union
 105     ] when* ;
 106
 107 M: asides modify-form ( asides -- )
 108     drop
 109     aside-id get
 110     aside-id-key
 111     hidden-form-field ;