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 random accessors quotations hashtables sequences continuations
   5 fry calendar combinators destructors alarms
   6 db db.tuples db.types
   7 http http.server http.server.dispatchers http.server.filters
   8 html.elements furnace ;
   9 IN: furnace.sessions
  10
  11 TUPLE: session id expires uid namespace changed? ;
  12
  13 : <session> ( id -- session )
  14     session new
  15         swap >>id ;
  16
  17 session "SESSIONS"
  18 {
  19     { "id" "ID" +random-id+ system-random-generator }
  20     { "expires" "EXPIRES" TIMESTAMP +not-null+ }
  21     { "uid" "UID" { VARCHAR 255 } }
  22     { "namespace" "NAMESPACE" FACTOR-BLOB }
  23 } define-persistent
  24
  25 : get-session ( id -- session )
  26     dup [ <session> select-tuple ] when ;
  27
  28 : init-sessions-table ( -- ) session ensure-table ;
  29
  30 : start-expiring-sessions ( db seq -- )
  31     '[
  32         , , [
  33             session new
  34                 -1.0/0.0 now [a,b] >>expires
  35             delete-tuples
  36         ] with-db
  37     ] 5 minutes every drop ;
  38
  39 GENERIC: init-session* ( responder -- )
  40
  41 M: object init-session* drop ;
  42
  43 M: dispatcher init-session* default>> init-session* ;
  44
  45 M: filter-responder init-session* responder>> init-session* ;
  46
  47 TUPLE: sessions < filter-responder timeout domain ;
  48
  49 : <sessions> ( responder -- responder' )
  50     sessions new
  51         swap >>responder
  52         20 minutes >>timeout ;
  53
  54 : (session-changed) ( session -- )
  55     t >>changed? drop ;
  56
  57 : session-changed ( -- )
  58     session get (session-changed) ;
  59
  60 : sget ( key -- value )
  61     session get namespace>> at ;
  62
  63 : sset ( value key -- )
  64     session get
  65     [ namespace>> set-at ] [ (session-changed) ] bi ;
  66
  67 : schange ( key quot -- )
  68     session get
  69     [ namespace>> swap change-at ] keep
  70     (session-changed) ; inline
  71
  72 : uid ( -- uid )
  73     session get uid>> ;
  74
  75 : set-uid ( uid -- )
  76     session get [ (>>uid) ] [ (session-changed) ] bi ;
  77
  78 : init-session ( session -- )
  79     session [ sessions get init-session* ] with-variable ;
  80
  81 : cutoff-time ( -- time )
  82     sessions get timeout>> from-now ;
  83
  84 : touch-session ( session -- )
  85     cutoff-time >>expires drop ;
  86
  87 : empty-session ( -- session )
  88     f <session>
  89         H{ } clone >>namespace
  90         dup touch-session ;
  91
  92 : begin-session ( -- session )
  93     empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
  94
  95 ! Destructor
  96 TUPLE: session-saver session ;
  97
  98 C: <session-saver> session-saver
  99
 100 M: session-saver dispose
 101     session>> dup changed?>> [
 102         [ touch-session ] [ update-tuple ] bi
 103     ] [ drop ] if ;
 104
 105 : save-session-after ( session -- )
 106     <session-saver> &dispose drop ;
 107
 108 : existing-session ( path session -- response )
 109     [ session set ] [ save-session-after ] bi
 110     sessions get responder>> call-responder ;
 111
 112 : session-id-key "__s" ;
 113
 114 : cookie-session-id ( request -- id/f )
 115     session-id-key get-cookie
 116     dup [ value>> string>number ] when ;
 117
 118 : post-session-id ( request -- id/f )
 119     session-id-key swap request-params at string>number ;
 120
 121 : request-session-id ( -- id/f )
 122     request get dup method>> {
 123         { "GET" [ cookie-session-id ] }
 124         { "HEAD" [ cookie-session-id ] }
 125         { "POST" [ post-session-id ] }
 126     } case ;
 127
 128 : request-session ( -- session/f )
 129     request-session-id get-session ;
 130
 131 : <session-cookie> ( id -- cookie )
 132     session-id-key <cookie>
 133         "$sessions" resolve-base-path >>path
 134         sessions get timeout>> from-now >>expires
 135         sessions get domain>> >>domain ;
 136
 137 : put-session-cookie ( response -- response' )
 138     session get id>> number>string <session-cookie> put-cookie ;
 139
 140 M: sessions modify-form ( responder -- )
 141     drop session get id>> session-id-key hidden-form-field ;
 142
 143 M: sessions call-responder* ( path responder -- response )
 144     sessions set
 145     request-session [ begin-session ] unless*
 146     existing-session put-session-cookie ;
 147
 148 : logout-all-sessions ( uid -- )
 149     session new swap >>uid delete-tuples ;