basis/furnace/conversations/conversations.factor

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