extra/furnace/flash/flash.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces assocs kernel sequences accessors
   4 urls db.types db.tuples math.parser fry
   5 http http.server http.server.filters http.server.redirection
   6 furnace furnace.cache furnace.sessions furnace.redirection ;
   7 IN: furnace.flash
   8
   9 TUPLE: flash-scope < server-state session namespace ;
  10
  11 : <flash-scope> ( id -- aside )
  12     flash-scope new-server-state ;
  13
  14 flash-scope "FLASH_SCOPES" {
  15     { "session" "SESSION" BIG-INTEGER +not-null+ }
  16     { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
  17 } define-persistent
  18
  19 : flash-id-key "__f" ;
  20
  21 TUPLE: flash-scopes < server-state-manager ;
  22
  23 : <flash-scopes> ( responder -- responder' )
  24     flash-scopes new-server-state-manager ;
  25
  26 SYMBOL: flash-scope
  27
  28 : fget ( key -- value )
  29     flash-scope get dup
  30     [ namespace>> at ] [ 2drop f ] if ;
  31
  32 : get-flash-scope ( id -- flash-scope )
  33     dup [ flash-scope get-state ] when
  34     dup [ dup session>> session get id>> = [ drop f ] unless ] when ;
  35
  36 : request-flash-scope ( request -- flash-scope )
  37     flash-id-key swap request-params at string>number get-flash-scope ;
  38
  39 M: flash-scopes call-responder*
  40     dup flash-scopes set
  41     request get request-flash-scope flash-scope set
  42     call-next-method ;
  43
  44 : make-flash-scope ( seq -- id )
  45     f <flash-scope>
  46         session get id>> >>session
  47         swap [ dup get ] H{ } map>assoc >>namespace
  48     [ flash-scopes get touch-state ] [ insert-tuple ] [ id>> ] tri ;
  49
  50 : <flash-redirect> ( url seq -- response )
  51     [ clone ] dip
  52     make-flash-scope flash-id-key set-query-param
  53     <redirect> ;
  54
  55 : restore-flash ( seq -- )
  56     flash-scope get dup [
  57         namespace>>
  58         [ '[ , key? ] filter ]
  59         [ '[ [ , at ] keep set ] each ]
  60         bi
  61     ] [ 2drop ] if ;