lib/Labyrinth/Session.pm

package Labyrinth::Session;

use warnings;
use strict;

use vars qw($VERSION @ISA %EXPORT_TAGS @EXPORT @EXPORT_OK);
$VERSION = '5.23';

=head1 NAME

Labyrinth::Session - Session Management for Labyrinth.

=head1 SYNOPSIS

  use Labyrinth::Session;
  Login($username,$password);
  my $logged_in = 1 if(my $user =  ValidSession());

=head1 DESCRIPTION

Provides the session management functionality, including Login & Logout 
functions, to maintain a user's access to the system. 

=cut

# -------------------------------------
# Export Details

require Exporter;
@ISA       = qw(Exporter);
%EXPORT_TAGS = (
    'all' => [ qw(
        ValidSession VerifyUser Authorised UserAccess FolderAccess
        ResetLanguage UpdateSession
    ) ]
);

@EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
@EXPORT    = ( @{ $EXPORT_TAGS{'all'} } );

# -------------------------------------
# Library Modules

use Digest::MD5 qw(md5_base64);

use Labyrinth::Audit;
use Labyrinth::Globals;
use Labyrinth::DTUtils;
use Labyrinth::CookieLib;
use Labyrinth::Mailer;
use Labyrinth::Users;
use Labyrinth::Variables;

# -------------------------------------
# Variables

my (%USERS,%FOLDERS);

# -------------------------------------
# The Functional Interface

=head1 FUNCTIONS

=over 4

=item Login

Handles login capabilities, including bad logins.

=item Logout

Handles logout capabilities.

=cut

sub Login {
    # forgotten password?
    return _forgotten()             if($cgiparams{cause} && $cgiparams{forgot});

    # values complete?
    return SetError('ERROR',1)    unless($cgiparams{cause} && $cgiparams{effect});

    # verify username/password
    my @rows = CheckUser($cgiparams{cause},$cgiparams{effect});
    return SetError('BADUSER',1)    unless(@rows);

    $tvars{user} = $rows[0];

    # add entry to session table
    my $session;
    (   $session,
        $tvars{user}{name},
        $tvars{'loginid'},
        $tvars{realm},
        $tvars{langcode}
    ) = _save_session($rows[0]->{realname},$rows[0]->{userid},$rows[0]->{realm},$rows[0]->{langcode});

    # set template variables
    $tvars{'loggedin'}   = 1;
    $tvars{user}{folder} = 1;
    $tvars{user}{option} = 0;
    $tvars{user}{userid} = $tvars{'loginid'};
    $tvars{user}{access} = VerifyUser($tvars{'loginid'});

    $tvars{realm} = $rows[0]->{realm} || 'public';

    if($tvars{realm} ne 'public') {
        SetCommand('home-' . $tvars{realm});
    }
}

sub Logout {
    my @rows = CheckUser('GUEST','GUEST');
    unless(@rows) {
        push @rows, {realname => 'Guest', userid => 0, realm => 'public', langcode => 'en'};
    }

    my $session;
    (   $session,
        $tvars{user}{name},
        $tvars{'loginid'},
        $tvars{realm},
        $tvars{langcode}
    ) = _save_session($rows[0]->{realname},$rows[0]->{userid},$rows[0]->{realm},$rows[0]->{langcode});
    $tvars{loggedin}     = 0;
    $tvars{user}{folder} = 1;
    $tvars{user}{option} = 0;
    $tvars{user}{userid} = $tvars{'loginid'};
    $tvars{user}{access} = VerifyUser($tvars{'loginid'});

    $tvars{redirect} = $settings{'logout-redirect'}   
        if($settings{'logout-redirect'} && $settings{'logout-redirect'} ne $cgiparams{act});
    return($session,$tvars{user}{name},$tvars{'loginid'},$tvars{realm});
}

=item ValidSession

Reloads an existing session, or creates a new one.

=item Store

Stores the current request, while the user logs in. (A simple form of continuations)

=item Retrieve

Retrieves the last request, if the user has logged in. (A simple form of continuations)
If the user is already login will set according to their realm.

=cut

sub ValidSession {
    # read cookie
    my ($userid,$name,$realm,$folder,$langcode,$option) = _get_session();
    $tvars{'loggedin'}   = ($name && lc $name ne 'guest') ? 1 : 0;
    $tvars{'loginid'}    = $userid;
    $tvars{'langcode'}   = $langcode;

    $tvars{user}{name}   = $name;
    $tvars{user}{userid} = $userid;
    $tvars{user}{folder} = $folder;
    $tvars{user}{option} = $option;
    $tvars{user}{access} = VerifyUser($userid);

    my $user = Labyrinth::Session->new($userid,$name,$realm);
    return $user;
}

sub Store {
    # we don't want to continually logout!
    return  if($cgiparams{act} eq 'user-logout');

    # store ready for continuation after login
    if (&GetCookies('sessionid')){
        my $session = $main::Cookies{'sessionid'};
        if($session && $session ne 'expired') {
            if(my @rows = $dbi->GetQuery('array','CheckSession',$session)) {
                my $query;
                if($cgiparams{lastpage} && $settings{lastpagereturn}) {
                    $query = $cgiparams{lastpage};
                    $query =~ y/~/=/;
                    $query =~ y/ /&/;
                } elsif($settings{lastpagereturn}) {
                    $query = join("&",map {"$_=$cgiparams{$_}"} keys %cgiparams);
                }
                $dbi->DoQuery('StoreSession',$query,$session);
            }
        }
    }
}

sub Retrieve {
    my $act = 'home-' . $tvars{realm};
LogDebug("Retrieve: 1.=$act");

    if(my @rows = $dbi->GetQuery('hash','GetRealmByName',$tvars{realm})) {
        $act = $rows[0]->{command};
    }
LogDebug("Retrieve: 2.=$act");

    if (&GetCookies('sessionid')){
        my $session = $main::Cookies{'sessionid'};
        if($session && $session ne 'expired') {
            if(my @rows = $dbi->GetQuery('array','RetrieveSession',$session)) {
LogDebug("Retrieve: 3.=[".($rows[0]->[0]||'')."]");
                my @parts = $rows[0]->[0] ? split("&",$rows[0]->[0]) : ();
                for my $part (@parts) {
                    $cgiparams{$1} = $2     if($part =~ /(.*?)=(.*)/);
                }
                $act = $cgiparams{act}  if(@parts);
                $dbi->DoQuery('StoreSession','',$session);
LogDebug("Retrieve: 4.=$act");
            }
        }
    }

LogDebug("Retrieve: NEXT=$act");
    SetCommand($act);
}

=item Authorised($level[,$userid])

Verifies the user has authorisation to the requested level. If userid is
omitted, the current user is assumed.

=item UserAccess

Returns the folders the user (and associated groups) has access to.

=item VerifyUser

Looks up the user's authorisation level, based on their user id and any groups
they belong to.

=item CheckUser

Given a username and password checks the database to ensure that the user
exists. Note that this uses both SHA1 (new encryption) and OLD_PASSWORD (old
encyription) to find the user. The latter is preserved for older
implementations.

=cut

sub Authorised  {
    my $needed = shift;
    return 0    if($needed && !$tvars{loggedin});

    my $userid = shift || $tvars{'loginid'};
    my $actual = VerifyUser($userid);

#   LogDebug("Authorised - needed=[$needed], actual=[$actual], result=[".($actual >= $needed ? 1 : 0)."]");

    return $actual >= $needed ? 1 : 0;
}

sub UserAccess {
    my $folderid = shift;
    my $groups = shift;

    my @rows = $dbi->GetQuery('array','FolderAccess',$tvars{loginid},$groups);
    return 0    unless(@rows);
    return $rows[0]->[0];
}

my %folderaccess;

sub VerifyUser {
    my $userid = shift || 0;
    my $folder = shift || 'public';
    my $access = 0;
LogDebug("VerifyUser($userid,'$folder')");

    return $access  unless($userid);

    # return if known
    return $folderaccess{$userid}{$folder}
        if($folderaccess{$userid}{$folder});

    # check base access
    my $user = GetUser($userid);
    $access = $user->{accessid};
    $tvars{user}{$_} = $user->{$_}   for(qw(realname nickname email));

    my @folders = ($folder ? GetFolderIDs( ref => $folder ) : (1));
    my $folders = join(',',grep {$_} @folders);
    my $groups = GetGroupIDs($userid);

    # check folder permissions
    my @rows = $dbi->GetQuery('hash','GetPermission',{folders=>$folders,groups=>$groups,user=>$userid});
    foreach my $rec (@rows) {
        $access = $rec->{accessid}  if($access < $rec->{accessid});
    }

LogDebug("-access=$access");

    $folderaccess{$userid}{$folder} = $access;
    return $access;
}

sub CheckUser {
    my ($user,$pass) = @_;

    return @{$USERS{$user}} if($USERS{$user});

    # SHA1 encryption
    my @rows = $dbi->GetQuery('hash','CheckUser',$user,$pass);
    if(@rows) {
        $USERS{$user} = \@rows;
        return @rows;
    }

    # OLD PASSWORD encryption
    @rows = $dbi->GetQuery('hash','CheckUserOld',$user,$pass);
    if(@rows) {
        $USERS{$user} = \@rows;
        return @rows;
    }

    # user not found
    return;
}

=item LoadFolders

Convienence function to load all folders when required.

=item GetFolderIDs

Returns the list of folders for the given leaf folder.

=item FolderAccess

Returns true or false as to whether the given user has access to the specified
folder. If no folder is given the default 'public' folder is used. If no user
is given the currently logged in user is used.

=cut

sub LoadFolders {
    return  if(%FOLDERS);

    my @rows = $dbi->GetQuery('hash','AllFolders');
    for my $row (@rows) {
        $FOLDERS{$row->{folderid}} = $row;
    }
}

sub GetFolderIDs {
    my %hash = @_;
    my ($id,%ids,@ids);

    LoadFolders();

    if($hash{id}) {
        $id = $hash{id};

    } elsif($hash{ref}) {
        for my $folderid (keys %FOLDERS) {
            if($FOLDERS{$folderid}->{path} eq $hash{ref}) {
                $id = $folderid;
                last;
            }
        }
    }

    return '0'  unless($id);

    while($FOLDERS{$id} && $FOLDERS{$id}->{parent} > 0) {
        $ids{$id} = 1;
        $id = $FOLDERS{$hash{id}}->{parent};
    }
    $ids{$id} = 1;
    @ids = keys %ids;

    return @ids if(wantarray);
    return join(",",@ids);
}

sub FolderAccess {
    my $folder = shift || 'public';
    my $userid = shift || $tvars{loginid};

LogDebug("FolderAccess('$folder',$userid)");

    my @rows = $dbi->GetQuery('hash','GetFolderByPath',$folder);
    return 0    unless(@rows);

    my $access = VerifyUser($userid,$folder);
    return 1    if($access >= $rows[0]->{accessid});
    return 0;
}

=item GetGroupIDs

Returns the list of groups the given user has access to.

=cut

sub GetGroupIDs {
    my $userid = shift;
    my %groups;

    $groups{1} = 1; # everyone is public

    # find primary groups for user
    my @rows = $dbi->GetQuery('array','GetGroupUserMap',$userid);

    while(@rows) {
        my (@parents);
        foreach (@rows) {
            next    if($_->[0] == 0);       # a bad entry
            next    if($groups{$_->[0]});   # already seen group
            $groups{$_->[0]} = 1;
            push @parents, $_->[0];
        }

        last    unless(@parents);

        # find associated groups for user
        @rows = $dbi->GetQuery('array','GetGroupParents',{groups=>join(",",@parents)});
    }

    return keys %groups if(wantarray);
    return join(",",keys %groups);
}

=item ResetLanguage

Within the current session, this function allows the user to change the
language associated within the system.

Currently this language element is under used, and could be used for error and
message strings pulled from a phrasebook.

=cut

sub ResetLanguage {
    my $lang = shift;
    return  unless($lang);

    my @rows = $dbi->GetQuery('array','GetLang',$lang);
    return  unless(@rows);

    $dbi->DoQuery('SetLangUser',$lang,$tvars{loginid});
    $dbi->DoQuery('SetLangSession',$lang,$settings{session});
    $tvars{langcode} = $lang;
}

=item UpdateSession

Updates specific fields for the current session.

=back

=cut

sub UpdateSession {
    my %hash = @_;
    my $session = delete $hash{session};
    $session ||= $main::Cookies{'sessionid'};
    for(keys %hash) {
        next    unless($hash{$_});
        $dbi->DoQuery('UpdateSession',{field=>$_},$hash{$_},$session);
    }

    if($hash{optionid}) {
        $tvars{user}{option} = $hash{optionid};
    }
}

# -------------------------------------
# The Object Interface

=head1 OBJECT METHODS

In addition to the above functions, the Session Management also allows for an
object interface.

=over 4

=item new

Create a new session object.

=item realm

Returns the current realm.

=cut

sub new {
    my $self = shift;

    my $atts = {
        'userid'    => $_[0],
        'name'      => $_[1],
        'realm'     => $_[2],
    };

    # create the object
    bless $atts, $self;
    return $atts;
}

sub realm {
    my $self = shift;
    return $self->{realm};
}

sub DESTROY {}

# -------------------------------------
# Internal Functions

sub _create_session_key {
    my $key = shift || '';
    my $string = $key . formatDate(0) . $$;
    my $md5 = md5_base64($string);
    $md5 =~ s![+/]!('a'..'z',0..9)[int(rand(36))]!eg;               # cookies can only handle \w characters
    return $md5;
}

sub _get_session {
    my $tsnow = formatDate(0);

    if($settings{delete_sessions}) {
        # delete timed out sessions, including this one if necessary (self cleaning)
        my $timeout = $settings{timeout} || 0;
        my $tsthen = $tsnow - $timeout;
        $dbi->DoQuery('DeleteSessions',$tsthen);
    }

    # default settings
    my ($userid,$name,$realm,$folder,$langcode,$option) = (0,'guest','public',1,'en',0);
    my $session;

    # retrieve the cookie
    if($settings{testing}) {
        $userid     = $cgiparams{cluserid}      if($cgiparams{cluserid});
        $name       = $cgiparams{clname}        if($cgiparams{clname});
        $realm      = $cgiparams{clrealm}       if($cgiparams{clrealm});
        $folder     = $cgiparams{clfolder}      if($cgiparams{clfolder});
        $langcode   = $cgiparams{cllangcode}    if($cgiparams{cllangcode});
#LogDebug("get_session: testing: ($userid,$name,$realm,$folder)");
    } elsif (&GetCookies('sessionid')){
        $session = $main::Cookies{'sessionid'};
        LogDebug("session=$session");
    } else {
        LogDebug("session=<no session>");
    }

    if(!$userid) {
        my @rows = CheckUser('GUEST','GUEST');
        $userid = $rows[0]->{userid};
    }

    $session = undef    if($session && $session eq 'expired');

    # try and time stamp the session
    if($session) {
        my @rows = $dbi->GetQuery('array','CheckSession',$session);
        LogDebug("CheckSession: 1.".(@rows ? 'found' : 'no')." session");
        if(@rows) {
            ($userid,$name,$realm,$folder,$langcode,$option) = @{$rows[0]};
            $option = $cgiparams{option}    if($cgiparams{option});
            UpdateSession(timeout => $tsnow, optionid => $option, session => $session);
        } else {
            $session = undef;
        }
    }

    # check we actually updated in time
    if($session) {
        my @rows = $dbi->GetQuery('array','CheckSession',$session);
        LogDebug("CheckSession: 2.".(@rows ? 'found' : 'no')." session");
        $session = undef    unless(@rows);
    }

    # create a new session if necessary
    unless($session) {
        if($settings{testing}) {
            ($session) = Logout();
        } else {
            ($session,$name,$userid,$realm,$langcode) = Logout();
        }
    }
    $settings{session} = $session;

    LogDebug('GetSession:name=['.($name||'').'], realm=['.($realm||'').']');

    return $userid,$name,$realm,$folder,$langcode,$option;
}

sub _save_session {
    my @fields = @_;
    my $session;

    LogDebug('SaveSession:1 fields=['.join('][',map {$_ || ''} @fields).']');

    $fields[0] ||= 'guest';
    $fields[1] ||= 0;
    $fields[2] ||= 'public';
    $fields[3] ||= 'en';
    $fields[4] ||= 0;

    if($fields[1] == 0) {
        my @rows = CheckUser('GUEST','GUEST');
        $fields[1] = $rows[0]->{userid};
    }

    LogDebug('SaveSession:2 fields=['.join('][',map {$_ || ''} @fields).']');

    $session = $main::Cookies{'sessionid'}  if(GetCookies('sessionid'));
    if($session && $session ne 'expired') {
        # check the session has been recorded in case it's been reaped, a user
        # can relogin with the same session key
        my @rows = $dbi->GetQuery('array','CheckSession',$session);
        LogDebug("CheckSession: 3.".(@rows ? 'found' : 'no')." session");
        if(@rows) {
            $dbi->DoQuery('UpdateSessionX',formatDate(0),@fields,$session);
        } else {
            $dbi->DoQuery('CreateSession',formatDate(0),@fields,$session);
        }
    } else {
        # add entry to session table
        $session = _create_session_key($cgiparams{cause});
        $dbi->DoQuery('CreateSession',formatDate(0),@fields,$session);
    }

    SetCookiePath('/');
    $tvars{cookie} = SetCookie('sessionid',$session);
    LogDebug('SaveSession:4 fields=['.join('][',map {$_ || ''} @fields).']');
    return ($session,@fields);
}

sub _forgotten {
    my @rows = $dbi->GetQuery('hash','FindUser',$cgiparams{cause});
    return SetError('BADUSER')    unless(@rows);
    return SetError('BANUSER')    if($rows[0]->{password} eq '-banned-');

    my $password = FreshPassword();
    my $name = $rows[0]->{'realname'} || 'User';

    $dbi->DoQuery('ChangePassword',$password,$rows[0]->{userid});
    MailSend(   template    => 'mailer/forgot.eml',
                name        => $name,
                password    => $password,
                email       => $cgiparams{cause}
    );

    if(MailSent()) {
        SetCommand('user-forgot');
    } else {
        SetError('BADMAIL');
    }
}

1;

__END__

=back

=head1 SEE ALSO

  Digest::MD5
  Labyrinth

=head1 AUTHOR

Barbie, <barbie@missbarbell.co.uk> for
Miss Barbell Productions, L<http://www.missbarbell.co.uk/>

=head1 COPYRIGHT & LICENSE

  Copyright (C) 2002-2014 Barbie for Miss Barbell Productions
  All Rights Reserved.

  This module is free software; you can redistribute it and/or
  modify it under the Artistic License 2.0.

=cut
	Global
`s`	Focus search bar
`?`	Bring up this help dialog
	GitHub
`g` `p`	Go to pull requests
`g` `i`	go to github issues (only if github is preferred repository)
	POD
`g` `a`	Go to author
`g` `c`	Go to changes
`g` `i`	Go to issues
`g` `d`	Go to dist
`g` `r`	Go to repository/SCM
`g` `s`	Go to source
`g` `b`	Go to file browse
	Search terms
module: (e.g. module:Plugin)
distribution: (e.g. distribution:Dancer auth)
author: (e.g. author:SONGMU Redis)
version: (e.g. version:1.00)