]> wagner.pp.ru Git - oss/vjournal.git/commitdiff
Added Session module
authorVictor Wagner <wagner@atlas-card.ru>
Tue, 8 Oct 2013 12:43:53 +0000 (16:43 +0400)
committerVictor Wagner <wagner@atlas-card.ru>
Tue, 8 Oct 2013 12:43:53 +0000 (16:43 +0400)
lib/VJournal/Session.pm [new file with mode: 0644]

diff --git a/lib/VJournal/Session.pm b/lib/VJournal/Session.pm
new file mode 100644 (file)
index 0000000..f07ce4e
--- /dev/null
@@ -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<VJournal::Session> manages session. Sesssion objects incoroprates
+B<CGI.pm> 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<session> 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<remote_addr()>,
+returns B<undef>.
+
+=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<create>, B<avatar> and B<email>.
+
+=cut   
+
+=head2 header
+
+Overrideds CGI.pm header routine and adds to the header Set-Cookie
+headers for cookies created by B<new>, B<create> or added by B<set_cookie>
+
+=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 = <F>;
+                       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;