basis/furnace/conversations/conversations.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
   8 furnace.cache
   9 furnace.scopes
  10 furnace.sessions
  11 furnace.redirection ;
  12 IN: furnace.conversations
  13
  14 TUPLE: conversation < scope
  15 session
  16 method url post-data ;
  17
  18 : <conversation> ( id -- aside )
  19     conversation new-server-state ;
  20
  21 conversation "CONVERSATIONS" {
  22     { "session" "SESSION" BIG-INTEGER +not-null+ }
  23     { "method" "METHOD" { VARCHAR 10 } }
  24     { "url" "URL" URL }
  25     { "post-data" "POST_DATA" FACTOR-BLOB }
  26 } define-persistent
  27
  28 : conversation-id-key "__c" ;
  29
  30 TUPLE: conversations < server-state-manager ;
  31
  32 : <conversations> ( responder -- responder' )
  33     conversations new-server-state-manager ;
  34
  35 SYMBOL: conversation
  36
  37 SYMBOL: conversation-id
  38
  39 : cget ( key -- value )
  40     conversation get scope-get ;
  41
  42 : cset ( value key -- )
  43     conversation get scope-set ;
  44
  45 : cchange ( key quot -- )
  46     conversation get scope-change ; inline
  47
  48 : get-conversation ( id -- conversation )
  49     dup [ conversation get-state ] when
  50     dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
  51
  52 : request-conversation-id ( request -- id )
  53     conversation-id-key swap request-params at string>number ;
  54
  55 : request-conversation ( request -- conversation )
  56     request-conversation-id get-conversation ;
  57
  58 : save-conversation-after ( conversation -- )
  59     conversations get save-scope-after ;
  60
  61 : set-conversation ( conversation -- )
  62     [
  63         [ conversation set ]
  64         [ id>> conversation-id set ]
  65         [ save-conversation-after ]
  66         tri
  67     ] when* ;
  68
  69 : init-conversations ( conversations -- )
  70     conversations set
  71     request get request-conversation-id
  72     get-conversation
  73     set-conversation ;
  74
  75 M: conversations call-responder*
  76     [ init-conversations ]
  77     [ conversations set ]
  78     [ call-next-method ]
  79     tri ;
  80
  81 : empty-conversastion ( -- conversation )
  82     conversation empty-scope
  83         session get id>> >>session ;
  84
  85 : touch-conversation ( conversation -- )
  86     conversations get touch-state ;
  87
  88 : add-conversation ( conversation -- )
  89     [ touch-conversation ] [ insert-tuple ] bi ;
  90
  91 : begin-conversation* ( -- conversation )
  92     empty-conversastion dup add-conversation ;
  93
  94 : begin-conversation ( -- )
  95     conversation get [
  96         begin-conversation*
  97         set-conversation
  98     ] unless ;
  99
 100 : end-conversation ( -- )
 101     conversation off
 102     conversation-id off ;
 103
 104 : <conversation-redirect> ( url seq -- response )
 105     begin-conversation
 106     [ [ get ] keep cset ] each
 107     <redirect> ;
 108
 109 : restore-conversation ( seq -- )
 110     conversation get dup [
 111         namespace>>
 112         [ '[ _ key? ] filter ]
 113         [ '[ [ _ at ] keep set ] each ]
 114         bi
 115     ] [ 2drop ] if ;
 116
 117 : begin-aside ( -- )
 118     begin-conversation
 119     conversation get
 120         request get
 121         [ method>> >>method ]
 122         [ url>> >>url ]
 123         [ post-data>> >>post-data ]
 124         tri
 125     touch-conversation ;
 126
 127 : end-aside-post ( aside -- response )
 128     request [
 129         clone
 130             over post-data>> >>post-data
 131             over url>> >>url
 132     ] change
 133     [ url>> url set ]
 134     [ url>> path>> split-path ] bi
 135     conversations get responder>> call-responder ;
 136
 137 \ end-aside-post DEBUG add-input-logging
 138
 139 ERROR: end-aside-in-get-error ;
 140
 141 : move-on ( id -- response )
 142     post-request? [ end-aside-in-get-error ] unless
 143     dup method>> {
 144         { "GET" [ url>> <redirect> ] }
 145         { "HEAD" [ url>> <redirect> ] }
 146         { "POST" [ end-aside-post ] }
 147     } case ;
 148
 149 : get-aside ( id -- conversation )
 150     get-conversation dup [ dup method>> [ drop f ] unless ] when ;
 151
 152 : end-aside* ( url id -- response )
 153     get-aside [ move-on ] [ <redirect> ] ?if ;
 154
 155 : end-aside ( default -- response )
 156     conversation-id get
 157     end-conversation
 158     end-aside* ;
 159
 160 M: conversations link-attr ( tag -- )
 161     drop
 162     "aside" optional-attr {
 163         { "none" [ conversation-id off ] }
 164         { "begin" [ begin-aside ] }
 165         { "current" [ ] }
 166         { f [ ] }
 167     } case ;
 168
 169 M: conversations modify-query ( query conversations -- query' )
 170     drop
 171     conversation-id get [
 172         conversation-id-key associate assoc-union
 173     ] when* ;
 174
 175 M: conversations modify-form ( conversations -- )
 176     drop
 177     conversation-id get
 178     conversation-id-key
 179     hidden-form-field ;