devel - Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory

Subject: Developers of Sympa

List archive

Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory

From: IKEDA Soji <address@concealed>
To: address@concealed
Subject: Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory
Date: Thu, 2 Jan 2014 20:39:13 +0900

All,

A happy new year!

And Guillaume.

Stop.

Before you move files, please talk us your plan of refactoring.
I have some proposal to your works on sympa-cleanup brahch.

But unfortunately, I'm in new year vacation (in Japan, a few days
before and after arrival of new year, all works in the country
stops). Please give me a few days to respond you.

Celebrating new year for Sympa,

-- Soji

On Thu, 2 Jan 2014 10:16:17 +0100 (CET)
address@concealed wrote:

> sympa[10085] trunk: [dev] move all perl modules in the same src/lib
> directory
> Revision 10085 Author rousse Date 2014-01-02 10:16:17 +0100 (jeu. 02 janv.
> 2014)
> Log Message[dev] move all perl modules in the same src/lib directory
> Modified Paths
> trunk/po/POTFILES.in
> trunk/src/lib/Makefile.am
> trunk/wwsympa/Makefile.am
> Added Paths
> trunk/src/lib/Auth.pm
> trunk/src/lib/Challenge.pm
> trunk/src/lib/Marc/
> trunk/src/lib/Marc.pm
> trunk/src/lib/SharedDocument.pm
> trunk/src/lib/SympaSession.pm
> trunk/src/lib/cookielib.pm
> trunk/src/lib/wwslib.pm
> Removed Paths
> trunk/wwsympa/Auth.pm
> trunk/wwsympa/Challenge.pm
> trunk/wwsympa/Marc/
> trunk/wwsympa/Marc.pm
> trunk/wwsympa/SharedDocument.pm
> trunk/wwsympa/SympaSession.pm
> trunk/wwsympa/cookielib.pm
> trunk/wwsympa/wwslib.pm
> Diff
> Modified: trunk/po/POTFILES.in (10084 => 10085)
> --- trunk/po/POTFILES.in 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/po/POTFILES.in 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -288,12 +288,12 @@
> web_tt2/view_template.tt2
> web_tt2/your_lists.tt2
> wwsympa/archived.pl.in
> -wwsympa/Auth.pm
> +src/lib/Auth.pm
> wwsympa/bounced.pl.in
> #wwsympa/Challenge.pm
> -wwsympa/cookielib.pm
> -wwsympa/Marc.pm
> -wwsympa/SharedDocument.pm
> -wwsympa/SympaSession.pm
> -wwsympa/wwslib.pm
> +src/lib/cookielib.pm
> +src/lib/Marc.pm
> +src/lib/SharedDocument.pm
> +src/lib/SympaSession.pm
> +src/lib/wwslib.pm
> wwsympa/wwsympa.fcgi.in
> Copied: trunk/src/lib/Auth.pm (from rev 10083, trunk/wwsympa/Auth.pm) (0
> => 10085)
> --- trunk/src/lib/Auth.pm (rev 0)
> +++ trunk/src/lib/Auth.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,575 @@
> +# Auth.pm - This module provides web authentication functions
> +# RCS Identication ; $Revision$ ; $Date$
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package Auth;
> +
> +use Digest::MD5;
> +
> +use Language qw(gettext_strftime);
> +
> +#use Log;
> +#use Conf;
> +#use List; # not used
> +use report;
> +
> +#use SDM;
> +
> +## return the password finger print (this proc allow futur replacement of
> md5 by sha1 or ....)
> +sub password_fingerprint {
> +
> + Sympa::Log::Syslog::do_log('debug', 'Auth::password_fingerprint');
> +
> + my $pwd = shift;
> + if (Site->password_case eq 'insensitive') {
> + return &tools::md5_fingerprint(lc($pwd));
> + } else {
> + return &tools::md5_fingerprint($pwd);
> + }
> +}
> +
> +## authentication : via email or uid
> +sub check_auth {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, ...)', @_);
> + my $robot = Robot::clean_robot(shift);
> + my $auth = shift; ## User email or UID
> + my $pwd = shift; ## Password
> +
> + my ($canonic, $user);
> +
> + if (&tools::valid_email($auth)) {
> + return authentication($robot, $auth, $pwd);
> + } else {
> + ## This is an UID
> + foreach my $ldap (@{Site->auth_services->{$robot->domain}}) {
> +
> + # only ldap service are to be applied here
> + next unless ($ldap->{'auth_type'} eq 'ldap');
> +
> + $canonic =
> + ldap_authentication($robot, $ldap, $auth, $pwd, 'uid_filter');
> + last if ($canonic); ## Stop at first match
> + }
> + if ($canonic) {
> +
> + unless ($user = User::get_global_user($canonic)) {
> + $user = {'email' => $canonic};
> + }
> + return {
> + 'user' => $user,
> + 'auth' => 'ldap',
> + 'alt_emails' => {$canonic => 'ldap'}
> + };
> +
> + } else {
> + &report::reject_report_web('user', 'incorrect_passwd', {})
> + unless ($ENV{'SYMPA_SOAP'});
> + Sympa::Log::Syslog::do_log('err', "Incorrect LDAP password");
> + return undef;
> + }
> + }
> +}
> +
> +## This subroutine if Sympa may use its native authentication for a given
> user
> +## It might not if no user_table paragraph is found in auth.conf or if the
> regexp or
> +## negative_regexp exclude this user
> +## IN : robot, user email
> +## OUT : boolean
> +sub may_use_sympa_native_auth {
> + my $robot = Robot::clean_robot(shift);
> + my $user_email = shift;
> +
> + my $ok = 0;
> + ## check each auth.conf paragrpah
> + foreach my $auth_service (@{Site->auth_services->{$robot->domain}}) {
> + next unless ($auth_service->{'auth_type'} eq 'user_table');
> +
> + next
> + if ($auth_service->{'regexp'} &&
> + ($user_email !~ /$auth_service->{'regexp'}/i));
> + next
> + if ($auth_service->{'negative_regexp'} &&
> + ($user_email =~ /$auth_service->{'negative_regexp'}/i));
> +
> + $ok = 1;
> + last;
> + }
> +
> + return $ok;
> +}
> +
> +sub authentication {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, ...)', @_);
> + my $robot = Robot::clean_robot(shift);
> + my $email = shift;
> + my $pwd = shift;
> + my ($user, $canonic);
> +
> + unless ($user = User::get_global_user($email)) {
> + $user = {'email' => $email};
> + }
> + unless ($user->{'password'}) {
> + $user->{'password'} = '';
> + }
> +
> + if ($user->{'wrong_login_count'} > $robot->max_wrong_password) {
> +
> + # too many wrong login attemp
> + User::update_global_user($email,
> + {wrong_login_count => $user->{'wrong_login_count'} + 1});
> + &report::reject_report_web('user', 'too_many_wrong_login', {})
> + unless ($ENV{'SYMPA_SOAP'});
> + Sympa::Log::Syslog::do_log('err',
> + 'login is blocked : too many wrong password submission for %s',
> + $email);
> + return undef;
> + }
> + foreach my $auth_service (@{Site->auth_services->{$robot->domain}}) {
> + next if ($auth_service->{'auth_type'} eq 'authentication_info_url');
> + next if ($email !~ /$auth_service->{'regexp'}/i);
> + next
> + if (($email =~ /$auth_service->{'negative_regexp'}/i) &&
> + ($auth_service->{'negative_regexp'}));
> +
> + ## Only 'user_table' and 'ldap' backends will need that Sympa
> collects the user passwords
> + ## Other backends are Single Sign-On solutions
> + if ($auth_service->{'auth_type'} eq 'user_table') {
> + my $fingerprint = &password_fingerprint($pwd);
> +
> + if ($fingerprint eq $user->{'password'}) {
> + User::update_global_user($email, {wrong_login_count => 0});
> + return {
> + 'user' => $user,
> + 'auth' => 'classic',
> + 'alt_emails' => {$email => 'classic'}
> + };
> + }
> + } elsif ($auth_service->{'auth_type'} eq 'ldap') {
> + if ($canonic = ldap_authentication(
> + $robot, $auth_service, $email, $pwd, 'email_filter'
> + )
> + ) {
> + unless ($user = User::get_global_user($canonic)) {
> + $user = {'email' => $canonic};
> + }
> + User::update_global_user($canonic, {wrong_login_count => 0});
> + return {
> + 'user' => $user,
> + 'auth' => 'ldap',
> + 'alt_emails' => {$email => 'ldap'}
> + };
> + }
> + }
> + }
> +
> + # increment wrong login count.
> + User::update_global_user($email,
> + {wrong_login_count => $user->{'wrong_login_count'} + 1});
> +
> + &report::reject_report_web('user', 'incorrect_passwd', {})
> + unless ($ENV{'SYMPA_SOAP'});
> + Sympa::Log::Syslog::do_log('err', 'authentication: incorrect password
> for user %s',
> + $email);
> +
> + $param->{'init_email'} = $email;
> + $param->{'escaped_init_email'} = &tools::escape_chars($email);
> + return undef;
> +}
> +
> +sub ldap_authentication {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, ...)', @_);
> + my $robot = Robot::clean_robot(shift);
> + my $ldap = shift;
> + my $auth = shift;
> + my $pwd = shift;
> + my $whichfilter = shift;
> + my ($mesg, $host, $ldap_passwd, $ldap_anonymous);
> +
> + unless ($robot->get_etc_filename('auth.conf')) {
> + return undef;
> + }
> +
> + ## No LDAP entry is defined in auth.conf
> + if ($#{Site->auth_services->{$robot->domain}} < 0) {
> + Sympa::Log::Syslog::do_log('notice', 'Skipping empty auth.conf');
> + return undef;
> + }
> +
> + # only ldap service are to be applied here
> + return undef unless ($ldap->{'auth_type'} eq 'ldap');
> +
> + # skip ldap auth service if the an email address was provided
> + # and this email address does not match the corresponding regexp
> + return undef if ($auth =~ /@/ && $auth !~ /$ldap->{'regexp'}/i);
> +
> + my @alternative_conf = split(/,/,
> $ldap->{'alternative_email_attribute'});
> + my $attrs = $ldap->{'email_attribute'};
> + my $filter = $ldap->{'get_dn_by_uid_filter'}
> + if ($whichfilter eq 'uid_filter');
> + $filter = $ldap->{'get_dn_by_email_filter'}
> + if ($whichfilter eq 'email_filter');
> + $filter =~ s/\[sender\]/$auth/ig;
> +
> + ## bind in order to have the user's DN
> + my $param = &tools::dup_var($ldap);
> + my $ds = new LDAPSource($param);
> +
> + unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
> + Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> + $ldap->{'host'});
> + return undef;
> + }
> +
> + $mesg = $ldap_anonymous->search(
> + base => $ldap->{'suffix'},
> + filter => "$filter",
> + scope => $ldap->{'scope'},
> + timeout => $ldap->{'timeout'}
> + );
> +
> + if ($mesg->count() == 0) {
> + Sympa::Log::Syslog::do_log('notice',
> + 'No entry in the Ldap Directory Tree of %s for %s',
> + $ldap->{'host'}, $auth);
> + $ds->disconnect();
> + return undef;
> + }
> +
> + my $refhash = $mesg->as_struct();
> + my (@DN) = keys(%$refhash);
> + $ds->disconnect();
> +
> + ## bind with the DN and the pwd
> +
> + ## Duplicate structure first
> + ## Then set the bind_dn and password according to the current user
> + $param = &tools::dup_var($ldap);
> + $param->{'ldap_bind_dn'} = $DN[0];
> + $param->{'ldap_bind_password'} = $pwd;
> +
> + $ds = new LDAPSource($param);
> +
> + unless (defined $ds && ($ldap_passwd = $ds->connect())) {
> + Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> + $param->{'host'});
> + return undef;
> + }
> +
> + $mesg = $ldap_passwd->search(
> + base => $ldap->{'suffix'},
> + filter => "$filter",
> + scope => $ldap->{'scope'},
> + timeout => $ldap->{'timeout'}
> + );
> +
> + if ($mesg->count() == 0 || $mesg->code() != 0) {
> + Sympa::Log::Syslog::do_log('notice', "No entry in the LDAP Directory
> Tree of %s",
> + $ldap->{'host'});
> + $ds->disconnect();
> + return undef;
> + }
> +
> + ## To get the value of the canonic email and the alternative email
> + my (@canonic_email, @alternative);
> +
> + ## Keep previous alt emails not from LDAP source
> + my $previous = {};
> + foreach my $alt (keys %{$param->{'alt_emails'}}) {
> + $previous->{$alt} = $param->{'alt_emails'}{$alt}
> + if ($param->{'alt_emails'}{$alt} ne 'ldap');
> + }
> + $param->{'alt_emails'} = {};
> +
> + my $entry = $mesg->entry(0);
> + @canonic_email = $entry->get_value($attrs, 'alloptions' => 1);
> + foreach my $email (@canonic_email) {
> + my $e = lc($email);
> + $param->{'alt_emails'}{$e} = 'ldap' if ($e);
> + }
> +
> + foreach my $attribute_value (@alternative_conf) {
> + @alternative = $entry->get_value($attribute_value, 'alloptions' => 1);
> + foreach my $alter (@alternative) {
> + my $a = lc($alter);
> + $param->{'alt_emails'}{$a} = 'ldap' if ($a);
> + }
> + }
> +
> + ## Restore previous emails
> + foreach my $alt (keys %{$previous}) {
> + $param->{'alt_emails'}{$alt} = $previous->{$alt};
> + }
> +
> + $ds->disconnect() or Sympa::Log::Syslog::do_log('notice', "unable to
> unbind");
> + Sympa::Log::Syslog::do_log('debug3', "canonic: $canonic_email[0]");
> + ## If the identifier provided was a valid email, return the provided
> email.
> + ## Otherwise, return the canonical email guessed after the login.
> + if (&tools::valid_email($auth) && !$robot->ldap_force_canonical_email)
> {
> + return ($auth);
> + } else {
> + return lc($canonic_email[0]);
> + }
> +}
> +
> +# fetch user email using his cas net_id and the paragrapah number in
> auth.conf
> +## NOTE: This might be moved to Robot package.
> +sub get_email_by_net_id {
> + my $robot = Robot::clean_robot(shift);
> + my $auth_id = shift;
> + my $attributes = shift;
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, uid=%s)',
> + $robot, $auth_id, $attributes->{'uid'});
> +
> + if (defined Site->auth_services->{$robot->domain}[$auth_id]
> + {'internal_email_by_netid'}) {
> + my $sso_config = @{Site->auth_services->{$robot->domain}}[$auth_id];
> + my $netid_cookie = $sso_config->{'netid_http_header'};
> +
> + $netid_cookie =~ s/(\w+)/$attributes->{$1}/ig;
> +
> + $email =
> + $robot->get_netidtoemail_db($netid_cookie,
> + Site->auth_services->{$robot->domain}[$auth_id]{'service_id'});
> +
> + return $email;
> + }
> +
> + my $ldap = @{Site->auth_services->{$robot->domain}}[$auth_id];
> +
> + my $param = &tools::dup_var($ldap);
> + my $ds = new LDAPSource($param);
> + my $ldap_anonymous;
> +
> + unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
> + Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> + $ldap->{'ldap_host'});
> + return undef;
> + }
> +
> + my $filter = $ldap->{'ldap_get_email_by_uid_filter'};
> + $filter =~ s/\[([\w-]+)\]/$attributes->{$1}/ig;
> +
> + # my @alternative_conf =
> split(/,/,$ldap->{'alternative_email_attribute'});
> +
> + my $emails = $ldap_anonymous->search(
> + base => $ldap->{'ldap_suffix'},
> + filter => $filter,
> + scope => $ldap->{'ldap_scope'},
> + timeout => $ldap->{'ldap_timeout'},
> + attrs => [$ldap->{'ldap_email_attribute'}],
> + );
> + my $count = $emails->count();
> +
> + if ($emails->count() == 0) {
> + Sympa::Log::Syslog::do_log('notice', "No entry in the LDAP Directory
> Tree of %s",
> + $host);
> + $ds->disconnect();
> + return undef;
> + }
> +
> + $ds->disconnect();
> +
> + ## return only the first attribute
> + my @results = $emails->entries;
> + foreach my $result (@results) {
> + return (lc($result->get_value($ldap->{'ldap_email_attribute'})));
> + }
> +
> +}
> +
> +# check trusted_application_name et trusted_application_password : return
> 1 or undef;
> +sub remote_app_check_password {
> + my $trusted_application_name = shift;
> + my $password = shift;
> + my $robot = Robot::clean_robot(shift);
> + Sympa::Log::Syslog::do_log('debug2', '(%s, ..., %s)',
> $trusted_application_name, $robot);
> +
> + my $md5 = &tools::md5_fingerprint($password);
> +
> + my $vars;
> +
> + # seach entry for trusted_application in Conf
> + my @trusted_apps;
> +
> + # select trusted_apps from robot context or sympa context
> + @trusted_apps = @{$robot->trusted_applications};
> +
> + foreach my $application (@trusted_apps) {
> +
> + if (lc($application->{'name'}) eq lc($trusted_application_name)) {
> + if ($md5 eq $application->{'md5password'}) {
> +
> +# Sympa::Log::Syslog::do_log('debug', 'Auth::remote_app_check_password :
> authentication succeed for %s',$application->{'name'});
> + my %proxy_for_vars;
> + foreach my $varname (@{$application->{'proxy_for_variables'}})
> + {
> + $proxy_for_vars{$varname} = 1;
> + }
> + return (\%proxy_for_vars);
> + } else {
> + Sympa::Log::Syslog::do_log('info',
> + 'Auth::remote_app_check_password: bad password from %s',
> + $trusted_application_name);
> + return undef;
> + }
> + }
> + }
> +
> + # no matching application found
> + Sympa::Log::Syslog::do_log('info',
> + 'Auth::remote_app-check_password: unknown application name %s',
> + $trusted_application_name);
> + return undef;
> +}
> +
> +# create new entry in one_time_ticket table using a rand as id so later
> +# access is authenticated
> +sub create_one_time_ticket {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> + my $email = shift;
> + my $robot = Robot::clean_robot(shift);
> + my $data_string = shift;
> + my $remote_addr = shift;
> + ## Value may be 'mail' if the IP address is not known
> +
> + my $ticket = &SympaSession::get_random();
> +
> + my $date = time;
> + my $sth;
> +
> + unless (
> + SDM::do_prepared_query(
> + q{INSERT INTO one_time_ticket_table
> + (ticket_one_time_ticket, robot_one_time_ticket,
> + email_one_time_ticket, date_one_time_ticket, data_one_time_ticket,
> + remote_addr_one_time_ticket, status_one_time_ticket)
> + VALUES (?, ?, ?, ?, ?, ?, ?)},
> + $ticket, $robot->domain,
> + $email, time, $data_string,
> + $remote_addr, 'open'
> + )
> + ) {
> + Sympa::Log::Syslog::do_log(
> + 'err',
> + 'Unable to insert new one time ticket for user %s, robot %s in
> the database',
> + $email,
> + $robot
> + );
> + return undef;
> + }
> + return $ticket;
> +}
> +
> +# read one_time_ticket from table and remove it
> +sub get_one_time_ticket {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s)', @_);
> + my $robot = shift;
> + my $ticket_number = shift;
> + my $addr = shift;
> +
> + my $sth;
> +
> + unless (
> + $sth = SDM::do_prepared_query(
> + q{SELECT ticket_one_time_ticket AS ticket,
> + robot_one_time_ticket AS robot,
> + email_one_time_ticket AS email,
> + date_one_time_ticket AS "date",
> + data_one_time_ticket AS data,
> + remote_addr_one_time_ticket AS remote_addr,
> + status_one_time_ticket as status
> + FROM one_time_ticket_table
> + WHERE ticket_one_time_ticket = ? AND robot_one_time_ticket = ?},
> + $ticket_number, $robot->domain
> + )
> + ) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to retrieve one time ticket %s from database',
> + $ticket_number);
> + return {'result' => 'error'};
> + }
> +
> + my $ticket = $sth->fetchrow_hashref('NAME_lc');
> + $sth->finish;
> +
> + unless ($ticket) {
> + Sympa::Log::Syslog::do_log('info', 'Unable to find one time ticket
> %s', $ticket);
> + return {'result' => 'not_found'};
> + }
> +
> + my $result;
> + my $printable_date = gettext_strftime "%d %b %Y at %H:%M:%S",
> + localtime($ticket->{'date'});
> + my $lockout = $robot->one_time_ticket_lockout || 'open';
> + my $lifetime =
> + tools::duration_conv($robot->one_time_ticket_lifetime || 0);
> +
> + if ($lockout eq 'one_time' and $ticket->{'status'} ne 'open') {
> + $result = 'closed';
> + Sympa::Log::Syslog::do_log('info', 'ticket %s from %s has been used
> before (%s)',
> + $ticket_number, $ticket->{'email'}, $printable_date);
> + } elsif ($lockout eq 'remote_addr' and
> + $ticket->{'status'} ne $addr and
> + $ticket->{'status'} ne 'open') {
> + $result = 'closed';
> + Sympa::Log::Syslog::do_log('info',
> + 'ticket %s from %s refused because accessed by the other (%s)',
> + $ticket_number, $ticket->{'email'}, $printable_date);
> + } elsif ($lifetime and $ticket->{'date'} + $lifetime < time) {
> + Sympa::Log::Syslog::do_log('info', 'ticket %s from %s refused because
> expired (%s)',
> + $ticket_number, $ticket->{'email'}, $printable_date);
> + $result = 'expired';
> + } else {
> + $result = 'success';
> + }
> +
> + if ($result eq 'success') {
> + unless (
> + $sth = SDM::do_prepared_query(
> + q{UPDATE one_time_ticket_table
> + SET status_one_time_ticket = ?
> + WHERE ticket_one_time_ticket = ? AND robot_one_time_ticket = ?},
> + $addr, $ticket_number, $robot->domain
> + )
> + ) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to set one time ticket %s status to %s',
> + $ticket_number, $addr);
> + } elsif (!$sth->rows) {
> +
> + # ticket may be removed by task.
> + Sympa::Log::Syslog::do_log('info', 'Unable to find one time
> ticket %s',
> + $ticket_number);
> + return {'result' => 'not_found'};
> + }
> + }
> +
> + Sympa::Log::Syslog::do_log('debug', 'ticket : %s; result : %s',
> $ticket_number, $result);
> + return {
> + 'result' => $result,
> + 'date' => $ticket->{'date'},
> + 'email' => $ticket->{'email'},
> + 'remote_addr' => $ticket->{'remote_addr'},
> + 'robot' => $robot->domain,
> + 'data' => $ticket->{'data'},
> + 'status' => $ticket->{'status'}
> + };
> +}
> +
> +1;
> Copied: trunk/src/lib/Challenge.pm (from rev 10083,
> trunk/wwsympa/Challenge.pm) (0 => 10085)
> --- trunk/src/lib/Challenge.pm (rev 0)
> +++ trunk/src/lib/Challenge.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,135 @@
> +# Challenge.pm - This module includes functions managing email challenges
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package Challenge;
> +
> +use strict;
> +no strict "vars";
> +
> +use Digest::MD5;
> +use POSIX;
> +use CGI::Cookie;
> +use Time::Local;
> +
> +use Log;
> +use Conf;
> +use SympaSession;
> +use SDM;
> +
> +# this structure is used to define which session attributes are stored in
> a dedicated database col where others are compiled in col 'data_session'
> +my %challenge_hard_attributes = ('id_challenge' => 1, 'date' => 1, 'robot'
> => 1,'email' => 1, 'list' => 1);
> +
> +
> +# create a challenge context and store it in challenge table
> +sub create {
> + my ($robot, $email, $context) = @_;
> +
> + Sympa::Log::Syslog::do_log('debug', 'Challenge::new(%s, %s, %s)',
> $challenge_id, $email, $robot);
> +
> + my $challenge={};
> +
> + unless ($robot) {
> + Sympa::Log::Syslog::do_log('err', 'Missing robot parameter, cannot
> create challenge object') ;
> + return undef;
> + }
> +
> + unless ($email) {
> + Sympa::Log::Syslog::do_log('err', 'Missing email parameter, cannot
> create challenge object') ;
> + return undef;
> + }
> +
> + $challenge->{'id_challenge'} = &get_random();
> + $challenge->{'email'} = $email;
> + $challenge->{'date'} = time;
> + $challenge->{'robot'} = $robot;
> + $challenge->{'data'} = $context;
> + return undef unless (&Challenge::store($challenge));
> + return $challenge->{'id_challenge'}
> +}
> +
> +
> +
> +sub load {
> +
> + my $id_challenge = shift;
> +
> + Sympa::Log::Syslog::do_log('debug', 'Challenge::load(%s)',
> $id_challenge);
> +
> + unless ($challenge_id) {
> + Sympa::Log::Syslog::do_log('err', 'Challenge::load() : internal
> error, SympaSession::load called with undef id_challenge');
> + return undef;
> + }
> +
> + my $sth;
> +
> + unless($sth = &SDM::do_query("SELECT id_challenge AS id_challenge,
> date_challenge AS 'date', remote_addr_challenge AS remote_addr,
> robot_challenge AS robot, email_challenge AS email, data_challenge AS data,
> hit_challenge AS hit, start_date_challenge AS start_date FROM
> challenge_table WHERE id_challenge = %s", $cookie)) {
> + Sympa::Log::Syslog::do_log('err','Unable to retrieve challenge %s
> from database',$cookie);
> + return undef;
> + }
> +
> + my $challenge = $sth->fetchrow_hashref('NAME_lc');
> +
> + unless ($challenge) {
> + return 'not_found';
> + }
> + my $challenge_datas;
> +
> + my %datas= &tools::string_2_hash($challenge->{'data'});
> + foreach my $key (keys %datas) {$challenge_datas->{$key} =
> $datas{$key};}
> +
> + $challenge_datas->{'id_challenge'} = $challenge->{'id_challenge'};
> + $challenge_datas->{'date'} = $challenge->{'date'};
> + $challenge_datas->{'robot'} = $challenge->{'robot'};
> + $challenge_datas->{'email'} = $challenge->{'email'};
> +
> + Sympa::Log::Syslog::do_log('debug3', 'Challenge::load(): removing
> existing challenge del_statement = %s',$del_statement);
> + unless(&SDM::do_query("DELETE FROM challenge_table WHERE
> (id_challenge=%s)",$id_challenge)) {
> + Sympa::Log::Syslog::do_log('err','Unable to delete challenge %s from
> database',$id_challenge);
> + return undef;
> + }
> +
> + return ('expired') if (time - $challenge_datas->{'date'} >=
> &tools::duration_conv(Site->challenge_table_ttl));
> + return ($challenge_datas);
> +}
> +
> +
> +sub store {
> +
> + my $challenge = shift;
> + Sympa::Log::Syslog::do_log('debug', 'Challenge::store()');
> +
> + return undef unless ($challenge->{'id_challenge'});
> +
> + my %hash ;
> + foreach my $var (keys %$challenge ) {
> + next if ($challenge_hard_attributes{$var});
> + next unless ($var);
> + $hash{$var} = $challenge->{$var};
> + }
> + my $data_string = &tools::hash_2_string (\%hash);
> + my $sth;
> +
> + unless(&SDM::do_query("INSERT INTO challenge_table (id_challenge,
> date_challenge, robot_challenge, email_challenge, data_challenge) VALUES
> ('%s','%s','%s','%s','%s'')",$challenge->{'id_challenge'},$challenge->{'date'},$challenge->{'robot'},$challenge->{'email'},$data_string))
> {
> + Sympa::Log::Syslog::do_log('err','Unable to store challenge %s
> informations in database (robot: %s, user:
> %s)',$challenge->{'id_challenge'},$challenge->{'robot'},$challenge->{'email'});
> + return undef;
> + }
> +}
> +
> +1;
> +
> Modified: trunk/src/lib/Makefile.am (10084 => 10085)
> --- trunk/src/lib/Makefile.am 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/src/lib/Makefile.am 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -10,7 +10,9 @@
> DBManipulatorMySQL.pm DBManipulatorSQLite.pm\
> DBManipulatorSybase.pm DBManipulatorOracle.pm \
> DBManipulatorPostgres.pm DBManipulatorDefault.pm \
> - listdef.pm moddef.pm Site.pm User.pm BounceMessage.pm
> + listdef.pm moddef.pm Site.pm User.pm BounceMessage.pm \
> + wwslib.pm cookielib.pm Marc.pm Auth.pm \
> + Marc/Search.pm SharedDocument.pm SympaSession.pm
>
> EXTRA_DIST = Sympa/Constants.pm.in $(nobase_modules_DATA)
> CLEANFILES = Sympa/Constants.pm
> Copied: trunk/src/lib/Marc.pm (from rev 10083, trunk/wwsympa/Marc.pm) (0
> => 10085)
> --- trunk/src/lib/Marc.pm (rev 0)
> +++ trunk/src/lib/Marc.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,58 @@
> +package Marc;
> +
> +use strict;
> +
> +use Carp;
> +
> +our $AUTOLOAD;
> +our $VERSION = "4.3";
> +
> +##------------------------------------------------------------------------##
> +## Constructor
> +
> +sub new
> +{
> + my $class = shift;
> + my $fields_ref = shift;
> + my $self =
> + {
> + directory_labels => {},
> + permitted => $fields_ref,
> + sort_function => 'sub { $a cmp $b }',
> + %$fields_ref,
> + };
> + $self->{permitted}->{sort_function} = 'sub { $a cmp $b }';
> + bless $self,$class;
> + return $self;
> +}
> +
> +##------------------------------------------------------------------------##
> +## The AUTOLOAD function allows for the dynamic creation of accessor
> methods
> +
> +sub AUTOLOAD
> +{
> + my $self = shift;
> + my $type = ref($self) or croak "$self is not an object";
> + my $name = $AUTOLOAD;
> +
> + # DESTROY messages should never be propagated.
> + return if $name =~ /::DESTROY$/;
> + # Remove the package name.
> + $name =~ s/^.*://;
> +
> + unless (exists($self->{permitted}->{$name}))
> + {
> + &message('arcsearch_marc_autoload_no_access');
> + &wwslog('info','arcsearch_marc: Can not access %s field in
> object of class %s', $name, $type);
> + return undef;
> + }
> + if (@_)
> + {
> + return $self->{$name} = shift;
> + }
> + else
> + {
> + return $self->{$name};
> + }
> +}
> +1;
> Copied: trunk/src/lib/SharedDocument.pm (from rev 10083,
> trunk/wwsympa/SharedDocument.pm) (0 => 10085)
> --- trunk/src/lib/SharedDocument.pm (rev 0)
> +++ trunk/src/lib/SharedDocument.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,533 @@
> +# SharedDocument.pm - module to manipulate shared web documents
> +# 
> +
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package SharedDocument;
> +
> +use strict;
> +
> +#use Carp; # currently not used
> +#use POSIX; # no longer used
> +
> +use tools;
> +use Language qw(gettext_strftime);
> +
> +#use List; # not used
> +use Log;
> +
> +## Creates a new object
> +sub new {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> + my ($pkg, $list, $path, $param) = @_;
> +
> + my $email = $param->{'user'}{'email'};
> +
> + #$email ||= 'nobody';
> + my $document = {};
> +
> + unless (ref($list) =~ /List/i) {
> + Sympa::Log::Syslog::do_log('err', 'SharedDocument::new : incorrect
> list parameter');
> + return undef;
> + }
> +
> + $document->{'root_path'} = $list->dir . '/shared';
> +
> + $document->{'path'} = &main::no_slash_end($path);
> + $document->{'escaped_path'} =
> + &tools::escape_chars($document->{'path'}, '/');
> +
> + ### Document isn't a description file
> + if ($document->{'path'} =~ /\.desc/) {
> + Sympa::Log::Syslog::do_log('err', "SharedDocument::new : %s :
> description file",
> + $document->{'path'});
> + return undef;
> + }
> +
> + ## absolute path
> + # my $doc;
> + $document->{'absolute_path'} = $document->{'root_path'};
> + if ($document->{'path'}) {
> + $document->{'absolute_path'} .= '/' . $document->{'path'};
> + }
> +
> + ## Check access control
> + &check_access_control($document, $param);
> +
> + ###############################
> + ## The path has been checked ##
> + ###############################
> +
> + ### Document exist ?
> + unless (-r $document->{'absolute_path'}) {
> + Sympa::Log::Syslog::do_log(
> + 'err',
> + "SharedDocument::new : unable to read %s : no such file or
> directory",
> + $document->{'absolute_path'}
> + );
> + return undef;
> + }
> +
> + ### Document has non-size zero?
> + unless (-s $document->{'absolute_path'}) {
> + Sympa::Log::Syslog::do_log(
> + 'err',
> + "SharedDocument::new : unable to read %s : empty document",
> + $document->{'absolute_path'}
> + );
> + return undef;
> + }
> +
> + $document->{'visible_path'} =
> + &main::make_visible_path($document->{'path'});
> +
> + ## Date
> + my @info = stat $document->{'absolute_path'};
> + $document->{'date'} = gettext_strftime "%d %b %Y", localtime $info[9];
> + $document->{'date_epoch'} = $info[9];
> +
> + # Size of the doc
> + $document->{'size'} = (-s $document->{'absolute_path'}) / 1000;
> +
> + ## Filename
> + my @tokens = split /\//, $document->{'path'};
> + $document->{'filename'} = $document->{'visible_filename'} =
> + $tokens[$#tokens];
> +
> + ## Moderated document
> + if ($document->{'filename'} =~ /^\.(.*)(\.moderate)$/) {
> + $document->{'moderate'} = 1;
> + $document->{'visible_filename'} = $1;
> + }
> +
> + $document->{'escaped_filename'} =
> + &tools::escape_chars($document->{'filename'});
> +
> + ## Father dir
> + if ($document->{'path'} =~ /^(([^\/]*\/)*)([^\/]+)$/) {
> + $document->{'father_path'} = $1;
> + } else {
> + $document->{'father_path'} = '';
> + }
> + $document->{'escaped_father_path'} =
> + &tools::escape_chars($document->{'father_path'}, '/');
> +
> + ### File, directory or URL ?
> + if (!(-d $document->{'absolute_path'})) {
> +
> + if ($document->{'filename'} =~ /^\..*\.(\w+)\.moderate$/) {
> + $document->{'file_extension'} = $1;
> + } elsif ($document->{'filename'} =~ /^.*\.(\w+)$/) {
> + $document->{'file_extension'} = $1;
> + }
> +
> + if ($document->{'file_extension'} eq 'url') {
> + $document->{'type'} = 'url';
> + } else {
> + $document->{'type'} = 'file';
> + }
> + } else {
> + $document->{'type'} = 'directory';
> + }
> +
> + ## Load .desc file unless root directory
> + my $desc_file;
> + if ($document->{'type'} eq 'directory') {
> + $desc_file = $document->{'absolute_path'} . '/.desc';
> + } else {
> + if ($document->{'absolute_path'} =~ /^(([^\/]*\/)*)([^\/]+)$/) {
> + $desc_file = $1 . '.desc.' . $3;
> + } else {
> + Sympa::Log::Syslog::do_log(
> + 'err',
> + "SharedDocument::new() : cannot determine desc file for %s",
> + $document->{'absolute_path'}
> + );
> + return undef;
> + }
> + }
> +
> + if ($document->{'path'} && (-e $desc_file)) {
> + my @info = stat $desc_file;
> + $document->{'serial_desc'} = $info[9];
> +
> + my %desc_hash = &main::get_desc_file($desc_file);
> + $document->{'owner'} = $desc_hash{'email'};
> + $document->{'title'} = $desc_hash{'title'};
> + $document->{'escaped_title'} =
> + &tools::escape_html($document->{'title'});
> +
> + # Author
> + if ($desc_hash{'email'}) {
> + $document->{'author'} = $desc_hash{'email'};
> + $document->{'author_mailto'} =
> + &main::mailto($list, $desc_hash{'email'});
> + $document->{'author_known'} = 1;
> + }
> + }
> +
> + ### File, directory or URL ?
> + if ($document->{'type'} eq 'url') {
> +
> + $document->{'icon'} = &main::get_icon('url');
> +
> + open DOC, $document->{'absolute_path'};
> + my $url = <DOC>;
> + close DOC;
> + chomp $url;
> + $document->{'url'} = $url;
> +
> + if ($document->{'filename'} =~ /^(.+)\.url/) {
> + $document->{'anchor'} = $1;
> + }
> + } elsif ($document->{'type'} eq 'file') {
> +
> + if (my $type = &main::get_mime_type($document->{'file_extension'})) {
> +
> + # type of the file and apache icon
> + if ($type =~ /^([\w\-]+)\/([\w\-]+)$/) {
> + my ($mimet, $subt) = ($1, $2);
> + if ($subt) {
> + if ($subt =~ /^octet-stream$/) {
> + $mimet = 'octet-stream';
> + $subt = 'binary';
> + }
> + $type = "$subt file";
> + }
> + $document->{'icon'} = &main::get_icon($mimet) ||
> + &main::get_icon('unknown');
> + }
> + } else {
> +
> + # unknown file type
> + $document->{'icon'} = &main::get_icon('unknown');
> + }
> +
> + ## HTML file
> + if ($document->{'file_extension'} =~ /^html?$/i) {
> + $document->{'html'} = 1;
> + $document->{'icon'} = &main::get_icon('text');
> + }
> +
> + ## Directory
> + } else {
> +
> + $document->{'icon'} = &main::get_icon('folder');
> +
> + # listing of all the shared documents of the directory
> + unless (opendir DIR, $document->{'absolute_path'}) {
> + Sympa::Log::Syslog::do_log(
> + 'err',
> + "SharedDocument::new() : cannot open %s : %s",
> + $document->{'absolute_path'}, $!
> + );
> + return undef;
> + }
> +
> + # array of entry of the directory DIR
> + my @tmpdir = readdir DIR;
> + closedir DIR;
> +
> + my $dir =
> + &main::get_directory_content(\@tmpdir, $email, $list,
> + $document->{'absolute_path'});
> +
> + foreach my $d (@{$dir}) {
> +
> + my $sub_document =
> + new SharedDocument($list, $document->{'path'} . '/' . $d,
> + $param);
> + push @{$document->{'subdir'}}, $sub_document;
> + }
> + }
> +
> + $document->{'list'} = $list;
> +
> + ## Bless Message object
> + bless $document, $pkg;
> +
> + return $document;
> +}
> +
> +sub dump {
> + my $self = shift;
> + my $fd = shift;
> +
> + &tools::dump_var($self, 0, $fd);
> +
> +}
> +
> +sub dup {
> + my $self = shift;
> +
> + my $copy = {};
> +
> + foreach my $k (keys %$self) {
> + $copy->{$k} = $self->{$k};
> + }
> +
> + return $copy;
> +}
> +
> +## Regulars
> +# read(/) = default (config list)
> +# edit(/) = default (config list)
> +# control(/) = not defined
> +# read(A/B)= (read(A) && read(B)) ||
> +# (author(A) || author(B))
> +# edit = idem read
> +# control (A/B) : author(A) || author(B)
> +# + (set owner A/B) if (empty directory &&
> +# control A)
> +
> +sub check_access_control {
> +
> + # Arguments:
> + # (\%mode,$path)
> + # if mode->{'read'} control access only for read
> + # if mode->{'edit'} control access only for edit
> + # if mode->{'control'} control access only for control
> +
> +# return the hash (
> +# $result{'may'}{'read'} == $result{'may'}{'edit'} ==
> $result{'may'}{'control'} if is_author else :
> +# $result{'may'}{'read'} = 0 or 1 (right or not)
> +# $result{'may'}{'edit'} = 0(not may edit) or 0.5(may edit with
> moderation) or 1(may edit ) : it is not a boolean anymore
> +# $result{'may'}{'control'} = 0 or 1 (right or not)
> +# $result{'reason'}{'read'} = string for authorization_reject.tt2 when
> may_read == 0
> +# $result{'reason'}{'edit'} = string for authorization_reject.tt2 when
> may_edit == 0
> +# $result{'scenario'}{'read'} = scenario name for the document
> +# $result{'scenario'}{'edit'} = scenario name for the document
> +
> + # Result
> + my %result;
> + $result{'reason'} = {};
> +
> + # Control
> +
> + # Arguments
> + my $self = shift;
> + my $param = shift;
> +
> + my $list = $self->{'list'};
> +
> + Sympa::Log::Syslog::do_log('debug', "check_access_control(%s)",
> $self->{'path'});
> +
> + # Control for editing
> + my $may_read = 1;
> + my $why_not_read = '';
> + my $may_edit = 1;
> + my $why_not_edit = '';
> +
> + ## First check privileges on the root shared directory
> + $result{'scenario'}{'read'} = $list->shared_doc->{'d_read'}{'name'};
> + $result{'scenario'}{'edit'} = $list->shared_doc->{'d_edit'}{'name'};
> +
> + ## Privileged owner has all privileges
> + if ($param->{'is_privileged_owner'}) {
> + $result{'may'}{'read'} = 1;
> + $result{'may'}{'edit'} = 1;
> + $result{'may'}{'control'} = 1;
> +
> + $self->{'access'} = \%result;
> + return 1;
> + }
> +
> + # if not privileged owner
> + if (1) {
> + my $result = Scenario::request_action(
> + $list,
> + 'shared_doc.d_read',
> + $param->{'auth_method'},
> + { 'sender' => $param->{'user'}{'email'},
> + 'remote_host' => $param->{'remote_host'},
> + 'remote_addr' => $param->{'remote_addr'}
> + }
> + );
> + my $action;
> + if (ref($result) eq 'HASH') {
> + $action = $result->{'action'};
> + $why_not_read = $result->{'reason'};
> + }
> +
> + $may_read = ($action =~ /do_it/i);
> + }
> +
> + if (1) {
> + my $result = Scenario::request_action(
> + $list,
> + 'shared_doc.d_edit',
> + $param->{'auth_method'},
> + { 'sender' => $param->{'user'}{'email'},
> + 'remote_host' => $param->{'remote_host'},
> + 'remote_addr' => $param->{'remote_addr'}
> + }
> + );
> + my $action;
> + if (ref($result) eq 'HASH') {
> + $action = $result->{'action'};
> + $why_not_edit = $result->{'reason'};
> + }
> +
> + #edit = 0, 0.5 or 1
> + $may_edit = &main::find_edit_mode($action);
> + $why_not_edit = '' if ($may_edit);
> + }
> +
> + ## Only authenticated users can edit files
> + unless ($param->{'user'}{'email'}) {
> + $may_edit = 0;
> + $why_not_edit = 'not_authenticated';
> + }
> +
> + my $current_path = $self->{'path'};
> + my $current_document;
> + my %desc_hash;
> + my $user = $param->{'user'}{'email'} || 'nobody';
> +
> + while ($current_path ne "") {
> +
> + # no description file found yet
> + my $def_desc_file = 0;
> + my $desc_file;
> +
> + $current_path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
> + $current_document = $3;
> + my $next_path = $1;
> +
> + # opening of the description file appropriated
> + if (-d $self->{'root_path'} . '/' . $current_path) {
> +
> + # case directory
> +
> + # unless ($slash) {
> + $current_path = $current_path . '/';
> +
> + # }
> +
> + if (-e "$self->{'root_path'}/$current_path.desc") {
> + $desc_file =
> + $self->{'root_path'} . '/' . $current_path . ".desc";
> + $def_desc_file = 1;
> + }
> +
> + } else {
> +
> + # case file
> + if (-e "$self->{'root_path'}/$next_path.desc.$3") {
> + $desc_file =
> + $self->{'root_path'} . '/' . $next_path . ".desc." . $3;
> + $def_desc_file = 1;
> + }
> + }
> +
> + if ($def_desc_file) {
> +
> + # a description file was found
> + # loading of acces information
> +
> + %desc_hash = &main::get_desc_file($desc_file);
> +
> + ## Author has all privileges
> + if ($user eq $desc_hash{'email'}) {
> + $result{'may'}{'read'} = 1;
> + $result{'may'}{'edit'} = 1;
> + $result{'may'}{'control'} = 1;
> +
> + $self->{'access'} = \%result;
> + return 1;
> + }
> +
> + if (1) {
> +
> + my $result = Scenario::request_action(
> + $list,
> + 'shared_doc.d_read',
> + $param->{'auth_method'},
> + { 'sender' => $param->{'user'}{'email'},
> + 'remote_host' => $param->{'remote_host'},
> + 'remote_addr' => $param->{'remote_addr'},
> + 'scenario' => $desc_hash{'read'}
> + }
> + );
> + my $action;
> + if (ref($result) eq 'HASH') {
> + $action = $result->{'action'};
> + $why_not_read = $result->{'reason'};
> + }
> +
> + $may_read = $may_read && ($action =~ /do_it/i);
> + $why_not_read = '' if ($may_read);
> + }
> +
> + if (1) {
> + my $result = Scenario::request_action(
> + $list,
> + 'shared_doc.d_edit',
> + $param->{'auth_method'},
> + { 'sender' => $param->{'user'}{'email'},
> + 'remote_host' => $param->{'remote_host'},
> + 'remote_addr' => $param->{'remote_addr'},
> + 'scenario' => $desc_hash{'edit'}
> + }
> + );
> + my $action_edit;
> + if (ref($result) eq 'HASH') {
> + $action_edit = $result->{'action'};
> + $why_not_edit = $result->{'reason'};
> + }
> +
> + # $may_edit = 0, 0.5 or 1
> + my $may_action_edit = &main::find_edit_mode($action_edit);
> + $may_edit = &main::merge_edit($may_edit, $may_action_edit);
> + $why_not_edit = '' if ($may_edit);
> +
> + }
> +
> + ## Only authenticated users can edit files
> + unless ($param->{'user'}{'email'}) {
> + $may_edit = 0;
> + $why_not_edit = 'not_authenticated';
> + }
> +
> + unless (defined $result{'scenario'}{'read'}) {
> + $result{'scenario'}{'read'} = $desc_hash{'read'};
> + $result{'scenario'}{'edit'} = $desc_hash{'edit'};
> + }
> +
> + }
> +
> + # truncate the path for the while
> + $current_path = $next_path;
> + }
> +
> + if (1) {
> + $result{'may'}{'read'} = $may_read;
> + $result{'reason'}{'read'} = $why_not_read;
> + }
> +
> + if (1) {
> + $result{'may'}{'edit'} = $may_edit;
> + $result{'reason'}{'edit'} = $why_not_edit;
> + }
> +
> + $self->{'access'} = \%result;
> + return 1;
> +}
> +
> +1;
> Copied: trunk/src/lib/SympaSession.pm (from rev 10083,
> trunk/wwsympa/SympaSession.pm) (0 => 10085)
> --- trunk/src/lib/SympaSession.pm (rev 0)
> +++ trunk/src/lib/SympaSession.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,796 @@
> +# SympaSession.pm - This module includes functions managing HTTP sessions
> in Sympa
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package SympaSession;
> +
> +use strict;
> +
> +use CGI::Cookie;
> +#use Digest::MD5; # no longer used
> +#use POSIX; # no longer used
> +#use Time::Local; # not used
> +
> +#use Conf; # no longer used
> +#use Log; # used by SDM
> +use SDM;
> +
> +# this structure is used to define which session attributes are stored in a
> +# dedicated database col where others are compiled in col 'data_session'
> +my %session_hard_attributes = ('id_session' => 1,
> + 'prev_id' => 1,
> + 'date' => 1,
> + 'refresh_date' => 1,
> + 'remote_addr' => 1,
> + 'robot' => 1,
> + 'email' => 1,
> + 'start_date' => 1,
> + 'hit' => 1,
> + 'new_session' => 1,
> + );
> +
> +sub new {
> + my $pkg = shift;
> + my $robot = Robot::clean_robot(shift, 1); #FIXME: maybe a Site object?
> + my $context = shift || {};
> +
> + my $cookie = $context->{'cookie'};
> + my $action = $context->{'action'};
> + my $rss = $context->{'rss'};
> + my $ajax = $context->{'ajax'};
> + Sympa::Log::Syslog::do_log('debug2', '(%s, cookie=%s, action=%s)',
> + $robot, $cookie, $action);
> +
> + my $self = {'robot' => $robot};
> + bless $self => $pkg;
> +
> + # passive_session are session not stored in the database, they are used
> + # for crawler bots and action such as css, wsdl, ajax and rss
> +
> + if (tools::is_a_crawler($robot,
> + {'user_agent_string' => $ENV{'HTTP_USER_AGENT'}})) {
> + $self->{'is_a_crawler'} = 1;
> + $self->{'passive_session'} = 1;
> + }
> + $self->{'passive_session'} = 1
> + if $rss or $action eq 'wsdl' or $action eq 'css';
> +
> + # if a session cookie exists, try to restore an existing session, don't
> + # store sessions from bots
> + if ($cookie and $self->{'passive_session'} != 1){
> + my $status ;
> + $status = $self->load($cookie);
> + unless (defined $status) {
> + return undef;
> + }
> + if ($status eq 'not_found') {
> + # start a new session (may be a fake cookie)
> + Sympa::Log::Syslog::do_log('info', 'ignoring unknown session
> cookie "%s"',
> + $cookie);
> + return __PACKAGE__->new($robot);
> + }
> + } else {
> + # create a new session context
> + ## Tag this session as new, ie no data in the DB exist
> + $self->{'new_session'} = 1;
> + $self->{'id_session'} = get_random();
> + $self->{'email'} = 'nobody';
> + $self->{'remote_addr'} = $ENV{'REMOTE_ADDR'};
> + $self->{'date'} = $self->{'start_date'} = $self->{'refresh_date'} =
> + time;
> + $self->{'hit'} = 1;
> + ##$self->{'robot'} = $robot->name;
> + $self->{'data'} = '';
> + }
> + return $self;
> +}
> +
> +sub load {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s)', @_);
> + my $self = shift;
> + my $cookie = shift;
> +
> + unless ($cookie) {
> + Sympa::Log::Syslog::do_log('err', 'internal error, undef id_session');
> + return undef;
> + }
> +
> + my $sth;
> + my $id_session;
> + my $is_old_session = 0;
> +
> + ## Load existing session.
> + if ($cookie and $cookie =~ /^\d{,16}$/) {
> + ## Compatibility: session by older releases of Sympa.
> + $id_session = $cookie;
> + $is_old_session = 1;
> +
> + ## Session by older releases of Sympa doesn't have refresh_date.
> + unless ($sth = SDM::do_prepared_query(
> + q{SELECT id_session AS id_session, id_session AS prev_id,
> + date_session AS "date",
> + remote_addr_session AS remote_addr,
> + robot_session AS robot, email_session AS email,
> + data_session AS data, hit_session AS hit,
> + start_date_session AS start_date,
> + date_session AS refresh_date
> + FROM session_table
> + WHERE robot_session = ? AND
> + id_session = ? AND
> + refresh_date_session IS NULL},
> + $self->{'robot'}->name, $id_session
> + )) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to load session %s',
> $id_session);
> + return undef;
> + }
> + } else {
> + $id_session = decrypt_session_id($cookie);
> + unless ($id_session) {
> + Sympa::Log::Syslog::do_log('err', 'internal error, undef
> id_session');
> + return 'not_found';
> + }
> +
> + ## Cookie may contain current or previous session ID.
> + unless ($sth = SDM::do_prepared_query(
> + q{SELECT id_session AS id_session, prev_id_session AS prev_id,
> + date_session AS "date",
> + remote_addr_session AS remote_addr,
> + robot_session AS robot, email_session AS email,
> + data_session AS data, hit_session AS hit,
> + start_date_session AS start_date,
> + refresh_date_session AS refresh_date
> + FROM session_table
> + WHERE robot_session = ? AND
> + (id_session = ? AND prev_id_session IS NOT NULL OR
> + prev_id_session = ?)},
> + $self->{'robot'}->name, $id_session, $id_session
> + )) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to load session %s',
> $id_session);
> + return undef;
> + }
> + }
> +
> + my $session = undef;
> + my $new_session = undef;
> + my $counter = 0;
> + while ($new_session = $sth->fetchrow_hashref('NAME_lc')) {
> + if ($counter > 0) {
> + Sympa::Log::Syslog::do_log('err',
> + 'The SQL statement did return more than one session');
> + $session->{'email'} = '';
> + last;
> + }
> + $session = $new_session;
> + $counter++;
> + }
> +
> + unless ($session) {
> + return 'not_found';
> + }
> +
> + ## Compatibility: Upgrade session by older releases of Sympa.
> + if ($is_old_session) {
> + SDM::do_prepared_query(
> + q{UPDATE session_table
> + SET prev_id_session = id_session
> + WHERE id_session = ? AND prev_id_session IS NULL AND
> + refresh_date_session IS NULL},
> + $id_session
> + );
> + }
> +
> + my %datas = tools::string_2_hash($session->{'data'});
> +
> + ## canonicalize lang if possible.
> + $datas{'lang'} =
> + Language::CanonicLang($datas{'lang'}) || $datas{'lang'}
> + if $datas{'lang'};
> +
> + foreach my $key (keys %datas) {$self->{$key} = $datas{$key};}
> +
> + $self->{'id_session'} = $session->{'id_session'};
> + $self->{'prev_id'} = $session->{'prev_id'};
> + $self->{'date'} = $session->{'date'};
> + $self->{'start_date'} = $session->{'start_date'};
> + $self->{'refresh_date'} = $session->{'refresh_date'};
> + $self->{'hit'} = $session->{'hit'} +1 ;
> + $self->{'remote_addr'} = $session->{'remote_addr'};
> + ##$self->{'robot'} = $session->{'robot'};
> + $self->{'email'} = $session->{'email'};
> +
> + return ($self);
> +}
> +
> +## This method will both store the session information in the database
> +sub store {
> + Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> + my $self = shift;
> +
> + return undef unless $self->{'id_session'};
> + # do not create a session in session table for crawlers;
> + return if $self->{'is_a_crawler'};
> + # do not create a session in session table for action such as RSS or
> CSS
> + # or wsdl that do not require this sophistication;
> + return if $self->{'passive_session'};
> +
> + my %hash;
> + foreach my $var (keys %$self ) {
> + next if ($session_hard_attributes{$var});
> + next unless ($var);
> + $hash{$var} = $self->{$var};
> + }
> + my $data_string = tools::hash_2_string (\%hash);
> + my $time = time;
> +
> + ## If this is a new session, then perform an INSERT
> + if ($self->{'new_session'}) {
> + ## Store the new session ID in the DB
> + ## Previous session ID is set to be same as new session ID.
> + unless (SDM::do_prepared_query(
> + q{INSERT INTO session_table
> + (id_session, prev_id_session,
> + date_session, refresh_date_session,
> + remote_addr_session, robot_session,
> + email_session, start_date_session, hit_session,
> + data_session)
> + VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)},
> + $self->{'id_session'}, $self->{'id_session'},
> + $time, $time,
> + $ENV{'REMOTE_ADDR'}, $self->{'robot'}->name,
> + $self->{'email'}, $self->{'start_date'}, $self->{'hit'},
> + $data_string
> + )) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to add new session %s informations in database',
> + $self->{'id_session'}
> + );
> + return undef;
> + }
> +
> + $self->{'prev_id'} = $self->{'id_session'};
> +
> + } else {
> + ## If the session already exists in DB, then perform an UPDATE
> +
> + ## Cookie may contain previous session ID.
> + my $sth = SDM::do_prepared_query(
> + q{SELECT id_session
> + FROM session_table
> + WHERE robot_session = ? AND prev_id_session = ?},
> + $self->{'robot'}->name, $self->{'id_session'}
> + );
> + unless ($sth) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to update session information in database');
> + return undef;
> + }
> + if ($sth->rows) {
> + my $new_id = $sth->fetchrow;
> + $sth->finish;
> + if ($new_id) {
> + $self->{'prev_id'} = $self->{'id_session'};
> + $self->{'id_session'} = $new_id;
> + }
> + }
> +
> + ## Update the new session in the DB
> + unless (SDM::do_prepared_query(
> + q{UPDATE session_table
> + SET date_session = ?, remote_addr_session = ?,
> + robot_session = ?, email_session = ?,
> + start_date_session = ?, hit_session = ?, data_session = ?
> + WHERE robot_session = ? AND
> + (id_session = ? AND prev_id_session IS NOT NULL OR
> + prev_id_session = ?)},
> + $time, $ENV{'REMOTE_ADDR'},
> + $self->{'robot'}->name, $self->{'email'},
> + $self->{'start_date'}, $self->{'hit'}, $data_string,
> + $self->{'robot'}->name,
> + $self->{'id_session'},
> + $self->{'id_session'}
> + )) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to update session %s information in database',
> + $self->{'id_session'}
> + );
> + return undef;
> + }
> + }
> +
> + return 1;
> +}
> +
> +## This method will renew the session ID
> +sub renew {
> + Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> + my $self = shift;
> +
> + return undef unless $self->{'id_session'};
> + # do not create a session in session table for crawlers;
> + return if $self->{'is_a_crawler'};
> + # do not create a session in session table for action such as RSS or
> CSS
> + # or wsdl that do not require this sophistication;
> + return if $self->{'passive_session'};
> +
> + my %hash;
> + foreach my $var (keys %$self ) {
> + next if ($session_hard_attributes{$var});
> + next unless ($var);
> + $hash{$var} = $self->{$var};
> + }
> + my $data_string = tools::hash_2_string(\%hash);
> +
> + my $sth;
> + ## Cookie may contain previous session ID.
> + $sth = SDM::do_prepared_query(
> + q{SELECT id_session
> + FROM session_table
> + WHERE robot_session = ? AND prev_id_session = ?},
> + $self->{'robot'}->name, $self->{'id_session'}
> + );
> + unless ($sth) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to update session information in database');
> + return undef;
> + }
> + if ($sth->rows) {
> + my $new_id = $sth->fetchrow;
> + $sth->finish;
> + if ($new_id) {
> + $self->{'prev_id'} = $self->{'id_session'};
> + $self->{'id_session'} = $new_id;
> + }
> + }
> +
> + ## Renew the session ID in order to prevent session hijacking
> + my $new_id = get_random();
> +
> + ## Do refresh the session ID when remote address was changed or refresh
> + ## interval was past. Conditions also are checked by SQL so that
> + ## simultaneous processes will be prevented renewing cookie.
> + my $time = time;
> + my $remote_addr = $ENV{'REMOTE_ADDR'};
> + my $refresh_term;
> + if (Site->cookie_refresh == 0) {
> + $refresh_term = $time;
> + } else {
> + my $cookie_refresh = Site->cookie_refresh;
> + $refresh_term =
> + int($time - $cookie_refresh * 0.25 - rand($cookie_refresh * 0.5));
> + }
> + unless ($self->{'remote_addr'} ne $remote_addr or
> + $self->{'refresh_date'} <= $refresh_term) {
> + return 0;
> + }
> +
> + ## First insert DB entry with new session ID,
> + $sth = SDM::do_query(
> + q{INSERT INTO session_table
> + (id_session, prev_id_session,
> + start_date_session, date_session, refresh_date_session,
> + remote_addr_session, robot_session, email_session,
> + hit_session, data_session)
> + SELECT %s, id_session,
> + start_date_session, date_session, %d,
> + %s, robot_session, email_session,
> + hit_session, data_session
> + FROM session_table
> + WHERE robot_session = %s AND
> + (id_session = %s AND prev_id_session IS NOT NULL OR
> + prev_id_session = %s) AND
> + (remote_addr_session <> %s OR refresh_date_session <= %d)},
> + SDM::quote($new_id),
> + $time,
> + SDM::quote($remote_addr),
> + SDM::quote($self->{'robot'}->name),
> + SDM::quote($self->{'id_session'}),
> + SDM::quote($self->{'id_session'}),
> + SDM::quote($remote_addr), $refresh_term
> + );
> + unless ($sth) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to renew session ID for
> session %s',
> + $self->{'id_session'});
> + return undef;
> + }
> + unless ($sth->rows) {
> + return 0;
> + }
> + ## Keep previous ID to prevent crosstalk, clearing grand-parent ID.
> + SDM::do_prepared_query(
> + q{UPDATE session_table
> + SET prev_id_session = NULL
> + WHERE robot_session = ? AND id_session = ?},
> + $self->{'robot'}->name, $self->{'id_session'}
> + );
> + ## Remove record of grand-parent ID.
> + SDM::do_prepared_query(
> + q{DELETE FROM session_table
> + WHERE id_session = ? AND prev_id_session IS NULL},
> + $self->{'prev_id'}
> + );
> +
> + ## Renew the session ID in order to prevent session hijacking
> + Sympa::Log::Syslog::do_log('info',
> + '[robot %s] [session %s] [client %s]%s new session %s',
> + $self->{'robot'}->name, $self->{'id_session'}, $remote_addr,
> + ($self->{'email'} ? sprintf(' [user %s]', $self->{'email'}) : ''),
> + $new_id
> + );
> + $self->{'prev_id'} = $self->{'id_session'};
> + $self->{'id_session'} = $new_id;
> + $self->{'refresh_date'} = $time;
> + $self->{'remote_addr'} = $remote_addr;
> +
> + return 1;
> +}
> +
> +## remove old sessions from a particular robot or from all robots.
> +## delay is a parameter in seconds
> +sub purge_old_sessions {
> + Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> + my $robot = Robot::clean_robot(shift, 1);
> +
> + my $delay = tools::duration_conv(Site->session_table_ttl);
> + my $anonymous_delay =
> + tools::duration_conv(Site->anonymous_session_table_ttl);
> +
> + unless ($delay) {
> + Sympa::Log::Syslog::do_log('debug3', 'exit with delay null');
> + return;
> + }
> + unless ($anonymous_delay) {
> + Sympa::Log::Syslog::do_log('debug3', 'exit with anonymous delay
> null');
> + return;
> + }
> +
> + my @sessions ;
> + my $sth;
> +
> + my $condition = '';
> + $condition = sprintf 'robot_session = %s', SDM::quote($robot->name)
> + if ref $robot eq 'Robot';
> + my $anonymous_condition = $condition;
> +
> + $condition .= sprintf '%s%d > date_session',
> + ($condition ? ' AND ' : ''), time - $delay
> + if $delay;
> + $condition = " WHERE $condition"
> + if $condition;
> +
> + $anonymous_condition .= sprintf '%s%d > date_session',
> + ($anonymous_condition ? ' AND ' : ''), time - $anonymous_delay
> + if $anonymous_delay;
> + $anonymous_condition .= sprintf
> + "%semail_session = 'nobody' AND hit_session = 1",
> + ($anonymous_condition ? ' AND ' : '');
> + $anonymous_condition = " WHERE $anonymous_condition"
> + if $anonymous_condition;
> +
> + my $count_statement = q{SELECT count(*) FROM session_table%s};
> + my $anonymous_count_statement = q{SELECT count(*) FROM
> session_table%s};
> + my $statement = q{DELETE FROM session_table%s};
> + my $anonymous_statement = q{DELETE FROM session_table%s};
> +
> + unless ($sth = SDM::do_query($count_statement, $condition)) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to count old session for
> robot %s', $robot);
> + return undef;
> + }
> +
> + my $total = $sth->fetchrow;
> + if ($total == 0) {
> + Sympa::Log::Syslog::do_log('debug3', 'no sessions to expire');
> + }else{
> + unless ($sth = SDM::do_query($statement, $condition)) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to purge old sessions
> for robot %s',
> + $robot);
> + return undef;
> + }
> + }
> + unless ($sth = SDM::do_query($anonymous_count_statement,
> + $anonymous_condition)) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to count anonymous sessions
> for robot %s',
> + $robot);
> + return undef;
> + }
> + my $anonymous_total = $sth->fetchrow;
> + if ($anonymous_total == 0) {
> + Sympa::Log::Syslog::do_log('debug3', 'no anonymous sessions to
> expire');
> + return $total ;
> + }
> + unless ($sth = SDM::do_query($anonymous_statement,
> + $anonymous_condition)) {
> + Sympa::Log::Syslog::do_log('err', 'Unable to purge anonymous sessions
> for robot %s',
> + $robot);
> + return undef;
> + }
> + return $total+$anonymous_total;
> +}
> +
> +
> +## remove old one_time_ticket from a particular robot or from all robots.
> delay is a parameter in seconds
> +##
> +sub purge_old_tickets {
> + Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> + my $robot = Robot::clean_robot(shift, 1);
> +
> + my $delay = tools::duration_conv(Site->one_time_ticket_table_ttl);
> + unless ($delay) {
> + Sympa::Log::Syslog::do_log('debug3', 'exit with delay null');
> + return;
> + }
> +
> + my @tickets ;
> + my $sth;
> +
> + my $condition = '';
> + $condition = sprintf '%d > date_one_time_ticket', time - $delay
> + if $delay;
> + $condition .= sprintf '%srobot_one_time_ticket = %s',
> + ($condition ? ' AND ' : ''), SDM::quote($robot->name)
> + if ref $robot eq 'Robot';
> + $condition = " WHERE $condition"
> + if $condition;
> +
> + unless ($sth = SDM::do_query(
> + q{SELECT count(*) FROM one_time_ticket_table%s},
> + $condition
> + )) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to count old one time tickets for robot %s', $robot);
> + return undef;
> + }
> +
> + my $total = $sth->fetchrow;
> + if ($total == 0) {
> + Sympa::Log::Syslog::do_log('debug3', 'no tickets to expire');
> + }else{
> + unless ($sth = SDM::do_query(
> + q{DELETE FROM one_time_ticket_table%s},
> + $condition
> + )) {
> + Sympa::Log::Syslog::do_log('err',
> + 'Unable to delete expired one time tickets for robot %s',
> + $robot);
> + return undef;
> + }
> + }
> + return $total;
> +}
> +
> +# list sessions for $robot where last access is newer then $delay. List is
> limited to connected users if $connected_only
> +sub list_sessions {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s)', @_);
> + my $delay = shift;
> + my $robot = Robot::clean_robot(shift, 1);
> + my $connected_only = shift;
> +
> + my @sessions ;
> + my $sth;
> + my $time = time;
> +
> + my $condition = '';
> + $condition = sprintf 'robot_session = %s', SDM::quote($robot->name)
> + if ref $robot eq 'Robot';
> + $condition .= sprintf '%s%d < date_session',
> + ($condition ? ' AND ' : ''), $time - $delay
> + if $delay;
> + $condition .= sprintf "%semail_session <> 'nobody'",
> + ($condition ? ' AND ' : '')
> + if $connected_only eq 'on';
> + $condition .= sprintf "%sprev_id_session IS NOT NULL",
> + ($condition ? ' AND ' : '');
> + $condition = " WHERE $condition"
> + if $condition;
> +
> + unless ($sth = SDM::do_query(
> + q{SELECT remote_addr_session, email_session, robot_session,
> + date_session, start_date_session, hit_session
> + FROM session_table%s},
> + $condition
> + )) {
> + Sympa::Log::Syslog::do_log('err','Unable to get the list of sessions
> for robot %s',
> + $robot);
> + return undef;
> + }
> +
> + while (my $session = ($sth->fetchrow_hashref('NAME_lc'))) {
> + $session->{'formated_date'} =
> + Language::gettext_strftime("%d %b %y %H:%M",
> localtime($session->{'date_session'}));
> + $session->{'formated_start_date'} =
> + Language::gettext_strftime ("%d %b %y %H:%M",
> localtime($session->{'start_date_session'}));
> +
> + push @sessions, $session;
> + }
> +
> + return \@sessions;
> +}
> +
> +###############################
> +# Subroutines to read cookies #
> +###############################
> +
> +## Generic subroutine to get a cookie value
> +sub get_session_cookie {
> + my $http_cookie = shift;
> +
> + if ($http_cookie =~/\S+/g) {
> + my %cookies = parse CGI::Cookie($http_cookie);
> + foreach (keys %cookies) {
> + my $cookie = $cookies{$_};
> + next unless ($cookie->name eq 'sympa_session');
> + return ($cookie->value);
> + }
> + }
> +
> + return (undef);
> +}
> +
> +
> +## Generic subroutine to set a cookie
> +## Set user $email cookie, ckecksum use $secret, expire=(now|session|#sec)
> domain=(localhost|<a domain>)
> +sub set_cookie {
> + Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> + my ($self, $http_domain, $expires,$use_ssl) = @_ ;
> +
> + my $expiration;
> + if ($expires =~ /now/i) {
> + ## 10 years ago
> + $expiration = '-10y';
> + }else{
> + $expiration = '+'.$expires.'m';
> + }
> +
> + if ($http_domain eq 'localhost') {
> + $http_domain="";
> + }
> +
> + my $value = encrypt_session_id($self->{'id_session'});
> +
> + my $cookie;
> + if ($expires =~ /session/i) {
> + $cookie = new CGI::Cookie (-name => 'sympa_session',
> + -value => $value,
> + -domain => $http_domain,
> + -path => '/',
> + -secure => $use_ssl,
> + -httponly => 1
> + );
> + }else {
> + $cookie = new CGI::Cookie (-name => 'sympa_session',
> + -value => $value,
> + -expires => $expiration,
> + -domain => $http_domain,
> + -path => '/',
> + -secure => $use_ssl,
> + -httponly => 1
> + );
> + }
> +
> + ## Send cookie to the client
> + printf "Set-Cookie: %s\n", $cookie->as_string;
> + return 1;
> +}
> +
> +# Build an HTTP cookie value to be sent to a SOAP client
> +sub soap_cookie2 {
> + my ($session_id, $http_domain, $expire) = @_;
> + my $cookie;
> + my $value;
> +
> + # WARNING : to check the cookie the SOAP services does not gives
> + # all the cookie, only it's value so we need ':'
> + $value = encrypt_session_id($session_id);
> +
> + ## With set-cookie2 max-age of 0 means removing the cookie
> + ## Maximum cookie lifetime is the session
> + $expire ||= 600; ## 10 minutes
> +
> + if ($http_domain eq 'localhost') {
> + $cookie = CGI::Cookie->new(
> + -name => 'sympa_session',
> + -value => $value,
> + -path => '/',
> + );
> + $cookie->max_age(time + $expire); # needs CGI >= 3.51.
> + } else {
> + $cookie = CGI::Cookie->new(
> + -name => 'sympa_session',
> + -value => $value,
> + -domain => $http_domain,
> + -path => '/',
> + );
> + $cookie->max_age(time + $expire); # needs CGI >= 3.51.
> + }
> +
> + ## Return the cookie value
> + return $cookie->as_string;
> +}
> +
> +sub get_random {
> + Sympa::Log::Syslog::do_log('debug3', '()');
> + ## Concatenates 2 integers for a better entropy
> + my $random = int(rand(10**7)).int(rand(10**7));
> + $random =~ s/^0(\.|\,)//;
> + return ($random)
> +}
> +
> +## Return the session object content, as a hashref
> +sub as_hashref {
> + my $self = shift;
> + my $data;
> +
> + foreach my $key (keys %{$self}) {
> + if ($key eq 'robot') {
> + $data->{$key} = $self->{'robot'}->name;
> + } else {
> + $data->{$key} = $self->{$key};
> + }
> + }
> +
> + return $data;
> +}
> +
> +## Return 1 if the Session object corresponds to an anonymous session.
> +sub is_anonymous {
> + my $self = shift;
> + if($self->{'email'} eq 'nobody' || $self->{'email'} eq '') {
> + return 1;
> + }else{
> + return 0;
> + }
> +}
> +
> +## Generate cookie from session ID.
> +sub encrypt_session_id {
> + my $id_session = shift;
> +
> + return $id_session unless Site->cookie;
> + my $cipher = tools::ciphersaber_installed();
> + return $id_session unless $cipher;
> +
> + my $id_session_bin =
> + pack 'nN', ($id_session >> 32), $id_session % (1 << 32);
> + my $cookie_bin = $cipher->encrypt($id_session_bin);
> + return sprintf '%*v02x', '', $cookie_bin;
> +}
> +
> +## Get session ID from cookie.
> +sub decrypt_session_id {
> + my $cookie = shift;
> +
> + return $cookie unless Site->cookie;
> + my $cipher = tools::ciphersaber_installed();
> + return $cookie unless $cipher;
> +
> + return undef unless $cookie =~ /\A[0-9a-f]+\z/;
> + my $cookie_bin = $cookie;
> + $cookie_bin =~ s/([0-9a-f]{2})/sprintf '%c', hex("0x$1")/eg;
> + my ($id_session_hi, $id_session_lo) =
> + unpack 'nN', $cipher->decrypt($cookie_bin);
> +
> + return ($id_session_hi << 32) + $id_session_lo;
> +}
> +
> +## Get unique ID
> +sub get_id {
> + my $self = shift;
> + return '' unless $self->{'id_session'} and $self->{'robot'};
> + return sprintf '%s@%s', $self->{'id_session'}, $self->{'robot'}->name;
> +}
> +
> +1;
> Copied: trunk/src/lib/cookielib.pm (from rev 10083,
> trunk/wwsympa/cookielib.pm) (0 => 10085)
> --- trunk/src/lib/cookielib.pm (rev 0)
> +++ trunk/src/lib/cookielib.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,206 @@
> +# cookielib.pm - This module includes functions managing HTTP cookies in
> Sympa
> +# RCS Identication ; $Revision$ ; $Date$
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package cookielib;
> +
> +use strict "vars";
> +
> +use Digest::MD5;
> +use POSIX;
> +use CGI::Cookie;
> +
> +use Log;
> +
> +## Generic subroutine to set a cookie
> +sub generic_set_cookie {
> + my %param = @_;
> +
> + my %cookie_param;
> + foreach my $p ('name','value','expires','domain','path') {
> + $cookie_param{'-'.$p} = $param{$p}; ## CGI::Cookie expects -param =>
> value
> + }
> +
> + if ($cookie_param{'-domain'} eq 'localhost') {
> + $cookie_param{'-domain'} = '';
> + }
> +
> + my $cookie = new CGI::Cookie(%cookie_param);
> +
> + ## Send cookie to the client
> + printf "Set-Cookie: %s\n", $cookie->as_string;
> +
> + return 1;
> +}
> +
> +
> +
> +# Sets an HTTP cookie to be sent to a SOAP client
> +# OBSOLETED: Use SympaSession::soap_cookie2().
> +sub set_cookie_soap {
> + my ($session_id,$http_domain,$expire) = @_ ;
> + my $cookie;
> + my $value;
> +
> + # WARNING : to check the cookie the SOAP services does not gives
> + # all the cookie, only it's value so we need ':'
> + $value = $session_id;
> +
> + ## With set-cookie2 max-age of 0 means removing the cookie
> + ## Maximum cookie lifetime is the session
> + $expire ||= 600; ## 10 minutes
> +
> + if ($http_domain eq 'localhost') {
> + $cookie = sprintf "%s=%s; Path=/; Max-Age=%s", 'sympa_session',
> $value, $expire;
> + }else {
> + $cookie = sprintf "%s=%s; Domain=%s; Path=/; Max-Age=%s",
> 'sympa_session', $value, $http_domain, $expire;;
> + }
> +
> + ## Return the cookie value
> + return $cookie;
> +}
> +
> +## returns Message Authentication Check code
> +sub get_mac {
> + my $email = shift ;
> + my $secret = shift ;
> + Sympa::Log::Syslog::do_log('debug3', "get_mac($email, $secret)");
> +
> + unless ($secret) {
> + Sympa::Log::Syslog::do_log('err', 'get_mac : failure missing
> server secret for cookie MD5 digest');
> + return undef;
> + }
> + unless ($email) {
> + Sympa::Log::Syslog::do_log('err', 'get_mac : failure missing
> email adresse or cookie MD5 digest');
> + return undef;
> + }
> +
> +
> +
> + my $md5 = new Digest::MD5;
> +
> + $md5->reset;
> + $md5->add($email.$secret);
> +
> + return substr( unpack("H*", $md5->digest) , -8 );
> +
> +}
> +
> +sub set_cookie_extern {
> + my ($secret,$http_domain,%alt_emails) = @_ ;
> + my $expiration;
> + my $cookie;
> + my $value;
> +
> + my @mails ;
> + foreach my $mail (keys %alt_emails) {
> + my $string = $mail.':'.$alt_emails{$mail};
> + push(@mails,$string);
> + }
> + my $emails = join(',',@mails);
> +
> + $value = sprintf '%s&%s',$emails,&get_mac($emails,$secret);
> +
> + if ($http_domain eq 'localhost') {
> + $http_domain="";
> + }
> +
> + $cookie = new CGI::Cookie (-name => 'sympa_altemails',
> + -value => $value,
> + -expires => '+1y',
> + -domain => $http_domain,
> + -path => '/'
> + );
> + ## Send cookie to the client
> + printf "Set-Cookie: %s\n", $cookie->as_string;
> + #Sympa::Log::Syslog::do_log('notice',"set_cookie_extern :
> %s",$cookie->as_string);
> + return 1;
> +}
> +
> +
> +
> +
> +###############################
> +# Subroutines to read cookies #
> +###############################
> +
> +## Generic subroutine to get a cookie value
> +sub generic_get_cookie {
> + my $http_cookie = shift;
> + my $cookie_name = shift;
> +
> + if ($http_cookie =~/\S+/g) {
> + my %cookies = parse CGI::Cookie($http_cookie);
> + foreach (keys %cookies) {
> + my $cookie = $cookies{$_};
> + next unless ($cookie->name eq $cookie_name);
> + return ($cookie->value);
> + }
> + }
> + return (undef);
> +}
> +
> +## Returns user information extracted from the cookie
> +sub check_cookie {
> + my $http_cookie = shift;
> + my $secret = shift;
> +
> + my $user = &generic_get_cookie($http_cookie, 'sympauser');
> +
> + my @values = split /:/, $user;
> + if ($#values >= 1) {
> + my ($email, $mac, $auth) = @values;
> + $auth ||= 'classic';
> +
> + ## Check the MAC
> + if (&get_mac($email,$secret) eq $mac) {
> + return ($email, $auth);
> + }
> + }
> +
> + return undef;
> +}
> +
> +sub check_cookie_extern {
> + my ($http_cookie,$secret,$user_email) = @_;
> +
> + my $extern_value = &generic_get_cookie($http_cookie,
> 'sympa_altemails');
> +
> + if ($extern_value =~ /^(\S+)&(\w+)$/) {
> + return undef unless (&get_mac($1,$secret) eq $2) ;
> +
> + my %alt_emails ;
> + foreach my $element (split(/,/,$1)){
> + my @array = split(/:/,$element);
> + $alt_emails{$array[0]} = $array[1];
> + }
> +
> + my $e = lc($user_email);
> + unless ($alt_emails{$e}) {
> + return undef;
> + }
> + return (\%alt_emails);
> + }
> + return undef
> +}
> +
> +1;
> +
> +
> +
> Copied: trunk/src/lib/wwslib.pm (from rev 10083, trunk/wwsympa/wwslib.pm)
> (0 => 10085)
> --- trunk/src/lib/wwslib.pm (rev 0)
> +++ trunk/src/lib/wwslib.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -0,0 +1,303 @@
> +# wwslib.pm - This module includes functions used by wwsympa.fcgi
> +# RCS Identication ; $Revision$ ; $Date$
> +#
> +# Sympa - SYsteme de Multi-Postage Automatique
> +# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> +# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> +#
> +# This program is free software; you can redistribute it and/or modify
> +# it under the terms of the GNU General Public License as published by
> +# the Free Software Foundation; either version 2 of the License, or
> +# (at your option) any later version.
> +#
> +# This program is distributed in the hope that it will be useful,
> +# but WITHOUT ANY WARRANTY; without even the implied warranty of
> +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> +# GNU General Public License for more details.
> +#
> +# You should have received a copy of the GNU General Public License
> +# along with this program. If not, see <http://www.gnu.org/licenses/>.
> +
> +package wwslib;
> +
> +use Log;
> +use Conf;
> +use Sympa::Constants;
> +
> +## No longer used: Use List->get_option_title().
> +%reception_mode = ('mail' => {'gettext_id' => 'standard (direct
> reception)'},
> + 'digest' => {'gettext_id' => 'digest MIME format'},
> + 'digestplain' => {'gettext_id' => 'digest plain text
> format'},
> + 'summary' => {'gettext_id' => 'summary mode'},
> + 'notice' => {'gettext_id' => 'notice mode'},
> + 'txt' => {'gettext_id' => 'text-only mode'},
> + 'html'=> {'gettext_id' => 'html-only mode'},
> + 'urlize' => {'gettext_id' => 'urlize mode'},
> + 'nomail' => {'gettext_id' => 'no mail (useful for
> vacations)'},
> + 'not_me' => {'gettext_id' => 'you do not receive your own
> posts'}
> + );
> +
> +## Cookie expiration periods with corresponding entry in NLS
> +%cookie_period = (0 => {'gettext_id' => "session"},
> + 10 => {'gettext_id' => "10 minutes"},
> + 30 => {'gettext_id' => "30 minutes"},
> + 60 => {'gettext_id' => "1 hour"},
> + 360 => {'gettext_id' => "6 hours"},
> + 1440 => {'gettext_id' => "1 day"},
> + 10800 => {'gettext_id' => "1 week"},
> + 43200 => {'gettext_id' => "30 days"});
> +
> +## No longer used: Use List->get_option_title().
> +%visibility_mode = ('noconceal' => {'gettext_id' => "listed in the list
> review page"},
> + 'conceal' => {'gettext_id' => "concealed"}
> + );
> +
> +## Filenames with corresponding entry in NLS set 15
> +%filenames = ('welcome.tt2' => {'gettext_id' => "welcome
> message"},
> + 'bye.tt2' => {'gettext_id' => "unsubscribe
> message"},
> + 'removed.tt2' => {'gettext_id' => "deletion
> message"},
> + 'message.footer' => {'gettext_id' => "message footer"},
> + 'message.header' => {'gettext_id' => "message header"},
> + 'remind.tt2' => {'gettext_id' => "remind message"},
> + 'reject.tt2' => {'gettext_id' => "editor rejection
> message"},
> + 'invite.tt2' => {'gettext_id' => "subscribing
> invitation message"},
> + 'helpfile.tt2' => {'gettext_id' => "help file"},
> + 'lists.tt2' => {'gettext_id' => "directory of
> lists"},
> + 'global_remind.tt2' => {'gettext_id' => "global remind
> message"},
> + 'summary.tt2' => {'gettext_id' => "summary
> message"},
> + 'info' => {'gettext_id' => "list
> description"},
> + 'homepage' => {'gettext_id' => "list homepage"},
> + 'create_list_request.tt2' => {'gettext_id' => "list creation
> request message"},
> + 'list_created.tt2' => {'gettext_id' => "list creation
> notification message"},
> + 'your_infected_msg.tt2' => {'gettext_id' => "virus infection
> message"},
> + 'list_aliases.tt2' => {'gettext_id' => "list aliases
> template"}
> + );
> +
> +%task_flavours = (
> + 'daily' => {'gettext_id' => 'daily' },
> + 'monthly' => {'gettext_id' => 'monthly' },
> + 'weekly' => {'gettext_id' => 'weekly' },
> + );
> +
> +## Defined in RFC 1893
> +%bounce_status = ('1.0' => 'Other address status',
> + '1.1' => 'Bad destination mailbox address',
> + '1.2' => 'Bad destination system address',
> + '1.3' => 'Bad destination mailbox address syntax',
> + '1.4' => 'Destination mailbox address ambiguous',
> + '1.5' => 'Destination mailbox address valid',
> + '1.6' => 'Mailbox has moved',
> + '1.7' => 'Bad sender\'s mailbox address syntax',
> + '1.8' => 'Bad sender\'s system address',
> + '2.0' => 'Other or undefined mailbox status',
> + '2.1' => 'Mailbox disabled, not accepting messages',
> + '2.2' => 'Mailbox full',
> + '2.3' => 'Message length exceeds administrative limit',
> + '2.4' => 'Mailing list expansion problem',
> + '3.0' => 'Other or undefined mail system status',
> + '3.1' => 'Mail system full',
> + '3.2' => 'System not accepting network messages',
> + '3.3' => 'System not capable of selected features',
> + '3.4' => 'Message too big for system',
> + '4.0' => 'Other or undefined network or routing status',
> + '4.1' => 'No answer from host',
> + '4.2' => 'Bad connection',
> + '4.3' => 'Routing server failure',
> + '4.4' => 'Unable to route',
> + '4.5' => 'Network congestion',
> + '4.6' => 'Routing loop detected',
> + '4.7' => 'Delivery time expired',
> + '5.0' => 'Other or undefined protocol status',
> + '5.1' => 'Invalid command',
> + '5.2' => 'Syntax error',
> + '5.3' => 'Too many recipients',
> + '5.4' => 'Invalid command arguments',
> + '5.5' => 'Wrong protocol version',
> + '6.0' => 'Other or undefined media error',
> + '6.1' => 'Media not supported',
> + '6.2' => 'Conversion required and prohibited',
> + '6.3' => 'Conversion required but not supported',
> + '6.4' => 'Conversion with loss performed',
> + '6.5' => 'Conversion failed',
> + '7.0' => 'Other or undefined security status',
> + '7.1' => 'Delivery not authorized, message refused',
> + '7.2' => 'Mailing list expansion prohibited',
> + '7.3' => 'Security conversion required but not possible',
> + '7.4' => 'Security features not supported',
> + '7.5' => 'Cryptographic failure',
> + '7.6' => 'Cryptographic algorithm not supported',
> + '7.7' => 'Message integrity failure');
> +
> +
> +
> +## if Crypt::CipherSaber installed store the cipher object
> +my $cipher;
> +
> +## Load WWSympa configuration file
> +##sub load_config
> +## MOVED: use Conf::load_wwsconf().
> +
> +## Load HTTPD MIME Types
> +sub load_mime_types {
> + my $types = {};
> +
> + @localisation = ('/etc/mime.types',
> '/usr/local/apache/conf/mime.types',
> + '/etc/httpd/conf/mime.types',Site->etc.'/mime.types');
> +
> + foreach my $loc (@localisation) {
> + next unless (-r $loc);
> +
> + unless(open (CONF, $loc)) {
> + Sympa::Log::Syslog::do_log('err',"load_mime_types: unable to open
> $loc");
> + return undef;
> + }
> + }
> +
> + while (<CONF>) {
> + next if /^\s*\#/;
> +
> + if (/^(\S+)\s+(.+)\s*$/i) {
> + my ($k, $v) = ($1, $2);
> +
> + my @extensions = split / /, $v;
> +
> + ## provides file extention, given the content-type
> + if ($#extensions >= 0) {
> + $types->{$k} = $extensions[0];
> + }
> +
> + foreach my $ext (@extensions) {
> + $types->{$ext} = $k;
> + }
> + next;
> + }
> + }
> +
> + close FILE;
> + return $types;
> +}
> +
> +## Returns user information extracted from the cookie
> +sub get_email_from_cookie {
> +# Sympa::Log::Syslog::do_log('debug', 'get_email_from_cookie');
> + my $cookie = shift;
> + my $secret = shift;
> +
> + my ($email, $auth) ;
> +
> + # Sympa::Log::Syslog::do_log('info',
> "get_email_from_cookie($cookie,$secret)");
> +
> + unless (defined $secret) {
> +
> &report::reject_report_web('intern','cookie_error',{},'','','',$robot);
> + Sympa::Log::Syslog::do_log('info', 'parameter cookie undefined,
> authentication failure');
> + }
> +
> + unless ($cookie) {
> +
> &report::reject_report_web('intern','cookie_error',$cookie,'get_email_from_cookie','','',$robot);
> + Sympa::Log::Syslog::do_log('info', ' cookie undefined, authentication
> failure');
> + }
> +
> + ($email, $auth) = &cookielib::check_cookie ($cookie, $secret);
> + unless ( $email) {
> + &report::reject_report_web('user','auth_failed',{},'');
> + Sympa::Log::Syslog::do_log('info', 'get_email_from_cookie: auth
> failed for user %s', $email);
> + return undef;
> + }
> +
> + return ($email, $auth);
> +}
> +
> +sub new_passwd {
> +
> + my $passwd;
> + my $nbchar = int(rand 5) + 6;
> + foreach my $i (0..$nbchar) {
> + $passwd .= chr(int(rand 26) + ord('a'));
> + }
> +
> + return 'init'.$passwd;
> +}
> +
> +## Basic check of an email address
> +sub valid_email {
> + my $email = shift;
> +
> + $email =~ /^([\w\-\_\.\/\+\=]+|\".*\")\@[\w\-]+(\.[\w\-]+)+$/;
> +}
> +
> +sub init_passwd {
> + my ($email, $data) = @_;
> +
> + my ($passwd, $user);
> +
> + if (User::is_global_user($email)) {
> + $user = User::get_global_user($email);
> +
> + $passwd = $user->{'password'};
> +
> + unless ($passwd) {
> + $passwd = &new_passwd();
> +
> + unless ( User::update_global_user($email,
> + {'password' => $passwd,
> + 'lang' => $user->{'lang'} ||
> $data->{'lang'}} )) {
> +
> &report::reject_report_web('intern','update_user_db_failed',{'user'=>$email},'','',$email,$robot);
> + Sympa::Log::Syslog::do_log('info','init_passwd: update
> failed');
> + return undef;
> + }
> + }
> + }else {
> + $passwd = &new_passwd();
> + unless ( User::add_global_user({'email' => $email,
> + 'password' => $passwd,
> + 'lang' => $data->{'lang'},
> + 'gecos' => $data->{'gecos'}})) {
> +
> &report::reject_report_web('intern','add_user_db_failed',{'user'=>$email},'','',$email,$robot);
> + Sympa::Log::Syslog::do_log('info','init_passwd: add failed');
> + return undef;
> + }
> + }
> +
> + return 1;
> +}
> +
> +sub get_my_url {
> +
> +
> + my $return_url;
> +
> + ## Mod_ssl sets SSL_PROTOCOL ; apache-ssl sets SSL_PROTOCOL_VERSION
> + if ($ENV{'HTTPS'} eq 'on') {
> + $return_url = 'https';
> + }else{
> + $return_url = 'http';
> + }
> +
> + $return_url .= '://'.&main::get_header_field('HTTP_HOST');
> + $return_url .= ':'.$ENV{'SERVER_PORT'} unless (($ENV{'SERVER_PORT'} eq
> '80')||($ENV{'SERVER_PORT'} eq '443'));
> + $return_url .= $ENV{'REQUEST_URI'};
> + return ($return_url);
> +}
> +
> +# Uploade source file to the destination on the server
> +sub upload_file_to_server {
> + my $param = shift;
> + Sympa::Log::Syslog::do_log('debug',"Uploading file from field %s to
> destination %s",$param->{'file_field'},$param->{'destination'});
> + my $fh;
> + unless ($fh = $param->{'query'}->upload($param->{'file_field'})) {
> + Sympa::Log::Syslog::do_log('debug',"Cannot upload file from field
> $param->{'file_field'}");
> + return undef;
> + }
> +
> + unless (open FILE, ">:bytes", $param->{'destination'}) {
> + Sympa::Log::Syslog::do_log('debug',"Cannot open file
> $param->{'destination'} : $!");
> + return undef;
> + }
> + while (<$fh>) {
> + print FILE;
> + }
> + close FILE;
> + return 1;
> +}
> +
> +1;
> Deleted: trunk/wwsympa/Auth.pm (10084 => 10085)
> --- trunk/wwsympa/Auth.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/Auth.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,575 +0,0 @@
> -# Auth.pm - This module provides web authentication functions
> -# RCS Identication ; $Revision$ ; $Date$
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package Auth;
> -
> -use Digest::MD5;
> -
> -use Language qw(gettext_strftime);
> -
> -#use Log;
> -#use Conf;
> -#use List; # not used
> -use report;
> -
> -#use SDM;
> -
> -## return the password finger print (this proc allow futur replacement of
> md5 by sha1 or ....)
> -sub password_fingerprint {
> -
> - Sympa::Log::Syslog::do_log('debug', 'Auth::password_fingerprint');
> -
> - my $pwd = shift;
> - if (Site->password_case eq 'insensitive') {
> - return &tools::md5_fingerprint(lc($pwd));
> - } else {
> - return &tools::md5_fingerprint($pwd);
> - }
> -}
> -
> -## authentication : via email or uid
> -sub check_auth {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, ...)', @_);
> - my $robot = Robot::clean_robot(shift);
> - my $auth = shift; ## User email or UID
> - my $pwd = shift; ## Password
> -
> - my ($canonic, $user);
> -
> - if (&tools::valid_email($auth)) {
> - return authentication($robot, $auth, $pwd);
> - } else {
> - ## This is an UID
> - foreach my $ldap (@{Site->auth_services->{$robot->domain}}) {
> -
> - # only ldap service are to be applied here
> - next unless ($ldap->{'auth_type'} eq 'ldap');
> -
> - $canonic =
> - ldap_authentication($robot, $ldap, $auth, $pwd, 'uid_filter');
> - last if ($canonic); ## Stop at first match
> - }
> - if ($canonic) {
> -
> - unless ($user = User::get_global_user($canonic)) {
> - $user = {'email' => $canonic};
> - }
> - return {
> - 'user' => $user,
> - 'auth' => 'ldap',
> - 'alt_emails' => {$canonic => 'ldap'}
> - };
> -
> - } else {
> - &report::reject_report_web('user', 'incorrect_passwd', {})
> - unless ($ENV{'SYMPA_SOAP'});
> - Sympa::Log::Syslog::do_log('err', "Incorrect LDAP password");
> - return undef;
> - }
> - }
> -}
> -
> -## This subroutine if Sympa may use its native authentication for a given
> user
> -## It might not if no user_table paragraph is found in auth.conf or if the
> regexp or
> -## negative_regexp exclude this user
> -## IN : robot, user email
> -## OUT : boolean
> -sub may_use_sympa_native_auth {
> - my $robot = Robot::clean_robot(shift);
> - my $user_email = shift;
> -
> - my $ok = 0;
> - ## check each auth.conf paragrpah
> - foreach my $auth_service (@{Site->auth_services->{$robot->domain}}) {
> - next unless ($auth_service->{'auth_type'} eq 'user_table');
> -
> - next
> - if ($auth_service->{'regexp'} &&
> - ($user_email !~ /$auth_service->{'regexp'}/i));
> - next
> - if ($auth_service->{'negative_regexp'} &&
> - ($user_email =~ /$auth_service->{'negative_regexp'}/i));
> -
> - $ok = 1;
> - last;
> - }
> -
> - return $ok;
> -}
> -
> -sub authentication {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, ...)', @_);
> - my $robot = Robot::clean_robot(shift);
> - my $email = shift;
> - my $pwd = shift;
> - my ($user, $canonic);
> -
> - unless ($user = User::get_global_user($email)) {
> - $user = {'email' => $email};
> - }
> - unless ($user->{'password'}) {
> - $user->{'password'} = '';
> - }
> -
> - if ($user->{'wrong_login_count'} > $robot->max_wrong_password) {
> -
> - # too many wrong login attemp
> - User::update_global_user($email,
> - {wrong_login_count => $user->{'wrong_login_count'} + 1});
> - &report::reject_report_web('user', 'too_many_wrong_login', {})
> - unless ($ENV{'SYMPA_SOAP'});
> - Sympa::Log::Syslog::do_log('err',
> - 'login is blocked : too many wrong password submission for %s',
> - $email);
> - return undef;
> - }
> - foreach my $auth_service (@{Site->auth_services->{$robot->domain}}) {
> - next if ($auth_service->{'auth_type'} eq 'authentication_info_url');
> - next if ($email !~ /$auth_service->{'regexp'}/i);
> - next
> - if (($email =~ /$auth_service->{'negative_regexp'}/i) &&
> - ($auth_service->{'negative_regexp'}));
> -
> - ## Only 'user_table' and 'ldap' backends will need that Sympa
> collects the user passwords
> - ## Other backends are Single Sign-On solutions
> - if ($auth_service->{'auth_type'} eq 'user_table') {
> - my $fingerprint = &password_fingerprint($pwd);
> -
> - if ($fingerprint eq $user->{'password'}) {
> - User::update_global_user($email, {wrong_login_count => 0});
> - return {
> - 'user' => $user,
> - 'auth' => 'classic',
> - 'alt_emails' => {$email => 'classic'}
> - };
> - }
> - } elsif ($auth_service->{'auth_type'} eq 'ldap') {
> - if ($canonic = ldap_authentication(
> - $robot, $auth_service, $email, $pwd, 'email_filter'
> - )
> - ) {
> - unless ($user = User::get_global_user($canonic)) {
> - $user = {'email' => $canonic};
> - }
> - User::update_global_user($canonic, {wrong_login_count => 0});
> - return {
> - 'user' => $user,
> - 'auth' => 'ldap',
> - 'alt_emails' => {$email => 'ldap'}
> - };
> - }
> - }
> - }
> -
> - # increment wrong login count.
> - User::update_global_user($email,
> - {wrong_login_count => $user->{'wrong_login_count'} + 1});
> -
> - &report::reject_report_web('user', 'incorrect_passwd', {})
> - unless ($ENV{'SYMPA_SOAP'});
> - Sympa::Log::Syslog::do_log('err', 'authentication: incorrect password
> for user %s',
> - $email);
> -
> - $param->{'init_email'} = $email;
> - $param->{'escaped_init_email'} = &tools::escape_chars($email);
> - return undef;
> -}
> -
> -sub ldap_authentication {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, ...)', @_);
> - my $robot = Robot::clean_robot(shift);
> - my $ldap = shift;
> - my $auth = shift;
> - my $pwd = shift;
> - my $whichfilter = shift;
> - my ($mesg, $host, $ldap_passwd, $ldap_anonymous);
> -
> - unless ($robot->get_etc_filename('auth.conf')) {
> - return undef;
> - }
> -
> - ## No LDAP entry is defined in auth.conf
> - if ($#{Site->auth_services->{$robot->domain}} < 0) {
> - Sympa::Log::Syslog::do_log('notice', 'Skipping empty auth.conf');
> - return undef;
> - }
> -
> - # only ldap service are to be applied here
> - return undef unless ($ldap->{'auth_type'} eq 'ldap');
> -
> - # skip ldap auth service if the an email address was provided
> - # and this email address does not match the corresponding regexp
> - return undef if ($auth =~ /@/ && $auth !~ /$ldap->{'regexp'}/i);
> -
> - my @alternative_conf = split(/,/,
> $ldap->{'alternative_email_attribute'});
> - my $attrs = $ldap->{'email_attribute'};
> - my $filter = $ldap->{'get_dn_by_uid_filter'}
> - if ($whichfilter eq 'uid_filter');
> - $filter = $ldap->{'get_dn_by_email_filter'}
> - if ($whichfilter eq 'email_filter');
> - $filter =~ s/\[sender\]/$auth/ig;
> -
> - ## bind in order to have the user's DN
> - my $param = &tools::dup_var($ldap);
> - my $ds = new LDAPSource($param);
> -
> - unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
> - Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> - $ldap->{'host'});
> - return undef;
> - }
> -
> - $mesg = $ldap_anonymous->search(
> - base => $ldap->{'suffix'},
> - filter => "$filter",
> - scope => $ldap->{'scope'},
> - timeout => $ldap->{'timeout'}
> - );
> -
> - if ($mesg->count() == 0) {
> - Sympa::Log::Syslog::do_log('notice',
> - 'No entry in the Ldap Directory Tree of %s for %s',
> - $ldap->{'host'}, $auth);
> - $ds->disconnect();
> - return undef;
> - }
> -
> - my $refhash = $mesg->as_struct();
> - my (@DN) = keys(%$refhash);
> - $ds->disconnect();
> -
> - ## bind with the DN and the pwd
> -
> - ## Duplicate structure first
> - ## Then set the bind_dn and password according to the current user
> - $param = &tools::dup_var($ldap);
> - $param->{'ldap_bind_dn'} = $DN[0];
> - $param->{'ldap_bind_password'} = $pwd;
> -
> - $ds = new LDAPSource($param);
> -
> - unless (defined $ds && ($ldap_passwd = $ds->connect())) {
> - Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> - $param->{'host'});
> - return undef;
> - }
> -
> - $mesg = $ldap_passwd->search(
> - base => $ldap->{'suffix'},
> - filter => "$filter",
> - scope => $ldap->{'scope'},
> - timeout => $ldap->{'timeout'}
> - );
> -
> - if ($mesg->count() == 0 || $mesg->code() != 0) {
> - Sympa::Log::Syslog::do_log('notice', "No entry in the LDAP Directory
> Tree of %s",
> - $ldap->{'host'});
> - $ds->disconnect();
> - return undef;
> - }
> -
> - ## To get the value of the canonic email and the alternative email
> - my (@canonic_email, @alternative);
> -
> - ## Keep previous alt emails not from LDAP source
> - my $previous = {};
> - foreach my $alt (keys %{$param->{'alt_emails'}}) {
> - $previous->{$alt} = $param->{'alt_emails'}{$alt}
> - if ($param->{'alt_emails'}{$alt} ne 'ldap');
> - }
> - $param->{'alt_emails'} = {};
> -
> - my $entry = $mesg->entry(0);
> - @canonic_email = $entry->get_value($attrs, 'alloptions' => 1);
> - foreach my $email (@canonic_email) {
> - my $e = lc($email);
> - $param->{'alt_emails'}{$e} = 'ldap' if ($e);
> - }
> -
> - foreach my $attribute_value (@alternative_conf) {
> - @alternative = $entry->get_value($attribute_value, 'alloptions' => 1);
> - foreach my $alter (@alternative) {
> - my $a = lc($alter);
> - $param->{'alt_emails'}{$a} = 'ldap' if ($a);
> - }
> - }
> -
> - ## Restore previous emails
> - foreach my $alt (keys %{$previous}) {
> - $param->{'alt_emails'}{$alt} = $previous->{$alt};
> - }
> -
> - $ds->disconnect() or Sympa::Log::Syslog::do_log('notice', "unable to
> unbind");
> - Sympa::Log::Syslog::do_log('debug3', "canonic: $canonic_email[0]");
> - ## If the identifier provided was a valid email, return the provided
> email.
> - ## Otherwise, return the canonical email guessed after the login.
> - if (&tools::valid_email($auth) && !$robot->ldap_force_canonical_email)
> {
> - return ($auth);
> - } else {
> - return lc($canonic_email[0]);
> - }
> -}
> -
> -# fetch user email using his cas net_id and the paragrapah number in
> auth.conf
> -## NOTE: This might be moved to Robot package.
> -sub get_email_by_net_id {
> - my $robot = Robot::clean_robot(shift);
> - my $auth_id = shift;
> - my $attributes = shift;
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, uid=%s)',
> - $robot, $auth_id, $attributes->{'uid'});
> -
> - if (defined Site->auth_services->{$robot->domain}[$auth_id]
> - {'internal_email_by_netid'}) {
> - my $sso_config = @{Site->auth_services->{$robot->domain}}[$auth_id];
> - my $netid_cookie = $sso_config->{'netid_http_header'};
> -
> - $netid_cookie =~ s/(\w+)/$attributes->{$1}/ig;
> -
> - $email =
> - $robot->get_netidtoemail_db($netid_cookie,
> - Site->auth_services->{$robot->domain}[$auth_id]{'service_id'});
> -
> - return $email;
> - }
> -
> - my $ldap = @{Site->auth_services->{$robot->domain}}[$auth_id];
> -
> - my $param = &tools::dup_var($ldap);
> - my $ds = new LDAPSource($param);
> - my $ldap_anonymous;
> -
> - unless (defined $ds && ($ldap_anonymous = $ds->connect())) {
> - Sympa::Log::Syslog::do_log('err', "Unable to connect to the LDAP
> server '%s'",
> - $ldap->{'ldap_host'});
> - return undef;
> - }
> -
> - my $filter = $ldap->{'ldap_get_email_by_uid_filter'};
> - $filter =~ s/\[([\w-]+)\]/$attributes->{$1}/ig;
> -
> - # my @alternative_conf =
> split(/,/,$ldap->{'alternative_email_attribute'});
> -
> - my $emails = $ldap_anonymous->search(
> - base => $ldap->{'ldap_suffix'},
> - filter => $filter,
> - scope => $ldap->{'ldap_scope'},
> - timeout => $ldap->{'ldap_timeout'},
> - attrs => [$ldap->{'ldap_email_attribute'}],
> - );
> - my $count = $emails->count();
> -
> - if ($emails->count() == 0) {
> - Sympa::Log::Syslog::do_log('notice', "No entry in the LDAP Directory
> Tree of %s",
> - $host);
> - $ds->disconnect();
> - return undef;
> - }
> -
> - $ds->disconnect();
> -
> - ## return only the first attribute
> - my @results = $emails->entries;
> - foreach my $result (@results) {
> - return (lc($result->get_value($ldap->{'ldap_email_attribute'})));
> - }
> -
> -}
> -
> -# check trusted_application_name et trusted_application_password : return
> 1 or undef;
> -sub remote_app_check_password {
> - my $trusted_application_name = shift;
> - my $password = shift;
> - my $robot = Robot::clean_robot(shift);
> - Sympa::Log::Syslog::do_log('debug2', '(%s, ..., %s)',
> $trusted_application_name, $robot);
> -
> - my $md5 = &tools::md5_fingerprint($password);
> -
> - my $vars;
> -
> - # seach entry for trusted_application in Conf
> - my @trusted_apps;
> -
> - # select trusted_apps from robot context or sympa context
> - @trusted_apps = @{$robot->trusted_applications};
> -
> - foreach my $application (@trusted_apps) {
> -
> - if (lc($application->{'name'}) eq lc($trusted_application_name)) {
> - if ($md5 eq $application->{'md5password'}) {
> -
> -# Sympa::Log::Syslog::do_log('debug', 'Auth::remote_app_check_password :
> authentication succeed for %s',$application->{'name'});
> - my %proxy_for_vars;
> - foreach my $varname (@{$application->{'proxy_for_variables'}})
> - {
> - $proxy_for_vars{$varname} = 1;
> - }
> - return (\%proxy_for_vars);
> - } else {
> - Sympa::Log::Syslog::do_log('info',
> - 'Auth::remote_app_check_password: bad password from %s',
> - $trusted_application_name);
> - return undef;
> - }
> - }
> - }
> -
> - # no matching application found
> - Sympa::Log::Syslog::do_log('info',
> - 'Auth::remote_app-check_password: unknown application name %s',
> - $trusted_application_name);
> - return undef;
> -}
> -
> -# create new entry in one_time_ticket table using a rand as id so later
> -# access is authenticated
> -sub create_one_time_ticket {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> - my $email = shift;
> - my $robot = Robot::clean_robot(shift);
> - my $data_string = shift;
> - my $remote_addr = shift;
> - ## Value may be 'mail' if the IP address is not known
> -
> - my $ticket = &SympaSession::get_random();
> -
> - my $date = time;
> - my $sth;
> -
> - unless (
> - SDM::do_prepared_query(
> - q{INSERT INTO one_time_ticket_table
> - (ticket_one_time_ticket, robot_one_time_ticket,
> - email_one_time_ticket, date_one_time_ticket, data_one_time_ticket,
> - remote_addr_one_time_ticket, status_one_time_ticket)
> - VALUES (?, ?, ?, ?, ?, ?, ?)},
> - $ticket, $robot->domain,
> - $email, time, $data_string,
> - $remote_addr, 'open'
> - )
> - ) {
> - Sympa::Log::Syslog::do_log(
> - 'err',
> - 'Unable to insert new one time ticket for user %s, robot %s in
> the database',
> - $email,
> - $robot
> - );
> - return undef;
> - }
> - return $ticket;
> -}
> -
> -# read one_time_ticket from table and remove it
> -sub get_one_time_ticket {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s)', @_);
> - my $robot = shift;
> - my $ticket_number = shift;
> - my $addr = shift;
> -
> - my $sth;
> -
> - unless (
> - $sth = SDM::do_prepared_query(
> - q{SELECT ticket_one_time_ticket AS ticket,
> - robot_one_time_ticket AS robot,
> - email_one_time_ticket AS email,
> - date_one_time_ticket AS "date",
> - data_one_time_ticket AS data,
> - remote_addr_one_time_ticket AS remote_addr,
> - status_one_time_ticket as status
> - FROM one_time_ticket_table
> - WHERE ticket_one_time_ticket = ? AND robot_one_time_ticket = ?},
> - $ticket_number, $robot->domain
> - )
> - ) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to retrieve one time ticket %s from database',
> - $ticket_number);
> - return {'result' => 'error'};
> - }
> -
> - my $ticket = $sth->fetchrow_hashref('NAME_lc');
> - $sth->finish;
> -
> - unless ($ticket) {
> - Sympa::Log::Syslog::do_log('info', 'Unable to find one time ticket
> %s', $ticket);
> - return {'result' => 'not_found'};
> - }
> -
> - my $result;
> - my $printable_date = gettext_strftime "%d %b %Y at %H:%M:%S",
> - localtime($ticket->{'date'});
> - my $lockout = $robot->one_time_ticket_lockout || 'open';
> - my $lifetime =
> - tools::duration_conv($robot->one_time_ticket_lifetime || 0);
> -
> - if ($lockout eq 'one_time' and $ticket->{'status'} ne 'open') {
> - $result = 'closed';
> - Sympa::Log::Syslog::do_log('info', 'ticket %s from %s has been used
> before (%s)',
> - $ticket_number, $ticket->{'email'}, $printable_date);
> - } elsif ($lockout eq 'remote_addr' and
> - $ticket->{'status'} ne $addr and
> - $ticket->{'status'} ne 'open') {
> - $result = 'closed';
> - Sympa::Log::Syslog::do_log('info',
> - 'ticket %s from %s refused because accessed by the other (%s)',
> - $ticket_number, $ticket->{'email'}, $printable_date);
> - } elsif ($lifetime and $ticket->{'date'} + $lifetime < time) {
> - Sympa::Log::Syslog::do_log('info', 'ticket %s from %s refused because
> expired (%s)',
> - $ticket_number, $ticket->{'email'}, $printable_date);
> - $result = 'expired';
> - } else {
> - $result = 'success';
> - }
> -
> - if ($result eq 'success') {
> - unless (
> - $sth = SDM::do_prepared_query(
> - q{UPDATE one_time_ticket_table
> - SET status_one_time_ticket = ?
> - WHERE ticket_one_time_ticket = ? AND robot_one_time_ticket = ?},
> - $addr, $ticket_number, $robot->domain
> - )
> - ) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to set one time ticket %s status to %s',
> - $ticket_number, $addr);
> - } elsif (!$sth->rows) {
> -
> - # ticket may be removed by task.
> - Sympa::Log::Syslog::do_log('info', 'Unable to find one time
> ticket %s',
> - $ticket_number);
> - return {'result' => 'not_found'};
> - }
> - }
> -
> - Sympa::Log::Syslog::do_log('debug', 'ticket : %s; result : %s',
> $ticket_number, $result);
> - return {
> - 'result' => $result,
> - 'date' => $ticket->{'date'},
> - 'email' => $ticket->{'email'},
> - 'remote_addr' => $ticket->{'remote_addr'},
> - 'robot' => $robot->domain,
> - 'data' => $ticket->{'data'},
> - 'status' => $ticket->{'status'}
> - };
> -}
> -
> -1;
> Deleted: trunk/wwsympa/Challenge.pm (10084 => 10085)
> --- trunk/wwsympa/Challenge.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/Challenge.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,135 +0,0 @@
> -# Challenge.pm - This module includes functions managing email challenges
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package Challenge;
> -
> -use strict;
> -no strict "vars";
> -
> -use Digest::MD5;
> -use POSIX;
> -use CGI::Cookie;
> -use Time::Local;
> -
> -use Log;
> -use Conf;
> -use SympaSession;
> -use SDM;
> -
> -# this structure is used to define which session attributes are stored in
> a dedicated database col where others are compiled in col 'data_session'
> -my %challenge_hard_attributes = ('id_challenge' => 1, 'date' => 1, 'robot'
> => 1,'email' => 1, 'list' => 1);
> -
> -
> -# create a challenge context and store it in challenge table
> -sub create {
> - my ($robot, $email, $context) = @_;
> -
> - Sympa::Log::Syslog::do_log('debug', 'Challenge::new(%s, %s, %s)',
> $challenge_id, $email, $robot);
> -
> - my $challenge={};
> -
> - unless ($robot) {
> - Sympa::Log::Syslog::do_log('err', 'Missing robot parameter, cannot
> create challenge object') ;
> - return undef;
> - }
> -
> - unless ($email) {
> - Sympa::Log::Syslog::do_log('err', 'Missing email parameter, cannot
> create challenge object') ;
> - return undef;
> - }
> -
> - $challenge->{'id_challenge'} = &get_random();
> - $challenge->{'email'} = $email;
> - $challenge->{'date'} = time;
> - $challenge->{'robot'} = $robot;
> - $challenge->{'data'} = $context;
> - return undef unless (&Challenge::store($challenge));
> - return $challenge->{'id_challenge'}
> -}
> -
> -
> -
> -sub load {
> -
> - my $id_challenge = shift;
> -
> - Sympa::Log::Syslog::do_log('debug', 'Challenge::load(%s)',
> $id_challenge);
> -
> - unless ($challenge_id) {
> - Sympa::Log::Syslog::do_log('err', 'Challenge::load() : internal
> error, SympaSession::load called with undef id_challenge');
> - return undef;
> - }
> -
> - my $sth;
> -
> - unless($sth = &SDM::do_query("SELECT id_challenge AS id_challenge,
> date_challenge AS 'date', remote_addr_challenge AS remote_addr,
> robot_challenge AS robot, email_challenge AS email, data_challenge AS data,
> hit_challenge AS hit, start_date_challenge AS start_date FROM
> challenge_table WHERE id_challenge = %s", $cookie)) {
> - Sympa::Log::Syslog::do_log('err','Unable to retrieve challenge %s
> from database',$cookie);
> - return undef;
> - }
> -
> - my $challenge = $sth->fetchrow_hashref('NAME_lc');
> -
> - unless ($challenge) {
> - return 'not_found';
> - }
> - my $challenge_datas;
> -
> - my %datas= &tools::string_2_hash($challenge->{'data'});
> - foreach my $key (keys %datas) {$challenge_datas->{$key} =
> $datas{$key};}
> -
> - $challenge_datas->{'id_challenge'} = $challenge->{'id_challenge'};
> - $challenge_datas->{'date'} = $challenge->{'date'};
> - $challenge_datas->{'robot'} = $challenge->{'robot'};
> - $challenge_datas->{'email'} = $challenge->{'email'};
> -
> - Sympa::Log::Syslog::do_log('debug3', 'Challenge::load(): removing
> existing challenge del_statement = %s',$del_statement);
> - unless(&SDM::do_query("DELETE FROM challenge_table WHERE
> (id_challenge=%s)",$id_challenge)) {
> - Sympa::Log::Syslog::do_log('err','Unable to delete challenge %s from
> database',$id_challenge);
> - return undef;
> - }
> -
> - return ('expired') if (time - $challenge_datas->{'date'} >=
> &tools::duration_conv(Site->challenge_table_ttl));
> - return ($challenge_datas);
> -}
> -
> -
> -sub store {
> -
> - my $challenge = shift;
> - Sympa::Log::Syslog::do_log('debug', 'Challenge::store()');
> -
> - return undef unless ($challenge->{'id_challenge'});
> -
> - my %hash ;
> - foreach my $var (keys %$challenge ) {
> - next if ($challenge_hard_attributes{$var});
> - next unless ($var);
> - $hash{$var} = $challenge->{$var};
> - }
> - my $data_string = &tools::hash_2_string (\%hash);
> - my $sth;
> -
> - unless(&SDM::do_query("INSERT INTO challenge_table (id_challenge,
> date_challenge, robot_challenge, email_challenge, data_challenge) VALUES
> ('%s','%s','%s','%s','%s'')",$challenge->{'id_challenge'},$challenge->{'date'},$challenge->{'robot'},$challenge->{'email'},$data_string))
> {
> - Sympa::Log::Syslog::do_log('err','Unable to store challenge %s
> informations in database (robot: %s, user:
> %s)',$challenge->{'id_challenge'},$challenge->{'robot'},$challenge->{'email'});
> - return undef;
> - }
> -}
> -
> -1;
> -
> Modified: trunk/wwsympa/Makefile.am (10084 => 10085)
> --- trunk/wwsympa/Makefile.am 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/Makefile.am 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -26,9 +26,6 @@
> wwsympa_wrapper_fcgi_SOURCES = wwsympa-wrapper.fcgi.c
> wwsympa_wrapper_fcgi_CPPFLAGS = -DWWSYMPA=\"$(execcgidir)/wwsympa.fcgi\"
>
> -nobase_modules_DATA = wwslib.pm cookielib.pm Marc.pm Auth.pm \
> - Marc/Search.pm SharedDocument.pm SympaSession.pm
> -
> default_DATA = mime.types
>
> EXTRA_DIST = $(default_DATA) $(nobase_modules_DATA) \
> Deleted: trunk/wwsympa/Marc.pm (10084 => 10085)
> --- trunk/wwsympa/Marc.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/Marc.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,58 +0,0 @@
> -package Marc;
> -
> -use strict;
> -
> -use Carp;
> -
> -our $AUTOLOAD;
> -our $VERSION = "4.3";
> -
> -##------------------------------------------------------------------------##
> -## Constructor
> -
> -sub new
> -{
> - my $class = shift;
> - my $fields_ref = shift;
> - my $self =
> - {
> - directory_labels => {},
> - permitted => $fields_ref,
> - sort_function => 'sub { $a cmp $b }',
> - %$fields_ref,
> - };
> - $self->{permitted}->{sort_function} = 'sub { $a cmp $b }';
> - bless $self,$class;
> - return $self;
> -}
> -
> -##------------------------------------------------------------------------##
> -## The AUTOLOAD function allows for the dynamic creation of accessor
> methods
> -
> -sub AUTOLOAD
> -{
> - my $self = shift;
> - my $type = ref($self) or croak "$self is not an object";
> - my $name = $AUTOLOAD;
> -
> - # DESTROY messages should never be propagated.
> - return if $name =~ /::DESTROY$/;
> - # Remove the package name.
> - $name =~ s/^.*://;
> -
> - unless (exists($self->{permitted}->{$name}))
> - {
> - &message('arcsearch_marc_autoload_no_access');
> - &wwslog('info','arcsearch_marc: Can not access %s field in
> object of class %s', $name, $type);
> - return undef;
> - }
> - if (@_)
> - {
> - return $self->{$name} = shift;
> - }
> - else
> - {
> - return $self->{$name};
> - }
> -}
> -1;
> Deleted: trunk/wwsympa/SharedDocument.pm (10084 => 10085)
> --- trunk/wwsympa/SharedDocument.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/SharedDocument.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,533 +0,0 @@
> -# SharedDocument.pm - module to manipulate shared web documents
> -# 
> -
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package SharedDocument;
> -
> -use strict;
> -
> -#use Carp; # currently not used
> -#use POSIX; # no longer used
> -
> -use tools;
> -use Language qw(gettext_strftime);
> -
> -#use List; # not used
> -use Log;
> -
> -## Creates a new object
> -sub new {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> - my ($pkg, $list, $path, $param) = @_;
> -
> - my $email = $param->{'user'}{'email'};
> -
> - #$email ||= 'nobody';
> - my $document = {};
> -
> - unless (ref($list) =~ /List/i) {
> - Sympa::Log::Syslog::do_log('err', 'SharedDocument::new : incorrect
> list parameter');
> - return undef;
> - }
> -
> - $document->{'root_path'} = $list->dir . '/shared';
> -
> - $document->{'path'} = &main::no_slash_end($path);
> - $document->{'escaped_path'} =
> - &tools::escape_chars($document->{'path'}, '/');
> -
> - ### Document isn't a description file
> - if ($document->{'path'} =~ /\.desc/) {
> - Sympa::Log::Syslog::do_log('err', "SharedDocument::new : %s :
> description file",
> - $document->{'path'});
> - return undef;
> - }
> -
> - ## absolute path
> - # my $doc;
> - $document->{'absolute_path'} = $document->{'root_path'};
> - if ($document->{'path'}) {
> - $document->{'absolute_path'} .= '/' . $document->{'path'};
> - }
> -
> - ## Check access control
> - &check_access_control($document, $param);
> -
> - ###############################
> - ## The path has been checked ##
> - ###############################
> -
> - ### Document exist ?
> - unless (-r $document->{'absolute_path'}) {
> - Sympa::Log::Syslog::do_log(
> - 'err',
> - "SharedDocument::new : unable to read %s : no such file or
> directory",
> - $document->{'absolute_path'}
> - );
> - return undef;
> - }
> -
> - ### Document has non-size zero?
> - unless (-s $document->{'absolute_path'}) {
> - Sympa::Log::Syslog::do_log(
> - 'err',
> - "SharedDocument::new : unable to read %s : empty document",
> - $document->{'absolute_path'}
> - );
> - return undef;
> - }
> -
> - $document->{'visible_path'} =
> - &main::make_visible_path($document->{'path'});
> -
> - ## Date
> - my @info = stat $document->{'absolute_path'};
> - $document->{'date'} = gettext_strftime "%d %b %Y", localtime $info[9];
> - $document->{'date_epoch'} = $info[9];
> -
> - # Size of the doc
> - $document->{'size'} = (-s $document->{'absolute_path'}) / 1000;
> -
> - ## Filename
> - my @tokens = split /\//, $document->{'path'};
> - $document->{'filename'} = $document->{'visible_filename'} =
> - $tokens[$#tokens];
> -
> - ## Moderated document
> - if ($document->{'filename'} =~ /^\.(.*)(\.moderate)$/) {
> - $document->{'moderate'} = 1;
> - $document->{'visible_filename'} = $1;
> - }
> -
> - $document->{'escaped_filename'} =
> - &tools::escape_chars($document->{'filename'});
> -
> - ## Father dir
> - if ($document->{'path'} =~ /^(([^\/]*\/)*)([^\/]+)$/) {
> - $document->{'father_path'} = $1;
> - } else {
> - $document->{'father_path'} = '';
> - }
> - $document->{'escaped_father_path'} =
> - &tools::escape_chars($document->{'father_path'}, '/');
> -
> - ### File, directory or URL ?
> - if (!(-d $document->{'absolute_path'})) {
> -
> - if ($document->{'filename'} =~ /^\..*\.(\w+)\.moderate$/) {
> - $document->{'file_extension'} = $1;
> - } elsif ($document->{'filename'} =~ /^.*\.(\w+)$/) {
> - $document->{'file_extension'} = $1;
> - }
> -
> - if ($document->{'file_extension'} eq 'url') {
> - $document->{'type'} = 'url';
> - } else {
> - $document->{'type'} = 'file';
> - }
> - } else {
> - $document->{'type'} = 'directory';
> - }
> -
> - ## Load .desc file unless root directory
> - my $desc_file;
> - if ($document->{'type'} eq 'directory') {
> - $desc_file = $document->{'absolute_path'} . '/.desc';
> - } else {
> - if ($document->{'absolute_path'} =~ /^(([^\/]*\/)*)([^\/]+)$/) {
> - $desc_file = $1 . '.desc.' . $3;
> - } else {
> - Sympa::Log::Syslog::do_log(
> - 'err',
> - "SharedDocument::new() : cannot determine desc file for %s",
> - $document->{'absolute_path'}
> - );
> - return undef;
> - }
> - }
> -
> - if ($document->{'path'} && (-e $desc_file)) {
> - my @info = stat $desc_file;
> - $document->{'serial_desc'} = $info[9];
> -
> - my %desc_hash = &main::get_desc_file($desc_file);
> - $document->{'owner'} = $desc_hash{'email'};
> - $document->{'title'} = $desc_hash{'title'};
> - $document->{'escaped_title'} =
> - &tools::escape_html($document->{'title'});
> -
> - # Author
> - if ($desc_hash{'email'}) {
> - $document->{'author'} = $desc_hash{'email'};
> - $document->{'author_mailto'} =
> - &main::mailto($list, $desc_hash{'email'});
> - $document->{'author_known'} = 1;
> - }
> - }
> -
> - ### File, directory or URL ?
> - if ($document->{'type'} eq 'url') {
> -
> - $document->{'icon'} = &main::get_icon('url');
> -
> - open DOC, $document->{'absolute_path'};
> - my $url = <DOC>;
> - close DOC;
> - chomp $url;
> - $document->{'url'} = $url;
> -
> - if ($document->{'filename'} =~ /^(.+)\.url/) {
> - $document->{'anchor'} = $1;
> - }
> - } elsif ($document->{'type'} eq 'file') {
> -
> - if (my $type = &main::get_mime_type($document->{'file_extension'})) {
> -
> - # type of the file and apache icon
> - if ($type =~ /^([\w\-]+)\/([\w\-]+)$/) {
> - my ($mimet, $subt) = ($1, $2);
> - if ($subt) {
> - if ($subt =~ /^octet-stream$/) {
> - $mimet = 'octet-stream';
> - $subt = 'binary';
> - }
> - $type = "$subt file";
> - }
> - $document->{'icon'} = &main::get_icon($mimet) ||
> - &main::get_icon('unknown');
> - }
> - } else {
> -
> - # unknown file type
> - $document->{'icon'} = &main::get_icon('unknown');
> - }
> -
> - ## HTML file
> - if ($document->{'file_extension'} =~ /^html?$/i) {
> - $document->{'html'} = 1;
> - $document->{'icon'} = &main::get_icon('text');
> - }
> -
> - ## Directory
> - } else {
> -
> - $document->{'icon'} = &main::get_icon('folder');
> -
> - # listing of all the shared documents of the directory
> - unless (opendir DIR, $document->{'absolute_path'}) {
> - Sympa::Log::Syslog::do_log(
> - 'err',
> - "SharedDocument::new() : cannot open %s : %s",
> - $document->{'absolute_path'}, $!
> - );
> - return undef;
> - }
> -
> - # array of entry of the directory DIR
> - my @tmpdir = readdir DIR;
> - closedir DIR;
> -
> - my $dir =
> - &main::get_directory_content(\@tmpdir, $email, $list,
> - $document->{'absolute_path'});
> -
> - foreach my $d (@{$dir}) {
> -
> - my $sub_document =
> - new SharedDocument($list, $document->{'path'} . '/' . $d,
> - $param);
> - push @{$document->{'subdir'}}, $sub_document;
> - }
> - }
> -
> - $document->{'list'} = $list;
> -
> - ## Bless Message object
> - bless $document, $pkg;
> -
> - return $document;
> -}
> -
> -sub dump {
> - my $self = shift;
> - my $fd = shift;
> -
> - &tools::dump_var($self, 0, $fd);
> -
> -}
> -
> -sub dup {
> - my $self = shift;
> -
> - my $copy = {};
> -
> - foreach my $k (keys %$self) {
> - $copy->{$k} = $self->{$k};
> - }
> -
> - return $copy;
> -}
> -
> -## Regulars
> -# read(/) = default (config list)
> -# edit(/) = default (config list)
> -# control(/) = not defined
> -# read(A/B)= (read(A) && read(B)) ||
> -# (author(A) || author(B))
> -# edit = idem read
> -# control (A/B) : author(A) || author(B)
> -# + (set owner A/B) if (empty directory &&
> -# control A)
> -
> -sub check_access_control {
> -
> - # Arguments:
> - # (\%mode,$path)
> - # if mode->{'read'} control access only for read
> - # if mode->{'edit'} control access only for edit
> - # if mode->{'control'} control access only for control
> -
> -# return the hash (
> -# $result{'may'}{'read'} == $result{'may'}{'edit'} ==
> $result{'may'}{'control'} if is_author else :
> -# $result{'may'}{'read'} = 0 or 1 (right or not)
> -# $result{'may'}{'edit'} = 0(not may edit) or 0.5(may edit with
> moderation) or 1(may edit ) : it is not a boolean anymore
> -# $result{'may'}{'control'} = 0 or 1 (right or not)
> -# $result{'reason'}{'read'} = string for authorization_reject.tt2 when
> may_read == 0
> -# $result{'reason'}{'edit'} = string for authorization_reject.tt2 when
> may_edit == 0
> -# $result{'scenario'}{'read'} = scenario name for the document
> -# $result{'scenario'}{'edit'} = scenario name for the document
> -
> - # Result
> - my %result;
> - $result{'reason'} = {};
> -
> - # Control
> -
> - # Arguments
> - my $self = shift;
> - my $param = shift;
> -
> - my $list = $self->{'list'};
> -
> - Sympa::Log::Syslog::do_log('debug', "check_access_control(%s)",
> $self->{'path'});
> -
> - # Control for editing
> - my $may_read = 1;
> - my $why_not_read = '';
> - my $may_edit = 1;
> - my $why_not_edit = '';
> -
> - ## First check privileges on the root shared directory
> - $result{'scenario'}{'read'} = $list->shared_doc->{'d_read'}{'name'};
> - $result{'scenario'}{'edit'} = $list->shared_doc->{'d_edit'}{'name'};
> -
> - ## Privileged owner has all privileges
> - if ($param->{'is_privileged_owner'}) {
> - $result{'may'}{'read'} = 1;
> - $result{'may'}{'edit'} = 1;
> - $result{'may'}{'control'} = 1;
> -
> - $self->{'access'} = \%result;
> - return 1;
> - }
> -
> - # if not privileged owner
> - if (1) {
> - my $result = Scenario::request_action(
> - $list,
> - 'shared_doc.d_read',
> - $param->{'auth_method'},
> - { 'sender' => $param->{'user'}{'email'},
> - 'remote_host' => $param->{'remote_host'},
> - 'remote_addr' => $param->{'remote_addr'}
> - }
> - );
> - my $action;
> - if (ref($result) eq 'HASH') {
> - $action = $result->{'action'};
> - $why_not_read = $result->{'reason'};
> - }
> -
> - $may_read = ($action =~ /do_it/i);
> - }
> -
> - if (1) {
> - my $result = Scenario::request_action(
> - $list,
> - 'shared_doc.d_edit',
> - $param->{'auth_method'},
> - { 'sender' => $param->{'user'}{'email'},
> - 'remote_host' => $param->{'remote_host'},
> - 'remote_addr' => $param->{'remote_addr'}
> - }
> - );
> - my $action;
> - if (ref($result) eq 'HASH') {
> - $action = $result->{'action'};
> - $why_not_edit = $result->{'reason'};
> - }
> -
> - #edit = 0, 0.5 or 1
> - $may_edit = &main::find_edit_mode($action);
> - $why_not_edit = '' if ($may_edit);
> - }
> -
> - ## Only authenticated users can edit files
> - unless ($param->{'user'}{'email'}) {
> - $may_edit = 0;
> - $why_not_edit = 'not_authenticated';
> - }
> -
> - my $current_path = $self->{'path'};
> - my $current_document;
> - my %desc_hash;
> - my $user = $param->{'user'}{'email'} || 'nobody';
> -
> - while ($current_path ne "") {
> -
> - # no description file found yet
> - my $def_desc_file = 0;
> - my $desc_file;
> -
> - $current_path =~ /^(([^\/]*\/)*)([^\/]+)(\/?)$/;
> - $current_document = $3;
> - my $next_path = $1;
> -
> - # opening of the description file appropriated
> - if (-d $self->{'root_path'} . '/' . $current_path) {
> -
> - # case directory
> -
> - # unless ($slash) {
> - $current_path = $current_path . '/';
> -
> - # }
> -
> - if (-e "$self->{'root_path'}/$current_path.desc") {
> - $desc_file =
> - $self->{'root_path'} . '/' . $current_path . ".desc";
> - $def_desc_file = 1;
> - }
> -
> - } else {
> -
> - # case file
> - if (-e "$self->{'root_path'}/$next_path.desc.$3") {
> - $desc_file =
> - $self->{'root_path'} . '/' . $next_path . ".desc." . $3;
> - $def_desc_file = 1;
> - }
> - }
> -
> - if ($def_desc_file) {
> -
> - # a description file was found
> - # loading of acces information
> -
> - %desc_hash = &main::get_desc_file($desc_file);
> -
> - ## Author has all privileges
> - if ($user eq $desc_hash{'email'}) {
> - $result{'may'}{'read'} = 1;
> - $result{'may'}{'edit'} = 1;
> - $result{'may'}{'control'} = 1;
> -
> - $self->{'access'} = \%result;
> - return 1;
> - }
> -
> - if (1) {
> -
> - my $result = Scenario::request_action(
> - $list,
> - 'shared_doc.d_read',
> - $param->{'auth_method'},
> - { 'sender' => $param->{'user'}{'email'},
> - 'remote_host' => $param->{'remote_host'},
> - 'remote_addr' => $param->{'remote_addr'},
> - 'scenario' => $desc_hash{'read'}
> - }
> - );
> - my $action;
> - if (ref($result) eq 'HASH') {
> - $action = $result->{'action'};
> - $why_not_read = $result->{'reason'};
> - }
> -
> - $may_read = $may_read && ($action =~ /do_it/i);
> - $why_not_read = '' if ($may_read);
> - }
> -
> - if (1) {
> - my $result = Scenario::request_action(
> - $list,
> - 'shared_doc.d_edit',
> - $param->{'auth_method'},
> - { 'sender' => $param->{'user'}{'email'},
> - 'remote_host' => $param->{'remote_host'},
> - 'remote_addr' => $param->{'remote_addr'},
> - 'scenario' => $desc_hash{'edit'}
> - }
> - );
> - my $action_edit;
> - if (ref($result) eq 'HASH') {
> - $action_edit = $result->{'action'};
> - $why_not_edit = $result->{'reason'};
> - }
> -
> - # $may_edit = 0, 0.5 or 1
> - my $may_action_edit = &main::find_edit_mode($action_edit);
> - $may_edit = &main::merge_edit($may_edit, $may_action_edit);
> - $why_not_edit = '' if ($may_edit);
> -
> - }
> -
> - ## Only authenticated users can edit files
> - unless ($param->{'user'}{'email'}) {
> - $may_edit = 0;
> - $why_not_edit = 'not_authenticated';
> - }
> -
> - unless (defined $result{'scenario'}{'read'}) {
> - $result{'scenario'}{'read'} = $desc_hash{'read'};
> - $result{'scenario'}{'edit'} = $desc_hash{'edit'};
> - }
> -
> - }
> -
> - # truncate the path for the while
> - $current_path = $next_path;
> - }
> -
> - if (1) {
> - $result{'may'}{'read'} = $may_read;
> - $result{'reason'}{'read'} = $why_not_read;
> - }
> -
> - if (1) {
> - $result{'may'}{'edit'} = $may_edit;
> - $result{'reason'}{'edit'} = $why_not_edit;
> - }
> -
> - $self->{'access'} = \%result;
> - return 1;
> -}
> -
> -1;
> Deleted: trunk/wwsympa/SympaSession.pm (10084 => 10085)
> --- trunk/wwsympa/SympaSession.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/SympaSession.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,796 +0,0 @@
> -# SympaSession.pm - This module includes functions managing HTTP sessions
> in Sympa
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package SympaSession;
> -
> -use strict;
> -
> -use CGI::Cookie;
> -#use Digest::MD5; # no longer used
> -#use POSIX; # no longer used
> -#use Time::Local; # not used
> -
> -#use Conf; # no longer used
> -#use Log; # used by SDM
> -use SDM;
> -
> -# this structure is used to define which session attributes are stored in a
> -# dedicated database col where others are compiled in col 'data_session'
> -my %session_hard_attributes = ('id_session' => 1,
> - 'prev_id' => 1,
> - 'date' => 1,
> - 'refresh_date' => 1,
> - 'remote_addr' => 1,
> - 'robot' => 1,
> - 'email' => 1,
> - 'start_date' => 1,
> - 'hit' => 1,
> - 'new_session' => 1,
> - );
> -
> -sub new {
> - my $pkg = shift;
> - my $robot = Robot::clean_robot(shift, 1); #FIXME: maybe a Site object?
> - my $context = shift || {};
> -
> - my $cookie = $context->{'cookie'};
> - my $action = $context->{'action'};
> - my $rss = $context->{'rss'};
> - my $ajax = $context->{'ajax'};
> - Sympa::Log::Syslog::do_log('debug2', '(%s, cookie=%s, action=%s)',
> - $robot, $cookie, $action);
> -
> - my $self = {'robot' => $robot};
> - bless $self => $pkg;
> -
> - # passive_session are session not stored in the database, they are used
> - # for crawler bots and action such as css, wsdl, ajax and rss
> -
> - if (tools::is_a_crawler($robot,
> - {'user_agent_string' => $ENV{'HTTP_USER_AGENT'}})) {
> - $self->{'is_a_crawler'} = 1;
> - $self->{'passive_session'} = 1;
> - }
> - $self->{'passive_session'} = 1
> - if $rss or $action eq 'wsdl' or $action eq 'css';
> -
> - # if a session cookie exists, try to restore an existing session, don't
> - # store sessions from bots
> - if ($cookie and $self->{'passive_session'} != 1){
> - my $status ;
> - $status = $self->load($cookie);
> - unless (defined $status) {
> - return undef;
> - }
> - if ($status eq 'not_found') {
> - # start a new session (may be a fake cookie)
> - Sympa::Log::Syslog::do_log('info', 'ignoring unknown session
> cookie "%s"',
> - $cookie);
> - return __PACKAGE__->new($robot);
> - }
> - } else {
> - # create a new session context
> - ## Tag this session as new, ie no data in the DB exist
> - $self->{'new_session'} = 1;
> - $self->{'id_session'} = get_random();
> - $self->{'email'} = 'nobody';
> - $self->{'remote_addr'} = $ENV{'REMOTE_ADDR'};
> - $self->{'date'} = $self->{'start_date'} = $self->{'refresh_date'} =
> - time;
> - $self->{'hit'} = 1;
> - ##$self->{'robot'} = $robot->name;
> - $self->{'data'} = '';
> - }
> - return $self;
> -}
> -
> -sub load {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s)', @_);
> - my $self = shift;
> - my $cookie = shift;
> -
> - unless ($cookie) {
> - Sympa::Log::Syslog::do_log('err', 'internal error, undef id_session');
> - return undef;
> - }
> -
> - my $sth;
> - my $id_session;
> - my $is_old_session = 0;
> -
> - ## Load existing session.
> - if ($cookie and $cookie =~ /^\d{,16}$/) {
> - ## Compatibility: session by older releases of Sympa.
> - $id_session = $cookie;
> - $is_old_session = 1;
> -
> - ## Session by older releases of Sympa doesn't have refresh_date.
> - unless ($sth = SDM::do_prepared_query(
> - q{SELECT id_session AS id_session, id_session AS prev_id,
> - date_session AS "date",
> - remote_addr_session AS remote_addr,
> - robot_session AS robot, email_session AS email,
> - data_session AS data, hit_session AS hit,
> - start_date_session AS start_date,
> - date_session AS refresh_date
> - FROM session_table
> - WHERE robot_session = ? AND
> - id_session = ? AND
> - refresh_date_session IS NULL},
> - $self->{'robot'}->name, $id_session
> - )) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to load session %s',
> $id_session);
> - return undef;
> - }
> - } else {
> - $id_session = decrypt_session_id($cookie);
> - unless ($id_session) {
> - Sympa::Log::Syslog::do_log('err', 'internal error, undef
> id_session');
> - return 'not_found';
> - }
> -
> - ## Cookie may contain current or previous session ID.
> - unless ($sth = SDM::do_prepared_query(
> - q{SELECT id_session AS id_session, prev_id_session AS prev_id,
> - date_session AS "date",
> - remote_addr_session AS remote_addr,
> - robot_session AS robot, email_session AS email,
> - data_session AS data, hit_session AS hit,
> - start_date_session AS start_date,
> - refresh_date_session AS refresh_date
> - FROM session_table
> - WHERE robot_session = ? AND
> - (id_session = ? AND prev_id_session IS NOT NULL OR
> - prev_id_session = ?)},
> - $self->{'robot'}->name, $id_session, $id_session
> - )) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to load session %s',
> $id_session);
> - return undef;
> - }
> - }
> -
> - my $session = undef;
> - my $new_session = undef;
> - my $counter = 0;
> - while ($new_session = $sth->fetchrow_hashref('NAME_lc')) {
> - if ($counter > 0) {
> - Sympa::Log::Syslog::do_log('err',
> - 'The SQL statement did return more than one session');
> - $session->{'email'} = '';
> - last;
> - }
> - $session = $new_session;
> - $counter++;
> - }
> -
> - unless ($session) {
> - return 'not_found';
> - }
> -
> - ## Compatibility: Upgrade session by older releases of Sympa.
> - if ($is_old_session) {
> - SDM::do_prepared_query(
> - q{UPDATE session_table
> - SET prev_id_session = id_session
> - WHERE id_session = ? AND prev_id_session IS NULL AND
> - refresh_date_session IS NULL},
> - $id_session
> - );
> - }
> -
> - my %datas = tools::string_2_hash($session->{'data'});
> -
> - ## canonicalize lang if possible.
> - $datas{'lang'} =
> - Language::CanonicLang($datas{'lang'}) || $datas{'lang'}
> - if $datas{'lang'};
> -
> - foreach my $key (keys %datas) {$self->{$key} = $datas{$key};}
> -
> - $self->{'id_session'} = $session->{'id_session'};
> - $self->{'prev_id'} = $session->{'prev_id'};
> - $self->{'date'} = $session->{'date'};
> - $self->{'start_date'} = $session->{'start_date'};
> - $self->{'refresh_date'} = $session->{'refresh_date'};
> - $self->{'hit'} = $session->{'hit'} +1 ;
> - $self->{'remote_addr'} = $session->{'remote_addr'};
> - ##$self->{'robot'} = $session->{'robot'};
> - $self->{'email'} = $session->{'email'};
> -
> - return ($self);
> -}
> -
> -## This method will both store the session information in the database
> -sub store {
> - Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> - my $self = shift;
> -
> - return undef unless $self->{'id_session'};
> - # do not create a session in session table for crawlers;
> - return if $self->{'is_a_crawler'};
> - # do not create a session in session table for action such as RSS or
> CSS
> - # or wsdl that do not require this sophistication;
> - return if $self->{'passive_session'};
> -
> - my %hash;
> - foreach my $var (keys %$self ) {
> - next if ($session_hard_attributes{$var});
> - next unless ($var);
> - $hash{$var} = $self->{$var};
> - }
> - my $data_string = tools::hash_2_string (\%hash);
> - my $time = time;
> -
> - ## If this is a new session, then perform an INSERT
> - if ($self->{'new_session'}) {
> - ## Store the new session ID in the DB
> - ## Previous session ID is set to be same as new session ID.
> - unless (SDM::do_prepared_query(
> - q{INSERT INTO session_table
> - (id_session, prev_id_session,
> - date_session, refresh_date_session,
> - remote_addr_session, robot_session,
> - email_session, start_date_session, hit_session,
> - data_session)
> - VALUES (?, ?, ?, ?, ?, ?, ?, ?, ?, ?)},
> - $self->{'id_session'}, $self->{'id_session'},
> - $time, $time,
> - $ENV{'REMOTE_ADDR'}, $self->{'robot'}->name,
> - $self->{'email'}, $self->{'start_date'}, $self->{'hit'},
> - $data_string
> - )) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to add new session %s informations in database',
> - $self->{'id_session'}
> - );
> - return undef;
> - }
> -
> - $self->{'prev_id'} = $self->{'id_session'};
> -
> - } else {
> - ## If the session already exists in DB, then perform an UPDATE
> -
> - ## Cookie may contain previous session ID.
> - my $sth = SDM::do_prepared_query(
> - q{SELECT id_session
> - FROM session_table
> - WHERE robot_session = ? AND prev_id_session = ?},
> - $self->{'robot'}->name, $self->{'id_session'}
> - );
> - unless ($sth) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to update session information in database');
> - return undef;
> - }
> - if ($sth->rows) {
> - my $new_id = $sth->fetchrow;
> - $sth->finish;
> - if ($new_id) {
> - $self->{'prev_id'} = $self->{'id_session'};
> - $self->{'id_session'} = $new_id;
> - }
> - }
> -
> - ## Update the new session in the DB
> - unless (SDM::do_prepared_query(
> - q{UPDATE session_table
> - SET date_session = ?, remote_addr_session = ?,
> - robot_session = ?, email_session = ?,
> - start_date_session = ?, hit_session = ?, data_session = ?
> - WHERE robot_session = ? AND
> - (id_session = ? AND prev_id_session IS NOT NULL OR
> - prev_id_session = ?)},
> - $time, $ENV{'REMOTE_ADDR'},
> - $self->{'robot'}->name, $self->{'email'},
> - $self->{'start_date'}, $self->{'hit'}, $data_string,
> - $self->{'robot'}->name,
> - $self->{'id_session'},
> - $self->{'id_session'}
> - )) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to update session %s information in database',
> - $self->{'id_session'}
> - );
> - return undef;
> - }
> - }
> -
> - return 1;
> -}
> -
> -## This method will renew the session ID
> -sub renew {
> - Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> - my $self = shift;
> -
> - return undef unless $self->{'id_session'};
> - # do not create a session in session table for crawlers;
> - return if $self->{'is_a_crawler'};
> - # do not create a session in session table for action such as RSS or
> CSS
> - # or wsdl that do not require this sophistication;
> - return if $self->{'passive_session'};
> -
> - my %hash;
> - foreach my $var (keys %$self ) {
> - next if ($session_hard_attributes{$var});
> - next unless ($var);
> - $hash{$var} = $self->{$var};
> - }
> - my $data_string = tools::hash_2_string(\%hash);
> -
> - my $sth;
> - ## Cookie may contain previous session ID.
> - $sth = SDM::do_prepared_query(
> - q{SELECT id_session
> - FROM session_table
> - WHERE robot_session = ? AND prev_id_session = ?},
> - $self->{'robot'}->name, $self->{'id_session'}
> - );
> - unless ($sth) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to update session information in database');
> - return undef;
> - }
> - if ($sth->rows) {
> - my $new_id = $sth->fetchrow;
> - $sth->finish;
> - if ($new_id) {
> - $self->{'prev_id'} = $self->{'id_session'};
> - $self->{'id_session'} = $new_id;
> - }
> - }
> -
> - ## Renew the session ID in order to prevent session hijacking
> - my $new_id = get_random();
> -
> - ## Do refresh the session ID when remote address was changed or refresh
> - ## interval was past. Conditions also are checked by SQL so that
> - ## simultaneous processes will be prevented renewing cookie.
> - my $time = time;
> - my $remote_addr = $ENV{'REMOTE_ADDR'};
> - my $refresh_term;
> - if (Site->cookie_refresh == 0) {
> - $refresh_term = $time;
> - } else {
> - my $cookie_refresh = Site->cookie_refresh;
> - $refresh_term =
> - int($time - $cookie_refresh * 0.25 - rand($cookie_refresh * 0.5));
> - }
> - unless ($self->{'remote_addr'} ne $remote_addr or
> - $self->{'refresh_date'} <= $refresh_term) {
> - return 0;
> - }
> -
> - ## First insert DB entry with new session ID,
> - $sth = SDM::do_query(
> - q{INSERT INTO session_table
> - (id_session, prev_id_session,
> - start_date_session, date_session, refresh_date_session,
> - remote_addr_session, robot_session, email_session,
> - hit_session, data_session)
> - SELECT %s, id_session,
> - start_date_session, date_session, %d,
> - %s, robot_session, email_session,
> - hit_session, data_session
> - FROM session_table
> - WHERE robot_session = %s AND
> - (id_session = %s AND prev_id_session IS NOT NULL OR
> - prev_id_session = %s) AND
> - (remote_addr_session <> %s OR refresh_date_session <= %d)},
> - SDM::quote($new_id),
> - $time,
> - SDM::quote($remote_addr),
> - SDM::quote($self->{'robot'}->name),
> - SDM::quote($self->{'id_session'}),
> - SDM::quote($self->{'id_session'}),
> - SDM::quote($remote_addr), $refresh_term
> - );
> - unless ($sth) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to renew session ID for
> session %s',
> - $self->{'id_session'});
> - return undef;
> - }
> - unless ($sth->rows) {
> - return 0;
> - }
> - ## Keep previous ID to prevent crosstalk, clearing grand-parent ID.
> - SDM::do_prepared_query(
> - q{UPDATE session_table
> - SET prev_id_session = NULL
> - WHERE robot_session = ? AND id_session = ?},
> - $self->{'robot'}->name, $self->{'id_session'}
> - );
> - ## Remove record of grand-parent ID.
> - SDM::do_prepared_query(
> - q{DELETE FROM session_table
> - WHERE id_session = ? AND prev_id_session IS NULL},
> - $self->{'prev_id'}
> - );
> -
> - ## Renew the session ID in order to prevent session hijacking
> - Sympa::Log::Syslog::do_log('info',
> - '[robot %s] [session %s] [client %s]%s new session %s',
> - $self->{'robot'}->name, $self->{'id_session'}, $remote_addr,
> - ($self->{'email'} ? sprintf(' [user %s]', $self->{'email'}) : ''),
> - $new_id
> - );
> - $self->{'prev_id'} = $self->{'id_session'};
> - $self->{'id_session'} = $new_id;
> - $self->{'refresh_date'} = $time;
> - $self->{'remote_addr'} = $remote_addr;
> -
> - return 1;
> -}
> -
> -## remove old sessions from a particular robot or from all robots.
> -## delay is a parameter in seconds
> -sub purge_old_sessions {
> - Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> - my $robot = Robot::clean_robot(shift, 1);
> -
> - my $delay = tools::duration_conv(Site->session_table_ttl);
> - my $anonymous_delay =
> - tools::duration_conv(Site->anonymous_session_table_ttl);
> -
> - unless ($delay) {
> - Sympa::Log::Syslog::do_log('debug3', 'exit with delay null');
> - return;
> - }
> - unless ($anonymous_delay) {
> - Sympa::Log::Syslog::do_log('debug3', 'exit with anonymous delay
> null');
> - return;
> - }
> -
> - my @sessions ;
> - my $sth;
> -
> - my $condition = '';
> - $condition = sprintf 'robot_session = %s', SDM::quote($robot->name)
> - if ref $robot eq 'Robot';
> - my $anonymous_condition = $condition;
> -
> - $condition .= sprintf '%s%d > date_session',
> - ($condition ? ' AND ' : ''), time - $delay
> - if $delay;
> - $condition = " WHERE $condition"
> - if $condition;
> -
> - $anonymous_condition .= sprintf '%s%d > date_session',
> - ($anonymous_condition ? ' AND ' : ''), time - $anonymous_delay
> - if $anonymous_delay;
> - $anonymous_condition .= sprintf
> - "%semail_session = 'nobody' AND hit_session = 1",
> - ($anonymous_condition ? ' AND ' : '');
> - $anonymous_condition = " WHERE $anonymous_condition"
> - if $anonymous_condition;
> -
> - my $count_statement = q{SELECT count(*) FROM session_table%s};
> - my $anonymous_count_statement = q{SELECT count(*) FROM
> session_table%s};
> - my $statement = q{DELETE FROM session_table%s};
> - my $anonymous_statement = q{DELETE FROM session_table%s};
> -
> - unless ($sth = SDM::do_query($count_statement, $condition)) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to count old session for
> robot %s', $robot);
> - return undef;
> - }
> -
> - my $total = $sth->fetchrow;
> - if ($total == 0) {
> - Sympa::Log::Syslog::do_log('debug3', 'no sessions to expire');
> - }else{
> - unless ($sth = SDM::do_query($statement, $condition)) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to purge old sessions
> for robot %s',
> - $robot);
> - return undef;
> - }
> - }
> - unless ($sth = SDM::do_query($anonymous_count_statement,
> - $anonymous_condition)) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to count anonymous sessions
> for robot %s',
> - $robot);
> - return undef;
> - }
> - my $anonymous_total = $sth->fetchrow;
> - if ($anonymous_total == 0) {
> - Sympa::Log::Syslog::do_log('debug3', 'no anonymous sessions to
> expire');
> - return $total ;
> - }
> - unless ($sth = SDM::do_query($anonymous_statement,
> - $anonymous_condition)) {
> - Sympa::Log::Syslog::do_log('err', 'Unable to purge anonymous sessions
> for robot %s',
> - $robot);
> - return undef;
> - }
> - return $total+$anonymous_total;
> -}
> -
> -
> -## remove old one_time_ticket from a particular robot or from all robots.
> delay is a parameter in seconds
> -##
> -sub purge_old_tickets {
> - Sympa::Log::Syslog::do_log('debug2', '(%s)', @_);
> - my $robot = Robot::clean_robot(shift, 1);
> -
> - my $delay = tools::duration_conv(Site->one_time_ticket_table_ttl);
> - unless ($delay) {
> - Sympa::Log::Syslog::do_log('debug3', 'exit with delay null');
> - return;
> - }
> -
> - my @tickets ;
> - my $sth;
> -
> - my $condition = '';
> - $condition = sprintf '%d > date_one_time_ticket', time - $delay
> - if $delay;
> - $condition .= sprintf '%srobot_one_time_ticket = %s',
> - ($condition ? ' AND ' : ''), SDM::quote($robot->name)
> - if ref $robot eq 'Robot';
> - $condition = " WHERE $condition"
> - if $condition;
> -
> - unless ($sth = SDM::do_query(
> - q{SELECT count(*) FROM one_time_ticket_table%s},
> - $condition
> - )) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to count old one time tickets for robot %s', $robot);
> - return undef;
> - }
> -
> - my $total = $sth->fetchrow;
> - if ($total == 0) {
> - Sympa::Log::Syslog::do_log('debug3', 'no tickets to expire');
> - }else{
> - unless ($sth = SDM::do_query(
> - q{DELETE FROM one_time_ticket_table%s},
> - $condition
> - )) {
> - Sympa::Log::Syslog::do_log('err',
> - 'Unable to delete expired one time tickets for robot %s',
> - $robot);
> - return undef;
> - }
> - }
> - return $total;
> -}
> -
> -# list sessions for $robot where last access is newer then $delay. List is
> limited to connected users if $connected_only
> -sub list_sessions {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s)', @_);
> - my $delay = shift;
> - my $robot = Robot::clean_robot(shift, 1);
> - my $connected_only = shift;
> -
> - my @sessions ;
> - my $sth;
> - my $time = time;
> -
> - my $condition = '';
> - $condition = sprintf 'robot_session = %s', SDM::quote($robot->name)
> - if ref $robot eq 'Robot';
> - $condition .= sprintf '%s%d < date_session',
> - ($condition ? ' AND ' : ''), $time - $delay
> - if $delay;
> - $condition .= sprintf "%semail_session <> 'nobody'",
> - ($condition ? ' AND ' : '')
> - if $connected_only eq 'on';
> - $condition .= sprintf "%sprev_id_session IS NOT NULL",
> - ($condition ? ' AND ' : '');
> - $condition = " WHERE $condition"
> - if $condition;
> -
> - unless ($sth = SDM::do_query(
> - q{SELECT remote_addr_session, email_session, robot_session,
> - date_session, start_date_session, hit_session
> - FROM session_table%s},
> - $condition
> - )) {
> - Sympa::Log::Syslog::do_log('err','Unable to get the list of sessions
> for robot %s',
> - $robot);
> - return undef;
> - }
> -
> - while (my $session = ($sth->fetchrow_hashref('NAME_lc'))) {
> - $session->{'formated_date'} =
> - Language::gettext_strftime("%d %b %y %H:%M",
> localtime($session->{'date_session'}));
> - $session->{'formated_start_date'} =
> - Language::gettext_strftime ("%d %b %y %H:%M",
> localtime($session->{'start_date_session'}));
> -
> - push @sessions, $session;
> - }
> -
> - return \@sessions;
> -}
> -
> -###############################
> -# Subroutines to read cookies #
> -###############################
> -
> -## Generic subroutine to get a cookie value
> -sub get_session_cookie {
> - my $http_cookie = shift;
> -
> - if ($http_cookie =~/\S+/g) {
> - my %cookies = parse CGI::Cookie($http_cookie);
> - foreach (keys %cookies) {
> - my $cookie = $cookies{$_};
> - next unless ($cookie->name eq 'sympa_session');
> - return ($cookie->value);
> - }
> - }
> -
> - return (undef);
> -}
> -
> -
> -## Generic subroutine to set a cookie
> -## Set user $email cookie, ckecksum use $secret, expire=(now|session|#sec)
> domain=(localhost|<a domain>)
> -sub set_cookie {
> - Sympa::Log::Syslog::do_log('debug2', '(%s, %s, %s, %s)', @_);
> - my ($self, $http_domain, $expires,$use_ssl) = @_ ;
> -
> - my $expiration;
> - if ($expires =~ /now/i) {
> - ## 10 years ago
> - $expiration = '-10y';
> - }else{
> - $expiration = '+'.$expires.'m';
> - }
> -
> - if ($http_domain eq 'localhost') {
> - $http_domain="";
> - }
> -
> - my $value = encrypt_session_id($self->{'id_session'});
> -
> - my $cookie;
> - if ($expires =~ /session/i) {
> - $cookie = new CGI::Cookie (-name => 'sympa_session',
> - -value => $value,
> - -domain => $http_domain,
> - -path => '/',
> - -secure => $use_ssl,
> - -httponly => 1
> - );
> - }else {
> - $cookie = new CGI::Cookie (-name => 'sympa_session',
> - -value => $value,
> - -expires => $expiration,
> - -domain => $http_domain,
> - -path => '/',
> - -secure => $use_ssl,
> - -httponly => 1
> - );
> - }
> -
> - ## Send cookie to the client
> - printf "Set-Cookie: %s\n", $cookie->as_string;
> - return 1;
> -}
> -
> -# Build an HTTP cookie value to be sent to a SOAP client
> -sub soap_cookie2 {
> - my ($session_id, $http_domain, $expire) = @_;
> - my $cookie;
> - my $value;
> -
> - # WARNING : to check the cookie the SOAP services does not gives
> - # all the cookie, only it's value so we need ':'
> - $value = encrypt_session_id($session_id);
> -
> - ## With set-cookie2 max-age of 0 means removing the cookie
> - ## Maximum cookie lifetime is the session
> - $expire ||= 600; ## 10 minutes
> -
> - if ($http_domain eq 'localhost') {
> - $cookie = CGI::Cookie->new(
> - -name => 'sympa_session',
> - -value => $value,
> - -path => '/',
> - );
> - $cookie->max_age(time + $expire); # needs CGI >= 3.51.
> - } else {
> - $cookie = CGI::Cookie->new(
> - -name => 'sympa_session',
> - -value => $value,
> - -domain => $http_domain,
> - -path => '/',
> - );
> - $cookie->max_age(time + $expire); # needs CGI >= 3.51.
> - }
> -
> - ## Return the cookie value
> - return $cookie->as_string;
> -}
> -
> -sub get_random {
> - Sympa::Log::Syslog::do_log('debug3', '()');
> - ## Concatenates 2 integers for a better entropy
> - my $random = int(rand(10**7)).int(rand(10**7));
> - $random =~ s/^0(\.|\,)//;
> - return ($random)
> -}
> -
> -## Return the session object content, as a hashref
> -sub as_hashref {
> - my $self = shift;
> - my $data;
> -
> - foreach my $key (keys %{$self}) {
> - if ($key eq 'robot') {
> - $data->{$key} = $self->{'robot'}->name;
> - } else {
> - $data->{$key} = $self->{$key};
> - }
> - }
> -
> - return $data;
> -}
> -
> -## Return 1 if the Session object corresponds to an anonymous session.
> -sub is_anonymous {
> - my $self = shift;
> - if($self->{'email'} eq 'nobody' || $self->{'email'} eq '') {
> - return 1;
> - }else{
> - return 0;
> - }
> -}
> -
> -## Generate cookie from session ID.
> -sub encrypt_session_id {
> - my $id_session = shift;
> -
> - return $id_session unless Site->cookie;
> - my $cipher = tools::ciphersaber_installed();
> - return $id_session unless $cipher;
> -
> - my $id_session_bin =
> - pack 'nN', ($id_session >> 32), $id_session % (1 << 32);
> - my $cookie_bin = $cipher->encrypt($id_session_bin);
> - return sprintf '%*v02x', '', $cookie_bin;
> -}
> -
> -## Get session ID from cookie.
> -sub decrypt_session_id {
> - my $cookie = shift;
> -
> - return $cookie unless Site->cookie;
> - my $cipher = tools::ciphersaber_installed();
> - return $cookie unless $cipher;
> -
> - return undef unless $cookie =~ /\A[0-9a-f]+\z/;
> - my $cookie_bin = $cookie;
> - $cookie_bin =~ s/([0-9a-f]{2})/sprintf '%c', hex("0x$1")/eg;
> - my ($id_session_hi, $id_session_lo) =
> - unpack 'nN', $cipher->decrypt($cookie_bin);
> -
> - return ($id_session_hi << 32) + $id_session_lo;
> -}
> -
> -## Get unique ID
> -sub get_id {
> - my $self = shift;
> - return '' unless $self->{'id_session'} and $self->{'robot'};
> - return sprintf '%s@%s', $self->{'id_session'}, $self->{'robot'}->name;
> -}
> -
> -1;
> Deleted: trunk/wwsympa/cookielib.pm (10084 => 10085)
> --- trunk/wwsympa/cookielib.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/cookielib.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,206 +0,0 @@
> -# cookielib.pm - This module includes functions managing HTTP cookies in
> Sympa
> -# RCS Identication ; $Revision$ ; $Date$
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package cookielib;
> -
> -use strict "vars";
> -
> -use Digest::MD5;
> -use POSIX;
> -use CGI::Cookie;
> -
> -use Log;
> -
> -## Generic subroutine to set a cookie
> -sub generic_set_cookie {
> - my %param = @_;
> -
> - my %cookie_param;
> - foreach my $p ('name','value','expires','domain','path') {
> - $cookie_param{'-'.$p} = $param{$p}; ## CGI::Cookie expects -param =>
> value
> - }
> -
> - if ($cookie_param{'-domain'} eq 'localhost') {
> - $cookie_param{'-domain'} = '';
> - }
> -
> - my $cookie = new CGI::Cookie(%cookie_param);
> -
> - ## Send cookie to the client
> - printf "Set-Cookie: %s\n", $cookie->as_string;
> -
> - return 1;
> -}
> -
> -
> -
> -# Sets an HTTP cookie to be sent to a SOAP client
> -# OBSOLETED: Use SympaSession::soap_cookie2().
> -sub set_cookie_soap {
> - my ($session_id,$http_domain,$expire) = @_ ;
> - my $cookie;
> - my $value;
> -
> - # WARNING : to check the cookie the SOAP services does not gives
> - # all the cookie, only it's value so we need ':'
> - $value = $session_id;
> -
> - ## With set-cookie2 max-age of 0 means removing the cookie
> - ## Maximum cookie lifetime is the session
> - $expire ||= 600; ## 10 minutes
> -
> - if ($http_domain eq 'localhost') {
> - $cookie = sprintf "%s=%s; Path=/; Max-Age=%s", 'sympa_session',
> $value, $expire;
> - }else {
> - $cookie = sprintf "%s=%s; Domain=%s; Path=/; Max-Age=%s",
> 'sympa_session', $value, $http_domain, $expire;;
> - }
> -
> - ## Return the cookie value
> - return $cookie;
> -}
> -
> -## returns Message Authentication Check code
> -sub get_mac {
> - my $email = shift ;
> - my $secret = shift ;
> - Sympa::Log::Syslog::do_log('debug3', "get_mac($email, $secret)");
> -
> - unless ($secret) {
> - Sympa::Log::Syslog::do_log('err', 'get_mac : failure missing
> server secret for cookie MD5 digest');
> - return undef;
> - }
> - unless ($email) {
> - Sympa::Log::Syslog::do_log('err', 'get_mac : failure missing
> email adresse or cookie MD5 digest');
> - return undef;
> - }
> -
> -
> -
> - my $md5 = new Digest::MD5;
> -
> - $md5->reset;
> - $md5->add($email.$secret);
> -
> - return substr( unpack("H*", $md5->digest) , -8 );
> -
> -}
> -
> -sub set_cookie_extern {
> - my ($secret,$http_domain,%alt_emails) = @_ ;
> - my $expiration;
> - my $cookie;
> - my $value;
> -
> - my @mails ;
> - foreach my $mail (keys %alt_emails) {
> - my $string = $mail.':'.$alt_emails{$mail};
> - push(@mails,$string);
> - }
> - my $emails = join(',',@mails);
> -
> - $value = sprintf '%s&%s',$emails,&get_mac($emails,$secret);
> -
> - if ($http_domain eq 'localhost') {
> - $http_domain="";
> - }
> -
> - $cookie = new CGI::Cookie (-name => 'sympa_altemails',
> - -value => $value,
> - -expires => '+1y',
> - -domain => $http_domain,
> - -path => '/'
> - );
> - ## Send cookie to the client
> - printf "Set-Cookie: %s\n", $cookie->as_string;
> - #Sympa::Log::Syslog::do_log('notice',"set_cookie_extern :
> %s",$cookie->as_string);
> - return 1;
> -}
> -
> -
> -
> -
> -###############################
> -# Subroutines to read cookies #
> -###############################
> -
> -## Generic subroutine to get a cookie value
> -sub generic_get_cookie {
> - my $http_cookie = shift;
> - my $cookie_name = shift;
> -
> - if ($http_cookie =~/\S+/g) {
> - my %cookies = parse CGI::Cookie($http_cookie);
> - foreach (keys %cookies) {
> - my $cookie = $cookies{$_};
> - next unless ($cookie->name eq $cookie_name);
> - return ($cookie->value);
> - }
> - }
> - return (undef);
> -}
> -
> -## Returns user information extracted from the cookie
> -sub check_cookie {
> - my $http_cookie = shift;
> - my $secret = shift;
> -
> - my $user = &generic_get_cookie($http_cookie, 'sympauser');
> -
> - my @values = split /:/, $user;
> - if ($#values >= 1) {
> - my ($email, $mac, $auth) = @values;
> - $auth ||= 'classic';
> -
> - ## Check the MAC
> - if (&get_mac($email,$secret) eq $mac) {
> - return ($email, $auth);
> - }
> - }
> -
> - return undef;
> -}
> -
> -sub check_cookie_extern {
> - my ($http_cookie,$secret,$user_email) = @_;
> -
> - my $extern_value = &generic_get_cookie($http_cookie,
> 'sympa_altemails');
> -
> - if ($extern_value =~ /^(\S+)&(\w+)$/) {
> - return undef unless (&get_mac($1,$secret) eq $2) ;
> -
> - my %alt_emails ;
> - foreach my $element (split(/,/,$1)){
> - my @array = split(/:/,$element);
> - $alt_emails{$array[0]} = $array[1];
> - }
> -
> - my $e = lc($user_email);
> - unless ($alt_emails{$e}) {
> - return undef;
> - }
> - return (\%alt_emails);
> - }
> - return undef
> -}
> -
> -1;
> -
> -
> -
> Deleted: trunk/wwsympa/wwslib.pm (10084 => 10085)
> --- trunk/wwsympa/wwslib.pm 2014-01-02 09:09:01 UTC (rev 10084)
> +++ trunk/wwsympa/wwslib.pm 2014-01-02 09:16:17 UTC (rev 10085)
> @@ -1,303 +0,0 @@
> -# wwslib.pm - This module includes functions used by wwsympa.fcgi
> -# RCS Identication ; $Revision$ ; $Date$
> -#
> -# Sympa - SYsteme de Multi-Postage Automatique
> -# Copyright (c) 1997, 1998, 1999, 2000, 2001 Comite Reseau des Universites
> -# Copyright (c) 1997,1998, 1999 Institut Pasteur & Christophe Wolfhugel
> -#
> -# This program is free software; you can redistribute it and/or modify
> -# it under the terms of the GNU General Public License as published by
> -# the Free Software Foundation; either version 2 of the License, or
> -# (at your option) any later version.
> -#
> -# This program is distributed in the hope that it will be useful,
> -# but WITHOUT ANY WARRANTY; without even the implied warranty of
> -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
> -# GNU General Public License for more details.
> -#
> -# You should have received a copy of the GNU General Public License
> -# along with this program. If not, see <http://www.gnu.org/licenses/>.
> -
> -package wwslib;
> -
> -use Log;
> -use Conf;
> -use Sympa::Constants;
> -
> -## No longer used: Use List->get_option_title().
> -%reception_mode = ('mail' => {'gettext_id' => 'standard (direct
> reception)'},
> - 'digest' => {'gettext_id' => 'digest MIME format'},
> - 'digestplain' => {'gettext_id' => 'digest plain text
> format'},
> - 'summary' => {'gettext_id' => 'summary mode'},
> - 'notice' => {'gettext_id' => 'notice mode'},
> - 'txt' => {'gettext_id' => 'text-only mode'},
> - 'html'=> {'gettext_id' => 'html-only mode'},
> - 'urlize' => {'gettext_id' => 'urlize mode'},
> - 'nomail' => {'gettext_id' => 'no mail (useful for
> vacations)'},
> - 'not_me' => {'gettext_id' => 'you do not receive your own
> posts'}
> - );
> -
> -## Cookie expiration periods with corresponding entry in NLS
> -%cookie_period = (0 => {'gettext_id' => "session"},
> - 10 => {'gettext_id' => "10 minutes"},
> - 30 => {'gettext_id' => "30 minutes"},
> - 60 => {'gettext_id' => "1 hour"},
> - 360 => {'gettext_id' => "6 hours"},
> - 1440 => {'gettext_id' => "1 day"},
> - 10800 => {'gettext_id' => "1 week"},
> - 43200 => {'gettext_id' => "30 days"});
> -
> -## No longer used: Use List->get_option_title().
> -%visibility_mode = ('noconceal' => {'gettext_id' => "listed in the list
> review page"},
> - 'conceal' => {'gettext_id' => "concealed"}
> - );
> -
> -## Filenames with corresponding entry in NLS set 15
> -%filenames = ('welcome.tt2' => {'gettext_id' => "welcome
> message"},
> - 'bye.tt2' => {'gettext_id' => "unsubscribe
> message"},
> - 'removed.tt2' => {'gettext_id' => "deletion
> message"},
> - 'message.footer' => {'gettext_id' => "message footer"},
> - 'message.header' => {'gettext_id' => "message header"},
> - 'remind.tt2' => {'gettext_id' => "remind message"},
> - 'reject.tt2' => {'gettext_id' => "editor rejection
> message"},
> - 'invite.tt2' => {'gettext_id' => "subscribing
> invitation message"},
> - 'helpfile.tt2' => {'gettext_id' => "help file"},
> - 'lists.tt2' => {'gettext_id' => "directory of
> lists"},
> - 'global_remind.tt2' => {'gettext_id' => "global remind
> message"},
> - 'summary.tt2' => {'gettext_id' => "summary
> message"},
> - 'info' => {'gettext_id' => "list
> description"},
> - 'homepage' => {'gettext_id' => "list homepage"},
> - 'create_list_request.tt2' => {'gettext_id' => "list creation
> request message"},
> - 'list_created.tt2' => {'gettext_id' => "list creation
> notification message"},
> - 'your_infected_msg.tt2' => {'gettext_id' => "virus infection
> message"},
> - 'list_aliases.tt2' => {'gettext_id' => "list aliases
> template"}
> - );
> -
> -%task_flavours = (
> - 'daily' => {'gettext_id' => 'daily' },
> - 'monthly' => {'gettext_id' => 'monthly' },
> - 'weekly' => {'gettext_id' => 'weekly' },
> - );
> -
> -## Defined in RFC 1893
> -%bounce_status = ('1.0' => 'Other address status',
> - '1.1' => 'Bad destination mailbox address',
> - '1.2' => 'Bad destination system address',
> - '1.3' => 'Bad destination mailbox address syntax',
> - '1.4' => 'Destination mailbox address ambiguous',
> - '1.5' => 'Destination mailbox address valid',
> - '1.6' => 'Mailbox has moved',
> - '1.7' => 'Bad sender\'s mailbox address syntax',
> - '1.8' => 'Bad sender\'s system address',
> - '2.0' => 'Other or undefined mailbox status',
> - '2.1' => 'Mailbox disabled, not accepting messages',
> - '2.2' => 'Mailbox full',
> - '2.3' => 'Message length exceeds administrative limit',
> - '2.4' => 'Mailing list expansion problem',
> - '3.0' => 'Other or undefined mail system status',
> - '3.1' => 'Mail system full',
> - '3.2' => 'System not accepting network messages',
> - '3.3' => 'System not capable of selected features',
> - '3.4' => 'Message too big for system',
> - '4.0' => 'Other or undefined network or routing status',
> - '4.1' => 'No answer from host',
> - '4.2' => 'Bad connection',
> - '4.3' => 'Routing server failure',
> - '4.4' => 'Unable to route',
> - '4.5' => 'Network congestion',
> - '4.6' => 'Routing loop detected',
> - '4.7' => 'Delivery time expired',
> - '5.0' => 'Other or undefined protocol status',
> - '5.1' => 'Invalid command',
> - '5.2' => 'Syntax error',
> - '5.3' => 'Too many recipients',
> - '5.4' => 'Invalid command arguments',
> - '5.5' => 'Wrong protocol version',
> - '6.0' => 'Other or undefined media error',
> - '6.1' => 'Media not supported',
> - '6.2' => 'Conversion required and prohibited',
> - '6.3' => 'Conversion required but not supported',
> - '6.4' => 'Conversion with loss performed',
> - '6.5' => 'Conversion failed',
> - '7.0' => 'Other or undefined security status',
> - '7.1' => 'Delivery not authorized, message refused',
> - '7.2' => 'Mailing list expansion prohibited',
> - '7.3' => 'Security conversion required but not possible',
> - '7.4' => 'Security features not supported',
> - '7.5' => 'Cryptographic failure',
> - '7.6' => 'Cryptographic algorithm not supported',
> - '7.7' => 'Message integrity failure');
> -
> -
> -
> -## if Crypt::CipherSaber installed store the cipher object
> -my $cipher;
> -
> -## Load WWSympa configuration file
> -##sub load_config
> -## MOVED: use Conf::load_wwsconf().
> -
> -## Load HTTPD MIME Types
> -sub load_mime_types {
> - my $types = {};
> -
> - @localisation = ('/etc/mime.types',
> '/usr/local/apache/conf/mime.types',
> - '/etc/httpd/conf/mime.types',Site->etc.'/mime.types');
> -
> - foreach my $loc (@localisation) {
> - next unless (-r $loc);
> -
> - unless(open (CONF, $loc)) {
> - Sympa::Log::Syslog::do_log('err',"load_mime_types: unable to open
> $loc");
> - return undef;
> - }
> - }
> -
> - while (<CONF>) {
> - next if /^\s*\#/;
> -
> - if (/^(\S+)\s+(.+)\s*$/i) {
> - my ($k, $v) = ($1, $2);
> -
> - my @extensions = split / /, $v;
> -
> - ## provides file extention, given the content-type
> - if ($#extensions >= 0) {
> - $types->{$k} = $extensions[0];
> - }
> -
> - foreach my $ext (@extensions) {
> - $types->{$ext} = $k;
> - }
> - next;
> - }
> - }
> -
> - close FILE;
> - return $types;
> -}
> -
> -## Returns user information extracted from the cookie
> -sub get_email_from_cookie {
> -# Sympa::Log::Syslog::do_log('debug', 'get_email_from_cookie');
> - my $cookie = shift;
> - my $secret = shift;
> -
> - my ($email, $auth) ;
> -
> - # Sympa::Log::Syslog::do_log('info',
> "get_email_from_cookie($cookie,$secret)");
> -
> - unless (defined $secret) {
> -
> &report::reject_report_web('intern','cookie_error',{},'','','',$robot);
> - Sympa::Log::Syslog::do_log('info', 'parameter cookie undefined,
> authentication failure');
> - }
> -
> - unless ($cookie) {
> -
> &report::reject_report_web('intern','cookie_error',$cookie,'get_email_from_cookie','','',$robot);
> - Sympa::Log::Syslog::do_log('info', ' cookie undefined, authentication
> failure');
> - }
> -
> - ($email, $auth) = &cookielib::check_cookie ($cookie, $secret);
> - unless ( $email) {
> - &report::reject_report_web('user','auth_failed',{},'');
> - Sympa::Log::Syslog::do_log('info', 'get_email_from_cookie: auth
> failed for user %s', $email);
> - return undef;
> - }
> -
> - return ($email, $auth);
> -}
> -
> -sub new_passwd {
> -
> - my $passwd;
> - my $nbchar = int(rand 5) + 6;
> - foreach my $i (0..$nbchar) {
> - $passwd .= chr(int(rand 26) + ord('a'));
> - }
> -
> - return 'init'.$passwd;
> -}
> -
> -## Basic check of an email address
> -sub valid_email {
> - my $email = shift;
> -
> - $email =~ /^([\w\-\_\.\/\+\=]+|\".*\")\@[\w\-]+(\.[\w\-]+)+$/;
> -}
> -
> -sub init_passwd {
> - my ($email, $data) = @_;
> -
> - my ($passwd, $user);
> -
> - if (User::is_global_user($email)) {
> - $user = User::get_global_user($email);
> -
> - $passwd = $user->{'password'};
> -
> - unless ($passwd) {
> - $passwd = &new_passwd();
> -
> - unless ( User::update_global_user($email,
> - {'password' => $passwd,
> - 'lang' => $user->{'lang'} ||
> $data->{'lang'}} )) {
> -
> &report::reject_report_web('intern','update_user_db_failed',{'user'=>$email},'','',$email,$robot);
> - Sympa::Log::Syslog::do_log('info','init_passwd: update
> failed');
> - return undef;
> - }
> - }
> - }else {
> - $passwd = &new_passwd();
> - unless ( User::add_global_user({'email' => $email,
> - 'password' => $passwd,
> - 'lang' => $data->{'lang'},
> - 'gecos' => $data->{'gecos'}})) {
> -
> &report::reject_report_web('intern','add_user_db_failed',{'user'=>$email},'','',$email,$robot);
> - Sympa::Log::Syslog::do_log('info','init_passwd: add failed');
> - return undef;
> - }
> - }
> -
> - return 1;
> -}
> -
> -sub get_my_url {
> -
> -
> - my $return_url;
> -
> - ## Mod_ssl sets SSL_PROTOCOL ; apache-ssl sets SSL_PROTOCOL_VERSION
> - if ($ENV{'HTTPS'} eq 'on') {
> - $return_url = 'https';
> - }else{
> - $return_url = 'http';
> - }
> -
> - $return_url .= '://'.&main::get_header_field('HTTP_HOST');
> - $return_url .= ':'.$ENV{'SERVER_PORT'} unless (($ENV{'SERVER_PORT'} eq
> '80')||($ENV{'SERVER_PORT'} eq '443'));
> - $return_url .= $ENV{'REQUEST_URI'};
> - return ($return_url);
> -}
> -
> -# Uploade source file to the destination on the server
> -sub upload_file_to_server {
> - my $param = shift;
> - Sympa::Log::Syslog::do_log('debug',"Uploading file from field %s to
> destination %s",$param->{'file_field'},$param->{'destination'});
> - my $fh;
> - unless ($fh = $param->{'query'}->upload($param->{'file_field'})) {
> - Sympa::Log::Syslog::do_log('debug',"Cannot upload file from field
> $param->{'file_field'}");
> - return undef;
> - }
> -
> - unless (open FILE, ">:bytes", $param->{'destination'}) {
> - Sympa::Log::Syslog::do_log('debug',"Cannot open file
> $param->{'destination'} : $!");
> - return undef;
> - }
> - while (<$fh>) {
> - print FILE;
> - }
> - close FILE;
> - return 1;
> -}
> -
> -1;

--
株式会社コンバージョンセキュリティ&OSSソリューション部池田荘児
〒231-0004　神奈川県横浜市中区元浜町3-21-2 ヘリオス関内ビル7F
e-mail address@concealed TEL 045-640-3550
http://www.conversion.co.jp/

Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory, IKEDA Soji, 01/02/2014
- Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory, IKEDA Soji, 01/02/2014
- Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory, Guillaume Rousse, 01/02/2014
  - Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory, IKEDA Soji, 01/02/2014
    - Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory, Guillaume Rousse, 01/02/2014

List archive

Re: [sympa-developpers] [sympa-commits] sympa[10085] trunk: [dev] move all perl modules in the same src/ lib directory