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