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,$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($user);
 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{$user});
 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         if (!$self->isowner()) return undef;
 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         dbmopen %bans,$config{-topdir}."/bans",0644;
 325         if (exists $bans{-identity}) {
 326                 return (-ban=>1);
 327         } else {
 328                 return ();
 329         }
 330 }
 331
 332 =head2 _update_user
 333
 334         $s->_update_user
 335
 336 Updates intformation about user in the user and session database.
 337 Internal function, called from B<create>, B<avatar> and B<email>.
 338
 339 =cut
 340
 341 =head2 header
 342
 343 Overrideds CGI.pm header routine and adds to the header Set-Cookie
 344 headers for cookies created by B<new>, B<create> or added by B<set_cookie>
 345
 346 =cut
 347
 348 sub header {
 349         my $self = shift;
 350         push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ;
 351         return $self->{-cgi}->header(@_);
 352 }
 353
 354 =head2 load_config
 355
 356         load_config($cgi)
 357
 358 walks up the path_translated() and searches for the B<.vjournalrc> config.
 359 dies if config not found.
 360
 361 =cut
 362
 363 sub load_config {
 364         my $cgi = $_[0];
 365         my $path=$cgi->path_translated();
 366         my @dirs = File::Spec->splitdir($path);
 367         my @uri = File::Spec->splitdir($cgi->path_info);
 368         my $found =0;
 369         while (@dirs) {
 370                 my $d=File::Spec->catdir(@dirs,CONFIG_NAME);
 371                 if (-r $d) {
 372                         open F,"<",$d;
 373                         local $/=undef;
 374                         my $config = <F>;
 375                         close F;
 376                         eval "%config = {$d}";
 377                         $config{-topdir}=File::Spec->catdir(@dirs);
 378                         $config{-topurl}=$cgi->url(-base=>1).File::Spec->catdir(@uri);
 379                         die $@ if ($@);
 380                         $found = 1;
 381                 }
 382                 pop @dirs;
 383                 pop @uri;
 384         }
 385         die ("Cannot find config file inside $path") unless $found;
 386         my @reqkeys=qw(-statedir);
 387         foreach my $key (@reqkeys) {
 388                 die "Required key $key missing from config"
 389                         unless exists $config{$key};
 390         }
 391         # sensible defaults
 392         $config{-sessionbase}||=$config{-statedir}."/sessions.db";
 393         $config{-userbase}||=$config{-statedir}."/user.db";
 394         $config{-sessiontime}||=86400*30;
 395         $config{-gracetime}||=86400;
 396         $config{-templatedir}||=$config{-topdir}."/templates"
 397         $config{-avatardir}||=$config{-topdir}."/avatars";
 398         if (!$config{-owner}) {
 399                 my $uri=substr($config{-topurl},index($config{-topurl},"://")+2;
 400                 $uri =~ s/:\d+(\/.*)?$//;
 401                 $config{-owner} = $uri;
 402         }
 403 }
 404
 405 =head2 AUTOLOAD
 406
 407 Delegates all called methods which are not implemented to the CGI.pm
 408 object
 409
 410 =cut
 411
 412
 413 sub AUTOLOAD {
 414         my $self=shift;
 415         my $func = $AUTOLOAD;;
 416         croak("Invalid method $AUTOLOAD") unless CGI->can($func);
 417         return $self->{-cgi}->$func(@_);
 418 }
 419
 420 1;