lib/VJournal/Session.pm

   1 package VJournal::Session;
   2
   3 use strict;
   4 use Carp;
   5 use CGI;
   6 use Cwd;
   7 use File::Spec;
   8
   9 use vars qw($AUTOLOAD);
  10 use constant COOKIE_NAME=>'VJ_SESSION';
  11 use constant CONFIG_NAME=>'.vjournalrc';
  12
  13
  14 our %config;
  15
  16 =head1 NAME
  17
  18 VJournal::Session - handle authorized use session
  19
  20 =head1 SYNOPSIS
  21
  22         use VJournal::Session
  23         my $s = VJournal::Session->new;
  24
  25 =head1 DESCRIPTION
  26
  27 B<VJournal::Session> manages session. Sesssion objects incoroprates
  28 B<CGI.pm> context, and any methods of CGI.pm can be called as session
  29 object methods.
  30
  31 =head1 METHODS
  32
  33 =head2 new
  34
  35    $session = new VJournal::Session();
  36    $session = new VJournal::Session($cgi);
  37
  38 Creates new B<session> object based on the CGI request. If no  CGI
  39 object is expilcitely provided, creates one using default constructor.
  40
  41 If there is no session cookie in the CGI context, or cookie is expired,
  42 or cookie is bound to IP address, other than current B<remote_addr()>,
  43 returns B<undef>.
  44
  45 =cut
  46
  47 sub new {
  48         my $pkg = shift;
  49         my %attrs;
  50         if (!@_) {
  51                 %attrs=(-cgi=>new CGI);
  52         } elsif (scalar(@_)%2==0) {
  53                 %attrs=@_;
  54         } elsif (scalar(@_) == 1) {
  55                 %attrs=(-cgi=>$_[0]);
  56         } else {
  57             croak "Invalid call to VJournal::Session::new"
  58         }
  59         if (exists $attrs{-cgi} && $attrs{-cgi}->can("cookie")) {
  60                 my $cgi=$attrs{-cgi};
  61                 my $sess_id = $cgi->cookie(COOKIE_NAME);
  62                 return undef unless $sess_id;
  63                 load_config();
  64                 if (!exists($config{-sessionbase})) {
  65                         croak "No VJournal config read";
  66                 }
  67                 my %userbase;
  68                 dbmopen %userbase,$config{-sessionbase},0644;
  69
  70                 return undef if (!exists($userbase{$sess_id}));
  71                 my ($name,$avatar,$email,$avwidth,$avheight,$ip,$expire) =
  72                 split(/:/,$userbase{$sess_id});
  73                 if ($ip && $ip ne $attrs{-cgi}->remote_addr()) {
  74                         return undef;
  75                 }
  76                 my $me={-id=>$sess_id,-name=>$name,-cgi=>$cgi};
  77                 if ($avatar) {
  78                         $me->{-avatar}=$avatar;
  79                         $me->{-avwidth}=$avwidth;
  80                         $me->{-avheight}=$avheight;
  81                 }
  82                 if ($email) {
  83                         $me->{-email}=$email;
  84                 }
  85
  86                 my $now = time();
  87                 if ($expire < $now) {
  88                         delete $userbase{$sess_id};
  89                         return undef;
  90                 } elsif ($expire < $now - $config{-gracetime}) {
  91                         $expire+=$config{-sessiontime};
  92                         $userbase{$sess_id}=join(":",$name,$avatar,$email,$avwidth,$avheight,$ip,$expire);
  93                         $me->{-cookie}=
  94                         [$cgi->cookie(-name=>COOKIE_NAME,-value=>$sess_id,-expires=>
  95                                 $expire)];
  96                 }
  97                 return bless $pkg,$me;
  98         }
  99 }
 100
 101 =head2 create
 102
 103 Creates new session for given user. It is assumet that user have been
 104 properly authenticated by caller. (i.e. using OpenID).
 105
 106    $session=VJournal::Session->create(-user=>'user',-cgi=>$cgi,-email=>$mailaddress,
 107         -avatar=>$uri,
 108         -bind_to_ip=>1
 109    );
 110
 111 If B<-bind_to_ip> is specified, session would be bound to IP address.
 112 Avatar uri and email address might be provided by the authentication
 113 mechanism.
 114
 115 If they are not obtained for free, caller shouldn't attempt to provide
 116 them to create. Better to check if avatar and email are defined after
 117 session creation. May be they are already cached.
 118
 119 =cut
 120
 121 sub create {
 122         my $pkg=shift;
 123         if (scalar(@_)%2!=0) {
 124                 croak("Invalid call to ".$pkg."->create");
 125         }
 126         my %params = @_;
 127         croack("User name is required by ".$pkg."->creae");
 128         $params{-cgi}=CGI->new() if(!$params{-cgi});
 129         load_config($params{-cgi});
 130
 131 }
 132
 133 =head2 avatar
 134
 135   print $s->avatar()
 136   %props=$s->avatar
 137   $s->avatar("http://www.some.site/userpic/user.gif");
 138
 139 In the scalar context returns img tag for user avatar.
 140 In the vector context returns list which looks like
 141
 142   -src=>http://some.site/some.pic, -width=>nnn,-height=>nnn,-alt=>username
 143
 144 If URL is supplied, attempts to cache image in the local userpic area
 145 so subsequent calls to the avatar would return local copy.
 146
 147 =cut
 148
 149 sub avatar {
 150         my $self = shift;
 151         if (@_) {
 152                 #setup new avatar
 153                 require VJournal::Avatar;
 154                 my %a = VJournal::Avatar::cache($_[0]);
 155                 while (my($key,$val)=each %a) {
 156                         $self->{$key}=$val;
 157                 }
 158                 $self->_update_user();
 159         } elsif (exists($self->{-avatar})) {
 160                 my @a=(-src=>$self->{-avatar},-width=>$self->{-avwidth},-height=>$self->{-avheight},-alt=>$self->{-name});
 161                 if (wantarray) {
 162                         return @a;
 163                 } else {
 164                         return $self->{-cgi}->img(@a);
 165                 }
 166         }
 167 }
 168
 169 =head2 email
 170
 171         my $addr=$s->email();
 172         $s->email($address);
 173
 174 =cut
 175
 176
 177 sub email {
 178         my $self = shift;
 179         if (@_) {
 180                 $self->{-email} = shift;
 181                 if (!exists $self->{-avatar}) {
 182                         require VJournal::Avatar;
 183                         VJournal::Avatar::by_email($self->{-email});
 184                 }
 185                 $self->_update_user();
 186         }
 187         return $self->{-email};
 188 }
 189
 190 =head2 isowner
 191
 192   if ($s->isowner()) {
 193   ....
 194
 195 returns true, if current user is owner of the blog
 196
 197 =cut
 198
 199 sub isowner {
 200         my $self=shift;
 201         return $self->{-name} eq $config{-owner};
 202 }
 203
 204 =head2 _update_user
 205
 206         $s->_update_user
 207
 208 Updates intformation about user in the user and session database.
 209 Internal function, called from B<create>, B<avatar> and B<email>.
 210
 211 =cut
 212
 213 =head2 header
 214
 215 Overrideds CGI.pm header routine and adds to the header Set-Cookie
 216 headers for cookies created by B<new>, B<create> or added by B<set_cookie>
 217
 218 =cut
 219
 220 sub header {
 221         my $self = shift;
 222         push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ;
 223         return $self->{-cgi}->header(@_);
 224 }
 225
 226 =head2 load_config
 227
 228         load_config($cgi)
 229
 230 walks up the path_translated() and searches for the B<.vjournalrc> config.
 231 dies if config not found.
 232
 233 =cut
 234
 235 sub load_config {
 236         my $path=$_[0]->path_translated();
 237         my @dirs = (File::Spec->splitdir($path));
 238         my $found =0;
 239         while (@dirs) {
 240                 my $d=File::Spec->catdir(@dirs,CONFIG_NAME);
 241                 if (-r $d) {
 242                         open F,"<",$d;
 243                         local $/=undef;
 244                         my $config = <F>;
 245                         close F;
 246                         eval "%config = {$d}";
 247                         die $@ if ($@);
 248                         $found = 1;
 249                 }
 250                 pop @dirs;
 251         }
 252         die ("Cannot find config file inside $path") unless $found;
 253         my @reqkeys=qw(-owner -statedir -templatedir);
 254         foreach my $key (@reqkeys) {
 255                 die "Required key $key missing from config"
 256                         unless exists $config{$key};
 257         }
 258         # sensible defaults
 259         $config{-sessionbase}||=$config{-statedir}."/sessions.db";
 260         $config{-userbase}||=$config{-statedir}."/user.db";
 261         $config{-sessiontime}||=86400*30;
 262         $config{-gracetime}||=86400;
 263 }
 264
 265 =head2 AUTOLOAD
 266
 267 Delegates all called methods which are not implemented to the CGI.pm
 268 object
 269
 270 =cut
 271
 272
 273 sub AUTOLOAD {
 274         my $self=shift;
 275         my $func = $AUTOLOAD;;
 276         croak("Invalid method $AUTOLOAD") unless CGI->can($func);
 277         return $self->{-cgi}->$func(@_);
 278 }
 279
 280 1;