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 $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(-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") unless $params{-user};
 128         $params{-cgi}=CGI->new() if(!$params{-cgi});
 129         load_config($params{-cgi});
 130         my $user=$params{-user};
 131         my %users;
 132         my %sessions;
 133         dbmopen %users,$config{-userbase},0644;
 134         my $session={-cgi=>$params{-cgi},-name=>$params{-user}};
 135         if (!exists($users{$user})) {
 136                 # New user come.
 137                 require VJournal::Avatar;
 138                 my @avatar;
 139                 if (exists $params{-avatar}) {
 140                         @avatar = VJournal::Avatar::cache($params{-avatar});
 141                 } else {
 142                         @avatar = VJournal::Avatar::by_openid($user);
 143                 }
 144                 if (!@avatar && exists $params{-email}) {
 145                         @avatar = VJournal::Avatar::by_email($params{-email});
 146                 }
 147                 my %a = @avatar;
 148                 $users{$user}=join(":",$params{-email},$a{-src},$a{-width},$a{-height});
 149         }
 150         my ($email,$avatarsrc,$avatarwidth,$avatarheight)=split(":",$users{$user});
 151         $session->{-email} = $email if $email;
 152         if ($avatarsrc) {
 153                 $session->{-avatar} = $avatarsrc;
 154                 $session->{-avwidth} = $avatarwidth;
 155                 $session->{-avheight} = $avatarheight;
 156         }
 157         my $expire = time()+$config{-sessiontime};
 158         require Digest::MD5;
 159         my
 160         $sessioninfo=join(":",$user,$avatarsrc,$email,$avatarwidth,$avatarheight,
 161                 ($params{-bind_to_ip}?$session->{-cgi}->remote_addr():""),$expire);
 162         $session->{-id} = Digest::MD5::md5_base64($sessioninfo);
 163         $sessions{$session->{-id}} = $sessioninfo;
 164         bless $session,$pkg;
 165         $session->{-cookie}=
 166                         [$session->cookie(-name=>COOKIE_NAME,-value=>$session->{-id},-expires=>
 167                                 $expire)];
 168         return $session
 169 }
 170
 171 =head2 set_cookie
 172
 173         $s->set_cookie($s->cookie(-name=>name,-value=>value));
 174
 175 Stores new cookie to be send to client inside the session object.
 176 They would be output when $s->header would be printed.
 177
 178 =cut
 179
 180 sub set_cookie {
 181         my $self=shift;
 182         $self->{-cookie}=[] if !exists $self->{-cookie};
 183         push @{$self->{-cookie}},@_;
 184 }
 185
 186 =head2 avatar
 187
 188   print $s->avatar()
 189   %props=$s->avatar
 190   $s->avatar("http://www.some.site/userpic/user.gif");
 191
 192 In the scalar context returns img tag for user avatar.
 193 In the vector context returns list which looks like
 194
 195   -src=>http://some.site/some.pic, -width=>nnn,-height=>nnn,-alt=>username
 196
 197 If URL is supplied, attempts to cache image in the local userpic area
 198 so subsequent calls to the avatar would return local copy.
 199
 200 =cut
 201
 202 sub avatar {
 203         my $self = shift;
 204         if (@_) {
 205                 #setup new avatar
 206                 require VJournal::Avatar;
 207                 my %a = VJournal::Avatar::cache($_[0]);
 208                 while (my($key,$val)=each %a) {
 209                         $self->{$key}=$val;
 210                 }
 211                 $self->_update_user();
 212         } elsif (exists($self->{-avatar})) {
 213                 my @a=(-src=>$self->{-avatar},-width=>$self->{-avwidth},-height=>$self->{-avheight},-alt=>$self->{-name});
 214                 if (wantarray) {
 215                         return @a;
 216                 } else {
 217                         return $self->{-cgi}->img(@a);
 218                 }
 219         }
 220 }
 221
 222 =head2 email
 223
 224         my $addr=$s->email();
 225         $s->email($address);
 226
 227 =cut
 228
 229
 230 sub email {
 231         my $self = shift;
 232         if (@_) {
 233                 $self->{-email} = shift;
 234                 if (!exists $self->{-avatar}) {
 235                         require VJournal::Avatar;
 236                         VJournal::Avatar::by_email($self->{-email});
 237                 }
 238                 $self->_update_user();
 239         }
 240         return $self->{-email};
 241 }
 242
 243 =head2 isowner
 244
 245   if ($s->isowner()) {
 246   ....
 247
 248 returns true, if current user is owner of the blog
 249
 250 =cut
 251
 252 sub isowner {
 253         my $self=shift;
 254         return $self->{-name} eq $config{-owner};
 255 }
 256
 257 =head2 _update_user
 258
 259         $s->_update_user
 260
 261 Updates intformation about user in the user and session database.
 262 Internal function, called from B<create>, B<avatar> and B<email>.
 263
 264 =cut
 265
 266 =head2 header
 267
 268 Overrideds CGI.pm header routine and adds to the header Set-Cookie
 269 headers for cookies created by B<new>, B<create> or added by B<set_cookie>
 270
 271 =cut
 272
 273 sub header {
 274         my $self = shift;
 275         push @_,-cookie=>$self->{-cookie} if exists($self->{-cookie}) ;
 276         return $self->{-cgi}->header(@_);
 277 }
 278
 279 =head2 load_config
 280
 281         load_config($cgi)
 282
 283 walks up the path_translated() and searches for the B<.vjournalrc> config.
 284 dies if config not found.
 285
 286 =cut
 287
 288 sub load_config {
 289         my $path=$_[0]->path_translated();
 290         my @dirs = (File::Spec->splitdir($path));
 291         my $found =0;
 292         while (@dirs) {
 293                 my $d=File::Spec->catdir(@dirs,CONFIG_NAME);
 294                 if (-r $d) {
 295                         open F,"<",$d;
 296                         local $/=undef;
 297                         my $config = <F>;
 298                         close F;
 299                         eval "%config = {$d}";
 300                         die $@ if ($@);
 301                         $found = 1;
 302                 }
 303                 pop @dirs;
 304         }
 305         die ("Cannot find config file inside $path") unless $found;
 306         my @reqkeys=qw(-owner -statedir -templatedir);
 307         foreach my $key (@reqkeys) {
 308                 die "Required key $key missing from config"
 309                         unless exists $config{$key};
 310         }
 311         # sensible defaults
 312         $config{-sessionbase}||=$config{-statedir}."/sessions.db";
 313         $config{-userbase}||=$config{-statedir}."/user.db";
 314         $config{-sessiontime}||=86400*30;
 315         $config{-gracetime}||=86400;
 316 }
 317
 318 =head2 AUTOLOAD
 319
 320 Delegates all called methods which are not implemented to the CGI.pm
 321 object
 322
 323 =cut
 324
 325
 326 sub AUTOLOAD {
 327         my $self=shift;
 328         my $func = $AUTOLOAD;;
 329         croak("Invalid method $AUTOLOAD") unless CGI->can($func);
 330         return $self->{-cgi}->$func(@_);
 331 }
 332
 333 1;