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