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                 load_config($cgi);
  62                 my $sess_id = $cgi->cookie(COOKIE_NAME);
  63                 return undef unless $sess_id;
  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,$identity,$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,-identity=>$identity,-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,$identity,$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 $me,$pkg;
  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(-identity=>'identity-url',
 107         -name=>"user display name",-cgi=>$cgi,-email=>$mailaddress,
 108         -avatar=>$uri,
 109         -bind_to_ip=>1
 110    );
 111
 112 If B<-bind_to_ip> is specified, session would be bound to IP address.
 113 Avatar uri and email address might be provided by the authentication
 114 mechanism.
 115
 116 If they are not obtained for free, caller shouldn't attempt to provide
 117 them to create. Better to check if avatar and email are defined after
 118 session creation. May be they are already cached.
 119
 120 =cut
 121
 122 sub create {
 123         my $pkg=shift;
 124         if (scalar(@_)%2!=0) {
 125                 croak("Invalid call to ".$pkg."->create");
 126         }
 127         my %params = @_;
 128         croack("User identity is required by ".$pkg."->create") unless
 129         $params{-identity};
 130         $params{-cgi}=CGI->new() if(!$params{-cgi});
 131         load_config($params{-cgi});
 132         my $identity=$params{-identity};
 133         my %users;
 134         my %sessions;
 135         dbmopen %users,$config{-userbase},0644;
 136         my $session={-cgi=>$params{-cgi},-identity=>$params{-identity}};
 137         if (!exists($users{$identity})) {
 138                 # New user come.
 139                 require VJournal::Avatar;
 140                 my @avatar;
 141                 if (exists $params{-avatar}) {
 142                         @avatar = VJournal::Avatar::cache($params{-avatar});
 143                 } else {
 144                         @avatar = VJournal::Avatar::by_openid($identity);
 145                 }
 146                 if (!@avatar && exists $params{-email}) {
 147                         @avatar = VJournal::Avatar::by_email($params{-email});
 148                 }
 149                 my %a = @avatar;
 150                 $users{$identity}=join(":",$params{-name}||$identity
 151                         ,$params{-email},$a{-src},$a{-width},$a{-height});
 152         }
 153         my ($name,$email,$avatarsrc,$avatarwidth,$avatarheight)=split(":",$users{$identity});
 154         $session->{-name} = $name;
 155         $session->{-email} = $email if $email;
 156         if ($avatarsrc) {
 157                 $session->{-avatar} = $avatarsrc;
 158                 $session->{-avwidth} = $avatarwidth;
 159                 $session->{-avheight} = $avatarheight;
 160         }
 161         my $expire = time()+$config{-sessiontime};
 162         require Digest::MD5;
 163         my
 164         $sessioninfo=join(":",$name,$identity,$avatarsrc,$email,$avatarwidth,$avatarheight,
 165                 ($params{-bind_to_ip}?$session->{-cgi}->remote_addr():""),$expire);
 166         $session->{-id} = Digest::MD5::md5_base64($sessioninfo);
 167         $sessions{$session->{-id}} = $sessioninfo;
 168         bless $session,$pkg;
 169         $session->{-cookie}=
 170                         [$session->cookie(-name=>COOKIE_NAME,-value=>$session->{-id},-expires=>
 171                                 $expire)];
 172         return $session
 173 }
 174
 175 =head2 set_cookie
 176
 177         $s->set_cookie($s->cookie(-name=>name,-value=>value));
 178
 179 Stores new cookie to be send to client inside the session object.
 180 They would be output when $s->header would be printed.
 181
 182 =cut
 183
 184 sub set_cookie {
 185         my $self=shift;
 186         $self->{-cookie}=[] if !exists $self->{-cookie};
 187         push @{$self->{-cookie}},@_;
 188 }
 189
 190 =head2 identity
 191
 192         $s->identity()
 193
 194 Returns OpenID identity URL     for current user
 195
 196 =cut
 197
 198 sub identity {
 199         return shift->{-identity};
 200 }
 201
 202 =head2 name
 203
 204         $s->name()
 205
 206 Returns display name for current user
 207
 208 =cut
 209
 210 sub name {
 211         return shift->{-name};
 212 }
 213
 214 =head2 avatar
 215
 216   print $s->avatar()
 217   %props=$s->avatar
 218   $s->avatar("http://www.some.site/userpic/user.gif");
 219
 220 In the scalar context returns img tag for user avatar.
 221 In the vector context returns list which looks like
 222
 223   -src=>http://some.site/some.pic, -width=>nnn,-height=>nnn,-alt=>username
 224
 225 If URL is supplied, attempts to cache image in the local userpic area
 226 so subsequent calls to the avatar would return local copy.
 227
 228 =cut
 229
 230 sub avatar {
 231         my $self = shift;
 232         if (@_) {
 233                 #setup new avatar
 234                 require VJournal::Avatar;
 235                 my %a = VJournal::Avatar::cache($_[0]);
 236                 while (my($key,$val)=each %a) {
 237                         $self->{$key}=$val;
 238                 }
 239                 $self->_update_user();
 240         } elsif (exists($self->{-avatar})) {
 241                 my @a=(-src=>$self->{-avatar},-width=>$self->{-avwidth},-height=>$self->{-avheight},-alt=>$self->{-name});
 242                 if (wantarray) {
 243                         return @a;
 244                 } else {
 245                         return $self->{-cgi}->img(@a);
 246                 }
 247         }
 248 }
 249
 250 =head2 email
 251
 252         my $addr=$s->email();
 253         $s->email($address);
 254
 255 =cut
 256
 257
 258 sub email {
 259         my $self = shift;
 260         if (@_) {
 261                 $self->{-email} = shift;
 262                 if (!exists $self->{-avatar}) {
 263                         require VJournal::Avatar;
 264                         VJournal::Avatar::by_email($self->{-email});
 265                 }
 266                 $self->_update_user();
 267         }
 268         return $self->{-email};
 269 }
 270
 271 =head2 isowner
 272
 273   if ($s->isowner()) {
 274   ....
 275
 276 returns true, if current user is owner of the blog
 277
 278 =cut
 279
 280 sub isowner {
 281         my $self=shift;
 282         return $self->{-identity} eq $config{-owner};
 283 }
 284
 285 =head2 banned
 286
 287         $s->banned()
 288
 289 Return true if current user is banned from leaving comments in the blog.
 290
 291 =cut
 292
 293 sub banned {
 294         return exists shift->{-ban}
 295 }
 296
 297 =head2 ban
 298
 299         $s->ban($identity_url);
 300
 301 Marks user as banned in the current blog
 302
 303 =cut
 304
 305 sub ban {
 306         my ($self,$foe) = @_;
 307         return undef if (!$self->isowner()) ;
 308         my %bans;
 309         dbmopen %bans,$config{-topdir}."/bans",0644;
 310         $bans{$foe}=time();
 311 }
 312
 313 =head2 _readban
 314
 315         $session=>{-identity=>$identity,...,_readban($identity)}
 316
 317 Returns aray (-ban => 1) if $identity is recorded in tbe bans dbm file
 318 in the blog top url
 319
 320 =cut
 321
 322 sub _readban {
 323         my $identity = shift;
 324         my %bans;
 325         dbmopen %bans,$config{-topdir}."/bans",0644;
 326         if (exists $bans{-identity}) {
 327                 return (-ban=>1);
 328         } else {
 329                 return ();
 330         }
 331 }
 332
 333 =head2 _update_user
 334
 335         $s->_update_user
 336
 337 Updates intformation about user in the user and session database.
 338 Internal function, called from B<create>, B<avatar> and B<email>.
 339
 340 =cut
 341
 342 =head2 header
 343
 344 Overrideds CGI.pm header routine and adds to the header Set-Cookie
 345 headers for cookies created by B<new>, B<create> or added by B<set_cookie>
 346
 347 =cut
 348
 349 sub header {
 350         my $self = shift;
 351         push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ;
 352         return $self->{-cgi}->header(@_);
 353 }
 354
 355 =head2 load_config
 356
 357         load_config($cgi)
 358
 359 walks up the path_translated() and searches for the B<.vjournalrc> config.
 360 dies if config not found.
 361
 362 =cut
 363
 364 sub load_config {
 365         my $cgi = $_[0];
 366         my $path;
 367         $path=$1 if $cgi->path_translated()=~/^(.*)$/;
 368         my @dirs = File::Spec->splitdir($path);
 369         my @uri = File::Spec->splitdir($cgi->path_info);
 370         my $found =0;
 371         while (@dirs) {
 372                 my $d=File::Spec->catdir(@dirs,CONFIG_NAME);
 373                 if (-r $d) {
 374                         open F,"<",$d;
 375                         while (<F>) {
 376                                 $config{"-$1"} = $2 if /^\s*(\w+)\s*=\s*"([^"]*)"\s*$/;
 377                         }
 378                         close F;
 379                         $config{-topdir}=File::Spec->catdir(@dirs);
 380                         $config{-topurl}=$cgi->url(-base=>1).File::Spec->catdir(@uri);
 381                         die $@ if ($@);
 382                         $found = 1;
 383                 }
 384                 pop @dirs;
 385                 pop @uri;
 386         }
 387         die ("Cannot find config file inside $path") unless $found;
 388         my @reqkeys=qw(-statedir);
 389         foreach my $key (@reqkeys) {
 390                 die "Required key $key missing from config"
 391                         unless exists $config{$key};
 392
 393         }
 394         # sensible defaults
 395         $config{-sessionbase}||=$config{-statedir}."/sessions.db";
 396         $config{-userbase}||=$config{-statedir}."/user.db";
 397         $config{-sessiontime}||=86400*30;
 398         $config{-gracetime}||=86400;
 399         $config{-templatedir}||=$config{-topdir}."/templates";
 400         $config{-avatardir}||=$config{-topdir}."/avatars";
 401         if (!$config{-owner}) {
 402                 my $uri=substr($config{-topurl},index($config{-topurl},"://")+3);
 403                 $uri =~ s/:\d+(\/.*)?$//;
 404                 $config{-owner} = $uri;
 405         }
 406 }
 407
 408 =head2 AUTOLOAD
 409
 410 Delegates all called methods which are not implemented to the CGI.pm
 411 object
 412
 413 =cut
 414
 415
 416 sub AUTOLOAD {
 417         my $self=shift;
 418         my $func = $AUTOLOAD;;
 419         croak("Invalid method $AUTOLOAD") unless CGI->can($func);
 420         return $self->{-cgi}->$func(@_);
 421 }
 422
 423 1;