X-Git-Url: http://www.wagner.pp.ru/gitweb/?p=oss%2Fvjournal.git;a=blobdiff_plain;f=lib%2FVJournal%2FSession.pm;fp=lib%2FVJournal%2FSession.pm;h=f07ce4ea1dd5a5cb3afe2f9de2a80e16505ea149;hp=0000000000000000000000000000000000000000;hb=46ccc783a7c123b036e2f9d3573d289f98967410;hpb=9fb2cd09abf5af9ee0d0ca5778dc6ea35f4ce7ba diff --git a/lib/VJournal/Session.pm b/lib/VJournal/Session.pm new file mode 100644 index 0000000..f07ce4e --- /dev/null +++ b/lib/VJournal/Session.pm @@ -0,0 +1,280 @@ +package VJournal::Session; + +use strict; +use Carp; +use CGI; +use Cwd; +use File::Spec; + +use vars qw($AUTOLOAD); +use constant COOKIE_NAME=>'VJ_SESSION'; +use constant CONFIG_NAME=>'.vjournalrc'; + + +our %config; + +=head1 NAME + +VJournal::Session - handle authorized use session + +=head1 SYNOPSIS + + use VJournal::Session + my $s = VJournal::Session->new; + +=head1 DESCRIPTION + +B manages session. Sesssion objects incoroprates +B context, and any methods of CGI.pm can be called as session +object methods. + +=head1 METHODS + +=head2 new + + $session = new VJournal::Session(); + $session = new VJournal::Session($cgi); + +Creates new B object based on the CGI request. If no CGI +object is expilcitely provided, creates one using default constructor. + +If there is no session cookie in the CGI context, or cookie is expired, +or cookie is bound to IP address, other than current B, +returns B. + +=cut + +sub new { + my $pkg = shift; + my %attrs; + if (!@_) { + %attrs=(-cgi=>new CGI); + } elsif (scalar(@_)%2==0) { + %attrs=@_; + } elsif (scalar(@_) == 1) { + %attrs=(-cgi=>$_[0]); + } else { + croak "Invalid call to VJournal::Session::new" + } + if (exists $attrs{-cgi} && $attrs{-cgi}->can("cookie")) { + my $cgi=$attrs{-cgi}; + my $sess_id = $cgi->cookie(COOKIE_NAME); + return undef unless $sess_id; + load_config(); + if (!exists($config{-sessionbase})) { + croak "No VJournal config read"; + } + my %userbase; + dbmopen %userbase,$config{-sessionbase},0644; + + return undef if (!exists($userbase{$sess_id})); + my ($name,$avatar,$email,$avwidth,$avheight,$ip,$expire) = + split(/:/,$userbase{$sess_id}); + if ($ip && $ip ne $attrs{-cgi}->remote_addr()) { + return undef; + } + my $me={-id=>$sess_id,-name=>$name,-cgi=>$cgi}; + if ($avatar) { + $me->{-avatar}=$avatar; + $me->{-avwidth}=$avwidth; + $me->{-avheight}=$avheight; + } + if ($email) { + $me->{-email}=$email; + } + + my $now = time(); + if ($expire < $now) { + delete $userbase{$sess_id}; + return undef; + } elsif ($expire < $now - $config{-gracetime}) { + $expire+=$config{-sessiontime}; + $userbase{$sess_id}=join(":",$name,$avatar,$email,$avwidth,$avheight,$ip,$expire); + $me->{-cookie}= + [$cgi->cookie(-name=>COOKIE_NAME,-value=>$sess_id,-expires=> + $expire)]; + } + return bless $pkg,$me; + } +} + +=head2 create + +Creates new session for given user. It is assumet that user have been +properly authenticated by caller. (i.e. using OpenID). + + $session=VJournal::Session->create(-user=>'user',-cgi=>$cgi,-email=>$mailaddress, + -avatar=>$uri, + -bind_to_ip=>1 + ); + +If B<-bind_to_ip> is specified, session would be bound to IP address. +Avatar uri and email address might be provided by the authentication +mechanism. + +If they are not obtained for free, caller shouldn't attempt to provide +them to create. Better to check if avatar and email are defined after +session creation. May be they are already cached. + +=cut + +sub create { + my $pkg=shift; + if (scalar(@_)%2!=0) { + croak("Invalid call to ".$pkg."->create"); + } + my %params = @_; + croack("User name is required by ".$pkg."->creae"); + $params{-cgi}=CGI->new() if(!$params{-cgi}); + load_config($params{-cgi}); + +} + +=head2 avatar + + print $s->avatar() + %props=$s->avatar + $s->avatar("http://www.some.site/userpic/user.gif"); + +In the scalar context returns img tag for user avatar. +In the vector context returns list which looks like + + -src=>http://some.site/some.pic, -width=>nnn,-height=>nnn,-alt=>username + +If URL is supplied, attempts to cache image in the local userpic area +so subsequent calls to the avatar would return local copy. + +=cut + +sub avatar { + my $self = shift; + if (@_) { + #setup new avatar + require VJournal::Avatar; + my %a = VJournal::Avatar::cache($_[0]); + while (my($key,$val)=each %a) { + $self->{$key}=$val; + } + $self->_update_user(); + } elsif (exists($self->{-avatar})) { + my @a=(-src=>$self->{-avatar},-width=>$self->{-avwidth},-height=>$self->{-avheight},-alt=>$self->{-name}); + if (wantarray) { + return @a; + } else { + return $self->{-cgi}->img(@a); + } + } +} + +=head2 email + + my $addr=$s->email(); + $s->email($address); + +=cut + + +sub email { + my $self = shift; + if (@_) { + $self->{-email} = shift; + if (!exists $self->{-avatar}) { + require VJournal::Avatar; + VJournal::Avatar::by_email($self->{-email}); + } + $self->_update_user(); + } + return $self->{-email}; +} + +=head2 isowner + + if ($s->isowner()) { + .... + +returns true, if current user is owner of the blog + +=cut + +sub isowner { + my $self=shift; + return $self->{-name} eq $config{-owner}; +} + +=head2 _update_user + + $s->_update_user + +Updates intformation about user in the user and session database. +Internal function, called from B, B and B. + +=cut + +=head2 header + +Overrideds CGI.pm header routine and adds to the header Set-Cookie +headers for cookies created by B, B or added by B + +=cut + +sub header { + my $self = shift; + push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ; + return $self->{-cgi}->header(@_); +} + +=head2 load_config + + load_config($cgi) + +walks up the path_translated() and searches for the B<.vjournalrc> config. +dies if config not found. + +=cut + +sub load_config { + my $path=$_[0]->path_translated(); + my @dirs = (File::Spec->splitdir($path)); + my $found =0; + while (@dirs) { + my $d=File::Spec->catdir(@dirs,CONFIG_NAME); + if (-r $d) { + open F,"<",$d; + local $/=undef; + my $config = ; + close F; + eval "%config = {$d}"; + die $@ if ($@); + $found = 1; + } + pop @dirs; + } + die ("Cannot find config file inside $path") unless $found; + my @reqkeys=qw(-owner -statedir -templatedir); + foreach my $key (@reqkeys) { + die "Required key $key missing from config" + unless exists $config{$key}; + } + # sensible defaults + $config{-sessionbase}||=$config{-statedir}."/sessions.db"; + $config{-userbase}||=$config{-statedir}."/user.db"; + $config{-sessiontime}||=86400*30; + $config{-gracetime}||=86400; +} + +=head2 AUTOLOAD + +Delegates all called methods which are not implemented to the CGI.pm +object + +=cut + + +sub AUTOLOAD { + my $self=shift; + my $func = $AUTOLOAD;; + croak("Invalid method $AUTOLOAD") unless CGI->can($func); + return $self->{-cgi}->$func(@_); +} + +1;