GBrowse
10 results

 view release on metacpan or  search on metacpan

lib/Bio/Graphics/Browser2/UserDB.pm  view on Meta::CPAN 

package Bio::Graphics::Browser2::UserDB;

# $Id: UserDB.pm 23607 2010-07-30 17:34:25Z cnvandev $
use strict;
use Bio::Graphics::Browser2;
use Bio::Graphics::Browser2::SendMail;
use CGI qw(:standard);
use DBI;
use Digest::SHA qw(sha1_hex sha1);
use JSON;
use Text::ParseWords 'quotewords';
use Digest::MD5 qw(md5_hex);
use Carp qw(confess cluck croak);

use constant HAVE_OPENID => eval "require Net::OpenID::Consumer; require LWP::UserAgent; 1" || 0;
use constant HAVE_SMTP   => eval "require Net::SMTP;1" || 0;

# SOME CLARIFICATION ON TERMINOLOGY
# "userid"    -- internal dbm ID for a user; a short integer
# "sessionid" -- GBrowse's session ID, a long hexadecimal
# "uploadsid"  -- GBrowse's upload ID, a long hexadecimal

sub new {
  my $class   = shift;
  my $globals = shift;

  my $VERSION = '0.5';
  my $credentials  = $globals->user_account_db 
      || "DBI:mysql:gbrowse_login;user=gbrowse;password=gbrowse";
  
  my $login = DBI->connect($credentials);
  unless ($login) {
      confess "Could not open login database $credentials";
  }

  my $self = bless {
      dbi      => $login,
      globals  => $globals,
      openid   => HAVE_OPENID,
      register => HAVE_SMTP,
  }, ref $class || $class;

  return $self;
}

sub globals  {shift->{globals} };
sub dbi      {shift->{dbi}     };
sub can_openid   {shift->{openid}  };
sub can_register {shift->{register}  };

sub generate_salted_digest {
    my $self     = shift;
    my $password = shift;
    my $salt     = $self->create_key(4);
    return $salt . sha1_hex($salt,$password);
}

sub salted_digest_match {
    my $self   = shift;
    my ($offered,$correct) = @_;
    my ($salt,$digest) = $correct =~ /^(.{4})(.+)/;
    return sha1_hex($salt,$offered) eq $digest;
}

sub is_salted {
    my $self    = shift;
    my $correct = shift;
    return $correct =~ /^[a-zA-Z0-9_]{4}[0-9a-f]{40}$/;
}

sub passwd_match {
    my $self = shift;
    my ($offered,$correct) = @_;
    return $self->is_salted($correct) ? $self->salted_digest_match($offered,$correct)
	                              : sha1($offered) eq $correct;
}

# Get Header - Returns the message found at the top of all confirmation e-mails.
sub get_header {
  my $self = shift;
  my $globals = $self->{globals};
  my $message  = "\nThank you for creating an account with " 
      . $globals->application_name 
      . ": " 
      . $globals->application_name_long . "\n\n";
  $message .= "The account information found below is for your reference only. ";
  $message .= "Please keep all account names and passwords in a safe location ";
  $message .= "and do not share your password with others.";
  return $message;
}

# Get Footer - Returns the message found at the bottom of all e-mails.
sub get_footer {

lib/Bio/Graphics/Browser2/UserDB.pm  view on Meta::CPAN 


    my $userdb  = $self->dbi;

    my $session = $self->globals->session($sessionid);
    $session->id eq $sessionid or die "Sessionid unavailable";
    my $uploadsid = $session->uploadsid;

    my $insert_session  = $userdb->prepare(<<END );
REPLACE INTO session (username,sessionid,uploadsid)
     VALUES (?,?,?)
END
    ;
    
    $insert_session->execute($username,$sessionid,$uploadsid)
	or return;
    return $userdb->last_insert_id('','','','');
}

sub set_session_and_uploadsid {
    my $self = shift;
    my ($userid,$sessionid,$uploadsid) = @_;

    my $userdb = $self->dbi;
    $userdb->do('UPDATE session SET sessionid=?,uploadsid=? WHERE userid=?',
		undef,
		$sessionid,$uploadsid,$userid) or die $userdb->errstr;
}

sub delete_user_by_username {
    my $self = shift;
    my $username = shift;
    my $userdb = $self->dbi;
    my $userid = $self->userid_from_username($username) or return;
    local $userdb->{AutoCommit} = 0;
    local $userdb->{RaiseError} = 1;
    eval {
	$userdb->do('DELETE FROM users        WHERE userid=?',undef,$userid);
	$userdb->do('DELETE FROM session      WHERE userid=?',undef,$userid);
	$userdb->do('DELETE FROM openid_users WHERE userid=?',undef,$userid);
	$userdb->do('DELETE FROM uploads      WHERE userid=?',undef,$userid);
	$userdb->do('DELETE FROM sharing      WHERE userid=?',undef,$userid);
	$userdb->commit();
    };
    if ($@) {
	warn "Account deletion failed due to $@. Rolling back.";
	eval {$userdb->rollback()};
    }
    1;
}

#####################################
# BUG!
# Everything below here supports the
# login.js script, which expects return
# values as various combinations of
# strings and JSON structures.
# This means API is strongly tied
# to database queries.
#####################################

# Validate - Ensures that a non-openid user's credentials are correct.
sub do_validate {
  my $self = shift;
  my ($user,$pass,$remember) = @_;
  
  my $userdb = $self->{dbi};
  my $update;

  # remove dangling unconfirmed accounts here
  $self->check_old_confirmations();

#  return $self->string_result('Usernames cannot contain any backslashes, whitespace or non-ascii characters.')
  return $self->code_result('INVALID_NAME'=>'Usernames cannot contain any backslashes, whitespace or non-ascii characters.')
      unless $self->check_user($user);

  my $userid = $self->userid_from_username($user);
  my $nowfun = $self->nowfun();

  # WARNING: bad design here
  # EXPLANATION: a remember value of "2" means to update last_login
  # but not to retrieve session ID. This seems to be requested during account
  # editing/updating.
  if($remember == 2) {
      $update = $userdb->prepare(
	  "UPDATE users SET last_login=$nowfun WHERE userid=? AND confirmed=1");
  } else {
      $update = $userdb->prepare(
	  "UPDATE users SET last_login=$nowfun,remember=$remember WHERE userid=? AND confirmed=1");
  }

  my $select = $userdb->prepare(
      "SELECT sessionid,email,confirmed,pass FROM users as a,session as b WHERE a.userid=b.userid and a.userid=?");
  $select->execute($userid)
      or return $self->dbi_err;

  # BUG: this is truly nasty -- the session id is found by string searching in login.js!!!!
  my ($session,$email,$confirmed,$correct_pass) = $select->fetchrow_array;

  if ($session && $self->passwd_match($pass,$correct_pass)) {
      if ($confirmed) {
	  my $result = $remember == 2 ? 'Success' : "session".$session;
	  return $self->string_result($result);
      } else {
	  return $self->string_result("unconfirmed${email}");
      }
  } else {
      return $self->string_result('Invalid username or password provided, please try again.'); 
  }

  # update time login now
  $update->execute($userid)
      or return $self->dbi_err;
}

# Add User Check - Checks to see if the user has already been added.
sub do_add_user_check {
  my $self = shift;
  my ($user,$email,$fullname,$pass,$userid) = @_;
  
  my $userdb = $self->dbi;

lib/Bio/Graphics/Browser2/UserDB.pm  view on Meta::CPAN 

	$old = $pass;
    }

    my $querystring  = "UPDATE users       ";
    $querystring .= "   SET $column  = ?";
    $querystring .= " WHERE userid   = ?";

    my $update = $userdb->prepare($querystring);
    unless($update->execute($new,$userid)) {
	if ($column eq 'email') {
	    return $self->string_result("New e-mail already in use, please try another.");
	} else {
	    return $self->dbi_err;
	}
    }

    if (DBI->errstr =~ m/for key 3$/) {
	return $self->string_result("New e-mail already in use, please try another.");
    }

    my $rows = $update->rows;
    if($rows == 1) {
	return $self->string_result("Success");
    } elsif ($rows == 0) {
	my $explanation = $column eq 'pass'  ? 'password' 
	                 :$column eq 'email' ? 'email address'
			 :'information';
	return $self->string_result("Incorrect $explanation provided, please check your spelling.");
    } else {
	if(($column eq 'email') and ($rows == -1)) {
	    return $self->string_result("New e-mail already in use, please try another.");
	} else {
	    return $self->string_result("Error: $rows rows returned, please consult your service host.");
	}
    }
    return $self->programmer_error;
}
  
# E-mail Info - Sends an e-mail when a user has forgotten their password.
sub do_email_info {
  my $self = shift;
  my $email = shift;
  my $globals = $self->{globals};
  my $userdb = $self->{dbi};
  
  return $self->string_result("Invalid e-mail address provided.")
      unless $self->check_email($email);

  my ($user,$rows,$openid_ref) = $self->do_retrieve_user($email);
  my @openids = @$openid_ref;
  my $openid  = "";
  
  return $self->string_result($user) unless $rows == 1;

  if (@openids) {foreach(@openids) {$openid .= "$_\n             ";}}
  else {$openid = "None\n";}

  my $pass = $self->create_key('8');
  my $message  = "\nYour password has been reset to the one seen below. To fix this,";
     $message .= " select \"My Account\" from the log in menu and log in with the";
     $message .= " credentials found below.\n\n    Username: $user\n    ";
     $message .= "Password: $pass\n\n    OpenIDs: $openid\n\n";
     $message .= $self->get_footer();

  my ($status,$err) = $self->Bio::Graphics::Browser2::SendMail::do_sendmail({
			     from       => $globals->email_address,
			     from_title => $globals->application_name,
			     to         => $email,
			     subject    => $globals->application_name . " Account Information",
			     msg        => $message
			    },$globals);
  return $self->string_result($err) unless $status;

  my $secret = $self->generate_salted_digest($pass);
  my $update = $userdb->prepare(
    "UPDATE users SET pass=? WHERE userid=? AND email=? AND confirmed=1");
  my $userid = $self->userid_from_username($user);
  $update->execute($secret,$userid,$email)
    or return $self->dbi_err;

  return $self->string_result('Success');
}

sub set_password {
    my $self = shift;
    my ($userid,$password) = @_;
    my $userdb   = $self->dbi;
    my $secret = $self->generate_salted_digest($password);
    my $update = $userdb->prepare(
	"UPDATE users SET pass=? WHERE userid=?") or die $userdb->errstr;
    my $status = $update->execute($secret,$userid) or die $userdb->errstr;
    return $status;
}

# Retrieve User - Gets the username associated with a given e-mail.
sub do_retrieve_user {
  my $self = shift;
  my $email = shift;
  
  my $userdb = $self->{dbi};
  
  my @openids;

  my $users = $userdb->selectcol_arrayref(
    "SELECT username FROM users as a,session as b WHERE a.userid=b.userid AND email=? AND confirmed=1",
  	undef,
  	$email)
  or return $self->dbi_err;

  my $rows = @$users;
  if ($rows == 1) {
    my $user  = $users->[0];
    my $query = $userdb->prepare(
      "SELECT openid_url FROM openid_users,session WHERE openid_users.userid=session.userid and session.username=?");
    $query->execute($user)
      or return $self->dbi_err;

    while (my $openid = $query->fetchrow_array) {
      push (@openids,$openid);
    }

lib/Bio/Graphics/Browser2/UserDB.pm  view on Meta::CPAN 

  my $userdb = $self->dbi;
  my $userid = $self->userid_from_username($user);
  return $self->string_result("Error: unknown user $user") unless $userid;

  my $sessionid = $self->get_sessionid($userid);
  $userdb->do('DELETE FROM session where userid=?',undef,$userid);
  my $session = $self->globals->session($sessionid);
  $session->delete;
  $session->flush;

  $userdb->do('DELETE FROM users WHERE userid=?',undef,$userid);

  my $query = $userdb->prepare(
    "DELETE FROM openid_users WHERE userid=?");
  if ($query->execute($userid)) {
      return $self->string_result('Success');
  } else {
      return $self->dbi_err;
  }
  return;
}

######################## O P E N I D   F U N C T I O N S #########################
# Check OpenID - Sends a user to their openid host for confirmation.

# BUG: ALL THE OPENID FUNCTIONS NEED TO BE REVISED
sub do_check_openid {
    my $self = shift;
    my $globals = $self->{globals};
    my ($openid, $sessionid, $source, $option) = @_;
    
    my $return_to  = $globals->gbrowse_url($source)."/?openid_confirm=1;page=$option;s=$sessionid";

    my $csr = Net::OpenID::Consumer->new(
        ua              => LWP::UserAgent->new,
        args            => CGI->new,
        consumer_secret => Bio::Graphics::Browser2->openid_secret,
        required_root   => "http://$ENV{'HTTP_HOST'}/"
    );

    my $claimed_identity = $csr->claimed_identity($openid)
        or return $self->string_result("The URL provided is not a valid OpenID, please check your spelling and try again.");
    
    my $check_url = $claimed_identity->check_url(
        return_to  => $return_to,
        trust_root => "http://$ENV{'HTTP_HOST'}/",
        delayed_return => 1
    );
    # request information about email address and full name
    $check_url .= "&openid.ns.ax=http://openid.net/srv/ax/1.0&openid.ax.mode=fetch_request&openid.ax.required=email,firstname,lastname&openid.ax.type.email=http://axschema.org/contact/email&openid.ax.type.firstname=http://axschema.org/namePerson/firs...

    # this shouldn't work, but oddly it does.
    # it has something to do with prototype ajax and the Location: string
    return (200,'text/html',"Location: $check_url"); # shouldn't work?

    # this should work, but oddly it doesn't
    # return (302,undef,$check_url);

}

# Confirm OpenID - Checks that the returned credentials are valid.
sub do_confirm_openid {
    my $self = shift;
    my ($callbacks, $sessionid, $option,$email,$fullname) = @_;
    
    my $userdb = $self->{dbi};
    
    my ($error, @results, $select, $user, $only);

    my $csr = Net::OpenID::Consumer->new(
        ua              => LWP::UserAgent->new,
        args            => $callbacks,
        consumer_secret => Bio::Graphics::Browser2->openid_secret,
        required_root   => "http://$ENV{'HTTP_HOST'}/"
    );

    if ($option eq "openid-add") {
        ($user, $only) = $userdb->selectrow_array(
	    "SELECT b.username,a.openid_only FROM users as a,session as b WHERE b.sessionid=? AND a.userid=b.userid",
	    undef,
	    $sessionid)
	    or return(200,'application/json',[{error=>'Error: '.$userdb->errstr.'.'}]);
        unless (defined $user) {
            push @results,{error=>"Error: Wrong session ID provided, please try again."};
            return (200,'application/json',\@results);
        }
    }

    $csr->handle_server_response(
        not_openid => sub {
            push @results,{user=>$user,only=>$only,error=>"Invalid OpenID provided, please check your spelling."};
        },
        setup_required => sub {
            push @results,{user=>$user,only=>$only,error=>"Error: Your OpenID requires setup."};
        },
        cancelled => sub {
            push @results,{user=>$user,only=>$only,error=>"OpenID verification cancelled."};
        },
        verified => sub {
            my $vident = shift;
            if($option eq "openid-add") {
		push @results,$self->do_add_openid_to_account($sessionid, $user, $vident->url, $only)
            } else {
		push @results,$self->do_get_openid($vident->url,$email,$fullname);
            }
        },
        error => sub {
            $error = $csr->err;
            push @results,{user=>$user,only=>$only,error=>"Error validating identity: $error."};
        }
    );
    return (200,'application/json',\@results);
}

sub do_get_gecos {
    my $self = shift;
    my $user = shift;
    my $sessionid = $self->sessionid_from_username($user) or return '';
    my $fullname = $self->fullname_from_sessionid($sessionid);
    return $self->string_result($fullname);
}



( run in 0.564 second using v1.01-cache-2.11-cpan-ceb78f64989 )