extra/furnace/sessions/sessions.factor

   1 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs kernel math.intervals math.parser namespaces
   4 strings random accessors quotations hashtables sequences continuations
   5 fry calendar combinators combinators.short-circuit destructors alarms
   6 io.servers.connection
   7 db db.tuples db.types
   8 http http.server http.server.dispatchers http.server.filters
   9 html.elements
  10 furnace furnace.cache ;
  11 IN: furnace.sessions
  12
  13 TUPLE: session < server-state namespace user-agent client changed? ;
  14
  15 : <session> ( id -- session )
  16     session new-server-state ;
  17
  18 session "SESSIONS"
  19 {
  20     { "namespace" "NAMESPACE" FACTOR-BLOB +not-null+ }
  21     { "user-agent" "USER_AGENT" TEXT +not-null+ }
  22     { "client" "CLIENT" TEXT +not-null+ }
  23 } define-persistent
  24
  25 : get-session ( id -- session )
  26     dup [ session get-state ] when ;
  27
  28 GENERIC: init-session* ( responder -- )
  29
  30 M: object init-session* drop ;
  31
  32 M: dispatcher init-session* default>> init-session* ;
  33
  34 M: filter-responder init-session* responder>> init-session* ;
  35
  36 TUPLE: sessions < server-state-manager domain verify? ;
  37
  38 : <sessions> ( responder -- responder' )
  39     sessions new-server-state-manager
  40         t >>verify? ;
  41
  42 : (session-changed) ( session -- )
  43     t >>changed? drop ;
  44
  45 : session-changed ( -- )
  46     session get (session-changed) ;
  47
  48 : sget ( key -- value )
  49     session get namespace>> at ;
  50
  51 : sset ( value key -- )
  52     session get
  53     [ namespace>> set-at ] [ (session-changed) ] bi ;
  54
  55 : schange ( key quot -- )
  56     session get
  57     [ namespace>> swap change-at ] keep
  58     (session-changed) ; inline
  59
  60 : init-session ( session -- )
  61     session [ sessions get init-session* ] with-variable ;
  62
  63 : touch-session ( session -- )
  64     sessions get touch-state ;
  65
  66 : remote-host ( -- string )
  67     {
  68         [ request get "x-forwarded-for" header ]
  69         [ remote-address get host>> ]
  70     } 0|| ;
  71
  72 : empty-session ( -- session )
  73     f <session>
  74         H{ } clone >>namespace
  75         remote-host >>client
  76         user-agent >>user-agent
  77         dup touch-session ;
  78
  79 : begin-session ( -- session )
  80     empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
  81
  82 ! Destructor
  83 TUPLE: session-saver session ;
  84
  85 C: <session-saver> session-saver
  86
  87 M: session-saver dispose
  88     session>> dup changed?>> [
  89         [ touch-session ] [ update-tuple ] bi
  90     ] [ drop ] if ;
  91
  92 : save-session-after ( session -- )
  93     <session-saver> &dispose drop ;
  94
  95 : existing-session ( path session -- response )
  96     [ session set ] [ save-session-after ] bi
  97     sessions get responder>> call-responder ;
  98
  99 : session-id-key "__s" ;
 100
 101 : verify-session ( session -- session )
 102     sessions get verify?>> [
 103         dup [
 104             dup
 105             [ client>> remote-host = ]
 106             [ user-agent>> user-agent = ]
 107             bi and [ drop f ] unless
 108         ] when
 109     ] when ;
 110
 111 : request-session ( -- session/f )
 112     session-id-key
 113     client-state dup string? [ string>number ] when
 114     get-session verify-session ;
 115
 116 : <session-cookie> ( -- cookie )
 117     session get id>> session-id-key <cookie>
 118         "$sessions" resolve-base-path >>path
 119         sessions get domain>> >>domain ;
 120
 121 : put-session-cookie ( response -- response' )
 122     <session-cookie> put-cookie ;
 123
 124 M: sessions modify-form ( responder -- )
 125     drop session get id>> session-id-key hidden-form-field ;
 126
 127 M: sessions call-responder* ( path responder -- response )
 128     sessions set
 129     request-session [ begin-session ] unless*
 130     existing-session put-session-cookie ;