Bivio::Delegate::Cookie
# Copyright (c) 2004-2010 bivio Software, Inc. All Rights Reserved. # $Id$ package Bivio::Delegate::Cookie; use strict; use Bivio::Base 'Collection.Attributes'; use Bivio::IO::Trace; # C<Bivio::Delegate::Cookie> manages cookies arriving via HTTP and # returns cookies to the user. By default cookies are persistent. Temporary # cookies do not set the 'max-age' field. A cookie can be set to time-out # after a period of activity. Cookie fields must begin with a letter. our($_TRACE); my($_MODIFIED_FIELD) = '_modified'; my($_PRIOR_TAG_FIELD) = '_prior_tag'; my($_ESC) = "\027"; my($_SEP) = "\036"; my($_ESC_ESC) = "${_ESC}E"; my($_ESC_SEP) = "${_ESC}S"; my($_DT) = b_use('Type.DateTime'); my($_S) = b_use('Type.Secret'); # 10 years my($_MAX_AGE) = "; max-age=31536000"; b_use('IO.Config')->register(my $_CFG = { domain => undef, tag => 'A', prior_tags => undef, is_temporary => 0, session_timeout_seconds => undef, session_update_seconds => undef, }); sub DATE_TIME_FIELD { return 'd'; } sub assert_is_ok { my($proto, $req) = @_; return unless $req->get('Type.UserAgent')->is_browser; $req->throw_die('MISSING_COOKIES', { client_addr => $req->unsafe_get('client_addr'), }) unless $req->get('cookie')->unsafe_get($proto->DATE_TIME_FIELD); return; } sub delete { my($self) = shift; _trace(\@_) if $_TRACE; my($res) = $self->SUPER::delete(@_); $self->put; return $res; } sub delete_all { die('not supported'); } sub handle_config { my(undef, $cfg) = @_; $cfg = b_use('IO.Ref')->nested_copy($cfg); $cfg->{session_update_seconds} = int($cfg->{session_timeout_seconds}/20) if $cfg->{session_timeout_seconds} && !defined($cfg->{session_update_seconds}); $cfg->{prior_tags} = $cfg->{prior_tags} && @{$cfg->{prior_tags}} ? [map( ref($_) ? [uc($_->[0]), lc($_->[1])] : [uc($_)], @{$cfg->{prior_tags}} )] : undef; $cfg->{tag} = uc($cfg->{tag}); $_CFG = $cfg; return; } sub header_out { my($self, $req, $r) = @_; my($fields) = $self->internal_get; return 0 unless _need_header_out($self, $fields, $req); my($domain) = $_CFG->{domain} ? b_use('UI.Facade')->get_from_request_or_self($req) ->unsafe_get('cookie_domain') || $_CFG->{domain} : undef; $fields->{$self->DATE_TIME_FIELD} = $_DT->now; my($p) = '; path=/'; $p .= (my $domain_prefix = "; domain=$domain") if $domain; $p .= $_MAX_AGE unless $_CFG->{is_temporary}; _trace('data=', $fields) if $_TRACE; my($clear_text) = ''; while (my($k, $v) = each(%$fields)) { next unless $k =~ /^[a-z]/i; $clear_text .= "$k$_SEP$v$_SEP" if defined($v); } chop($clear_text); my($value) = $_CFG->{tag} . '=' . $_S->encrypt_http_base64($clear_text) . $p . '; HttpOnly' . ($req->agent_execution_is_secure ? '; Secure' : ''); _trace($value) if $_TRACE; $req->get('reply')->send_append_header($r, 'Set-Cookie', $value); _clear_prior_tags($req) if $fields->{$_PRIOR_TAG_FIELD}; return 1; } sub new { my($proto, $req, $r) = @_; return $proto->SUPER::new( $req->get('Type.UserAgent')->is_browser ? _parse($proto, $r->header_in('Cookie') || '') : {}); } sub put { my($self) = shift; my(%values) = @_; foreach my $key (keys(%values)) { b_die('keys must start with a letter: ', $key) unless $key =~ /^[a-z]/i; } _trace(\@_) if $_TRACE; return $self->SUPER::put(@_, $_MODIFIED_FIELD => 1); } sub unsafe_get_escaped { my($self) = shift; my($value); if ($value = $self->unsafe_get(@_)) { $value =~ s/$_ESC_SEP/$_SEP/g; $value =~ s/$_ESC_ESC/$_ESC/g; } return $value; } sub put_escaped { my($self, %values) = @_; foreach my $value (values(%values)) { $value =~ s/$_ESC/$_ESC_ESC/g; $value =~ s/$_SEP/$_ESC_SEP/g; } return $self->put(%values); } sub _clear_prior_tags { my($req) = @_; my($r) = $req->get('r'); # cookie has already been set, need to append multiple Set-Cookie vlaues foreach my $prior_tag (@{$_CFG->{prior_tags}}) { my($tag, $domain) = @$prior_tag; my($h) = $r->hostname; foreach my $d ( undef, $h, !$domain ? () : $domain eq $h ? () : $domain, ) { $req->get('reply')->send_append_header( $r, 'Set-Cookie', "$tag=; path=/; max-age=0" . ($d ? "; domain=$d" : ''), ); } } return; } sub _need_header_out { my($self, $fields, $req) = @_; return 0 unless $req->get('Type.UserAgent')->is_browser; return 1 if $fields->{$_MODIFIED_FIELD}; return 0 unless $_CFG->{session_timeout_seconds}; return 1 unless $_CFG->{session_update_seconds} && $fields->{$self->DATE_TIME_FIELD}; return $_DT->compare( $_DT->add_seconds( $fields->{$self->DATE_TIME_FIELD}, $_CFG->{session_update_seconds}, ), $_DT->now, ) > 0 ? 0 : 1; } sub _parse { my($proto, $cookie) = @_; _trace($cookie) if $_TRACE; my($values) = _parse_values($proto, $cookie); return {$_MODIFIED_FIELD => 1} unless $values && %$values; if ($_CFG->{session_timeout_seconds}) { my($date) = $_DT->from_literal($values->{$proto->DATE_TIME_FIELD}); if ($date && $_DT->compare( $_DT->now, $_DT->add_seconds($date, $_CFG->{session_timeout_seconds}), ) > 0 ) { _trace('session timed out: ', $_DT->to_string($date)) if $_TRACE; return { $_MODIFIED_FIELD => 1, $proto->DATE_TIME_FIELD => $date }; } } return $values; } sub _parse_items { my($proto, $cookie) = @_; my($items) = {}; my($rows) = [split(/\s*[;,]\s*/, $cookie)]; my($ignore_prior_tags) = grep(/^\s*$_CFG->{tag}\s*=/, @$rows) ? 1 : 0; foreach my $f (@$rows) { my($k, $v) = split(/\s*=\s*/, $f, 2); unless (defined($k) && defined($v) && length($v)) { _trace($k, ': ignoring other element') if $_TRACE; next; } $k = uc($k); unless ($k eq $_CFG->{tag}) { if ($_CFG->{prior_tags} && grep($k eq $_->[0], @{$_CFG->{prior_tags}})) { $items->{$_PRIOR_TAG_FIELD}++; next if $ignore_prior_tags; } else { _trace('tag from another server or old tag: ', $k) if $_TRACE; next; } } if (exists($items->{$k})) { #TODO: use the largest DATE_TIME value in the cookie to solve collisions b_warn('duplicate cookie value for key: ', $k, ', ', $items->{$k}, ' and ', $v); next; } $items->{$k} = $v; } return $items; } sub _parse_values { my($proto, $cookie) = @_; my($values) = {}; my($items) = _parse_items($proto, $cookie); my($prior_tag) = delete($items->{$_PRIOR_TAG_FIELD}); while (my($k, $v) = each(%$items)) { $v =~ s/"//g; my($s) = $_S->decrypt_http_base64($v); unless ($s) { _trace('unable to decode: ', $v) if $_TRACE; return undef; } my(@v) = split(/$_SEP/o, $s); _trace('data=', \@v) if $_TRACE; push(@v, '') if int(@v) % 2; my(%v) = @v; unless (($_DT->from_literal( $v{$proto->DATE_TIME_FIELD}))[0]) { b_warn( 'invalid cookie: encrypted=', $v, ' decrypted=', \@v); return undef; } while (my($k, $v) = each(%v)) { $values->{$k} = $v; } } if ($prior_tag) { $values->{$_PRIOR_TAG_FIELD}++; $values->{$_MODIFIED_FIELD}++; } return $values; } 1;