basis/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 furnace.scopes ;
  11 IN: furnace.sessions
  12
  13 TUPLE: session < scope user-agent client ;
  14
  15 : <session> ( id -- session )
  16     session new-server-state ;
  17
  18 session "SESSIONS"
  19 {
  20     { "user-agent" "USER_AGENT" TEXT +not-null+ }
  21     { "client" "CLIENT" TEXT +not-null+ }
  22 } define-persistent
  23
  24 : get-session ( id -- session )
  25     dup [ session get-state ] when ;
  26
  27 GENERIC: init-session* ( responder -- )
  28
  29 M: object init-session* drop ;
  30
  31 M: dispatcher init-session* default>> init-session* ;
  32
  33 M: filter-responder init-session* responder>> init-session* ;
  34
  35 TUPLE: sessions < server-state-manager domain verify? ;
  36
  37 : <sessions> ( responder -- responder' )
  38     sessions new-server-state-manager
  39         t >>verify? ;
  40
  41 : session-changed ( -- )
  42     session get scope-changed ;
  43
  44 : sget ( key -- value ) session get scope-get ;
  45
  46 : sset ( value key -- ) session get scope-set ;
  47
  48 : schange ( key quot -- ) session get scope-change ; inline
  49
  50 : init-session ( session -- )
  51     session [ sessions get init-session* ] with-variable ;
  52
  53 : touch-session ( session -- )
  54     sessions get touch-state ;
  55
  56 : remote-host ( -- string )
  57     {
  58         [ request get "x-forwarded-for" header ]
  59         [ remote-address get host>> ]
  60     } 0|| ;
  61
  62 : empty-session ( -- session )
  63     session empty-scope
  64         remote-host >>client
  65         user-agent >>user-agent
  66         dup touch-session ;
  67
  68 : begin-session ( -- session )
  69     empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
  70
  71 : save-session-after ( session -- )
  72     sessions get save-scope-after ;
  73
  74 : existing-session ( path session -- response )
  75     [ session set ] [ save-session-after ] bi
  76     sessions get responder>> call-responder ;
  77
  78 : session-id-key "__s" ;
  79
  80 : verify-session ( session -- session )
  81     sessions get verify?>> [
  82         dup [
  83             dup
  84             [ client>> remote-host = ]
  85             [ user-agent>> user-agent = ]
  86             bi and [ drop f ] unless
  87         ] when
  88     ] when ;
  89
  90 : request-session ( -- session/f )
  91     session-id-key
  92     client-state dup string? [ string>number ] when
  93     get-session verify-session ;
  94
  95 : <session-cookie> ( -- cookie )
  96     session get id>> session-id-key <cookie>
  97         "$sessions" resolve-base-path >>path
  98         sessions get domain>> >>domain ;
  99
 100 : put-session-cookie ( response -- response' )
 101     <session-cookie> put-cookie ;
 102
 103 M: sessions modify-form ( responder -- )
 104     drop session get id>> session-id-key hidden-form-field ;
 105
 106 M: sessions call-responder* ( path responder -- response )
 107     sessions set
 108     request-session [ begin-session ] unless*
 109     existing-session put-session-cookie ;
 110
 111 SLOT: session
 112
 113 : check-session ( state/f -- state/f )
 114     dup [ dup session>> session get id>> = [ drop f ] unless ] when ;