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.cache
   8 furnace.scopes
   9 furnace.sessions
  10 furnace.utilities
  11 furnace.redirection ;
  12 IN: furnace.conversations
  13
  14 TUPLE: conversation < scope session ;
  15
  16 : <conversation> ( id -- conversation )
  17     conversation new-server-state ;
  18
  19 conversation "CONVERSATIONS" {
  20     { "session" "SESSION" BIG-INTEGER +not-null+ }
  21 } define-persistent
  22
  23 CONSTANT: conversation-id-key "__c"
  24
  25 TUPLE: conversations < server-state-manager ;
  26
  27 : <conversations> ( responder -- responder' )
  28     conversations new-server-state-manager ;
  29
  30 SYMBOL: conversation
  31
  32 SYMBOL: conversation-id
  33
  34 : cget ( key -- value )
  35     conversation get scope-get ;
  36
  37 : cset ( value key -- )
  38     conversation get scope-set ;
  39
  40 : cchange ( key quot -- )
  41     conversation get scope-change ; inline
  42
  43 : get-conversation ( id -- conversation )
  44     dup [ conversation get-state ] when check-session ;
  45
  46 : request-conversation-id ( request -- id )
  47     conversation-id-key swap request-params at string>number ;
  48
  49 : request-conversation ( request -- conversation )
  50     request-conversation-id get-conversation ;
  51
  52 : save-conversation-after ( conversation -- )
  53     conversations get save-scope-after ;
  54
  55 : set-conversation ( conversation -- )
  56     [
  57         [ conversation set ]
  58         [ id>> conversation-id set ]
  59         [ save-conversation-after ]
  60         tri
  61     ] when* ;
  62
  63 : init-conversations ( conversations -- )
  64     conversations set
  65     request get request-conversation-id
  66     get-conversation
  67     set-conversation ;
  68
  69 M: conversations call-responder*
  70     [ init-conversations ]
  71     [ conversations set ]
  72     [ call-next-method ]
  73     tri ;
  74
  75 : empty-conversastion ( -- conversation )
  76     conversation empty-scope
  77         session get id>> >>session ;
  78
  79 : touch-conversation ( conversation -- )
  80     conversations get touch-state ;
  81
  82 : add-conversation ( conversation -- )
  83     [ touch-conversation ] [ insert-tuple ] bi ;
  84
  85 : begin-conversation ( -- )
  86     conversation get [
  87         empty-conversastion
  88         [ add-conversation ]
  89         [ set-conversation ] bi
  90     ] unless ;
  91
  92 : end-conversation ( -- )
  93     conversation off
  94     conversation-id off ;
  95
  96 : <continue-conversation> ( url -- response )
  97     conversation-id get
  98     conversation-id-key
  99     set-query-param
 100     <redirect> ;
 101
 102 : restore-conversation ( seq -- )
 103     conversation get dup [
 104         namespace>>
 105         [ '[ _ key? ] filter ]
 106         [ '[ [ _ at ] keep set ] each ]
 107         bi
 108     ] [ 2drop ] if ;
 109
 110 M: conversations modify-form ( conversations -- xml/f )
 111     drop
 112     conversation-id get
 113     conversation-id-key
 114     hidden-form-field ;