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
  66     set-conversation ;
  67
  68 M: conversations call-responder*
  69     [ init-conversations ]
  70     [ conversations set ]
  71     [ call-next-method ]
  72     tri ;
  73
  74 : empty-conversastion ( -- conversation )
  75     conversation empty-scope
  76         session get id>> >>session ;
  77
  78 : touch-conversation ( conversation -- )
  79     conversations get touch-state ;
  80
  81 : add-conversation ( conversation -- )
  82     [ touch-conversation ] [ insert-tuple ] bi ;
  83
  84 : begin-conversation ( -- )
  85     conversation get [
  86         empty-conversastion
  87         [ add-conversation ]
  88         [ set-conversation ] bi
  89     ] unless ;
  90
  91 : end-conversation ( -- )
  92     conversation off
  93     conversation-id off ;
  94
  95 : <continue-conversation> ( url -- response )
  96     conversation-id get
  97     conversation-id-key
  98     set-query-param
  99     <redirect> ;
 100
 101 : restore-conversation ( seq -- )
 102     conversation get [
 103         namespace>>
 104         [ '[ _ key? ] filter ]
 105         [ '[ [ _ at ] keep set ] each ]
 106         bi
 107     ] [ drop ] if* ;
 108
 109 M: conversations modify-form
 110     drop
 111     conversation-id get
 112     conversation-id-key
 113     hidden-form-field ;