1# -*- indent-tabs-mode: nil; -*- 2# vim:ft=perl:et:sw=4 3# $Id$ 4 5# Sympa - SYsteme de Multi-Postage Automatique 6# 7# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel 8# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 9# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites 10# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER 11# Copyright 2017, 2018, 2019, 2020 The Sympa Community. See the AUTHORS.md 12# file at the top-level directory of this distribution and at 13# <https://github.com/sympa-community/sympa.git>. 14# 15# This program is free software; you can redistribute it and/or modify 16# it under the terms of the GNU General Public License as published by 17# the Free Software Foundation; either version 2 of the License, or 18# (at your option) any later version. 19# 20# This program is distributed in the hope that it will be useful, 21# but WITHOUT ANY WARRANTY; without even the implied warranty of 22# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 23# GNU General Public License for more details. 24# 25# You should have received a copy of the GNU General Public License 26# along with this program. If not, see <http://www.gnu.org/licenses/>. 27 28## Note to developers: 29## This corresponds to Sympa::ConfigurableObject (and Sympa::Site) package 30## in trunk. 31 32package Sympa; 33 34use strict; 35use warnings; 36#use Cwd qw(); 37use DateTime; 38use English qw(-no_match_vars); 39use Scalar::Util qw(); 40use URI; 41 42use Conf; 43use Sympa::Constants; 44use Sympa::Language; 45use Sympa::Log; 46use Sympa::Regexps; 47use Sympa::Spindle::ProcessTemplate; 48use Sympa::Tools::Text; 49 50my $log = Sympa::Log->instance; 51 52# Old name: List::compute_auth(). 53#DEPRECATED. Reusable auth key is no longer used. 54#sub compute_auth; 55 56# Old name: List::request_auth(). 57# DEPRECATED. Reusable auth keys are no longer used. 58#sub request_auth; 59 60# Old names: 61# [<=6.2a] tools::get_filename() 62# [6.2b] tools::search_fullpath() 63# [trunk] Sympa::ConfigurableObject::get_etc_filename() 64sub search_fullpath { 65 $log->syslog('debug3', '(%s, %s, %s)', @_); 66 my $that = shift; 67 my $name = shift; 68 my %options = @_; 69 70 my (@try, $default_name); 71 72 ## template refers to a language 73 ## => extend search to default tpls 74 ## FIXME: family path precedes to list path. Is it appropriate? 75 if ($name =~ /^(\S+)\.([^\s\/]+)\.tt2$/) { 76 $default_name = $1 . '.tt2'; 77 @try = 78 map { ($_ . '/' . $name, $_ . '/' . $default_name) } 79 @{Sympa::get_search_path($that, %options)}; 80 } else { 81 @try = 82 map { $_ . '/' . $name } 83 @{Sympa::get_search_path($that, %options)}; 84 } 85 86 my @result; 87 foreach my $f (@try) { 88 next unless -r $f; 89 $log->syslog('debug3', 'Name: %s; file %s', $name, $f); 90 91 if ($options{'order'} and $options{'order'} eq 'all') { 92 push @result, $f; 93 } else { 94 return $f; 95 } 96 } 97 if ($options{'order'} and $options{'order'} eq 'all') { 98 return @result; 99 } 100 101 return undef; 102} 103 104# Old names: 105# [<=6.2a] tools::make_tt2_include_path() 106# [6.2b] tools::get_search_path() 107# [trunk] Sympa::ConfigurableObject::get_etc_include_path() 108sub get_search_path { 109 $log->syslog('debug3', '(%s, %s, %s)', @_); 110 my $that = shift; 111 my %options = @_; 112 113 my $subdir = $options{'subdir'}; 114 my $lang = $options{'lang'}; 115 my $lang_only = $options{'lang_only'}; 116 117 ## Get language subdirectories. 118 my $lang_dirs; 119 if ($lang) { 120 ## For compatibility: add old-style "locale" directory at first. 121 ## Add lang itself and fallback directories. 122 $lang_dirs = [ 123 grep {$_} ( 124 Sympa::Language::lang2oldlocale($lang), 125 Sympa::Language::implicated_langs($lang) 126 ) 127 ]; 128 } 129 130 return [_get_search_path($that, $subdir, $lang_dirs, $lang_only)]; 131} 132 133sub _get_search_path { 134 my $that = shift; 135 my ($subdir, $lang_dirs, $lang_only) = @_; # shift is not used 136 137 my @search_path; 138 139 if (ref $that and ref $that eq 'Sympa::List') { 140 my $path_list; 141 my $path_family; 142 @search_path = _get_search_path($that->{'domain'}, @_); 143 144 if ($subdir) { 145 $path_list = $that->{'dir'} . '/' . $subdir; 146 } else { 147 $path_list = $that->{'dir'}; 148 } 149 if ($lang_dirs) { 150 unless ($lang_only) { 151 unshift @search_path, $path_list; 152 } 153 unshift @search_path, map { $path_list . '/' . $_ } @$lang_dirs; 154 } else { 155 unshift @search_path, $path_list; 156 } 157 158 if (defined $that->get_family) { 159 my $family = $that->get_family; 160 if ($subdir) { 161 $path_family = $family->{'dir'} . '/' . $subdir; 162 } else { 163 $path_family = $family->{'dir'}; 164 } 165 if ($lang_dirs) { 166 unless ($lang_only) { 167 unshift @search_path, $path_family; 168 } 169 unshift @search_path, 170 map { $path_family . '/' . $_ } @$lang_dirs; 171 } else { 172 unshift @search_path, $path_family; 173 } 174 } 175 } elsif (ref $that and ref $that eq 'Sympa::Family') { 176 my $path_family; 177 @search_path = _get_search_path($that->{'domain'}, @_); 178 179 if ($subdir) { 180 $path_family = $that->{'dir'} . '/' . $subdir; 181 } else { 182 $path_family = $that->{'dir'}; 183 } 184 if ($lang_dirs) { 185 unless ($lang_only) { 186 unshift @search_path, $path_family; 187 } 188 unshift @search_path, map { $path_family . '/' . $_ } @$lang_dirs; 189 } else { 190 unshift @search_path, $path_family; 191 } 192 } elsif (not ref $that and $that and $that ne '*') { # Robot 193 my $path_robot; 194 @search_path = _get_search_path('*', @_); 195 196 if ($subdir) { 197 $path_robot = $Conf::Conf{'etc'} . '/' . $that . '/' . $subdir; 198 } else { 199 $path_robot = $Conf::Conf{'etc'} . '/' . $that; 200 } 201 if (-d $path_robot) { 202 if ($lang_dirs) { 203 unless ($lang_only) { 204 unshift @search_path, $path_robot; 205 } 206 unshift @search_path, 207 map { $path_robot . '/' . $_ } @$lang_dirs; 208 } else { 209 unshift @search_path, $path_robot; 210 } 211 } 212 } elsif (not ref $that and $that eq '*') { # Site 213 my $path_etcbindir; 214 my $path_etcdir; 215 216 if ($subdir) { 217 $path_etcbindir = Sympa::Constants::DEFAULTDIR . '/' . $subdir; 218 $path_etcdir = $Conf::Conf{'etc'} . '/' . $subdir; 219 } else { 220 $path_etcbindir = Sympa::Constants::DEFAULTDIR; 221 $path_etcdir = $Conf::Conf{'etc'}; 222 } 223 if ($lang_dirs) { 224 unless ($lang_only) { 225 @search_path = ( 226 (map { $path_etcdir . '/' . $_ } @$lang_dirs), 227 $path_etcdir, 228 (map { $path_etcbindir . '/' . $_ } @$lang_dirs), 229 $path_etcbindir 230 ); 231 } else { 232 @search_path = ( 233 (map { $path_etcdir . '/' . $_ } @$lang_dirs), 234 (map { $path_etcbindir . '/' . $_ } @$lang_dirs) 235 ); 236 } 237 } else { 238 @search_path = ($path_etcdir, $path_etcbindir); 239 } 240 } else { 241 die 'bug in logic. Ask developer'; 242 } 243 244 return @search_path; 245} 246 247# Default diagnostic messages taken from IANA registry: 248# http://www.iana.org/assignments/smtp-enhanced-status-codes/ 249# They should be modified to fit in Sympa. 250my %diag_messages = ( 251 'default' => 'Other undefined Status', 252 # success 253 '2.1.5' => 'Destination address valid', 254 # no available family, dynamic list creation failed, etc. 255 '4.2.1' => 'Mailbox disabled, not accepting messages', 256 # no subscribers in dynamic list 257 '4.2.4' => 'Mailing list expansion problem', 258 # unknown list address 259 '5.1.1' => 'Bad destination mailbox address', 260 # unknown robot 261 '5.1.2' => 'Bad destination system address', 262 # too large 263 '5.2.3' => 'Message length exceeds administrative limit', 264 # no owners defined in list at all, no listmasters defined at all 265 '5.2.4' => 'Mailing list expansion problem', 266 # could not store message into spool or mailer 267 '5.3.0' => 'Other or undefined mail system status', 268 # misconfigured family list 269 '5.3.5' => 'System incorrectly configured', 270 # loop detected 271 '5.4.6' => 'Routing loop detected', 272 # message contains commands 273 '5.6.0' => 'Other or undefined media error', 274 # no command found in message 275 '5.6.1' => 'Media not supported', 276 # failed to personalize (merge_feature) 277 '5.6.5' => 'Conversion Failed', 278 # virus found 279 '5.7.0' => 'Other or undefined security status', 280 # message is not authorized and is rejected 281 '5.7.1' => 'Delivery not authorized, message refused', 282 # failed to re-encrypt decrypted message 283 '5.7.5' => 'Cryptographic failure', 284); 285 286# Old names: tools::send_dsn(), Sympa::ConfigurableObject::send_dsn(). 287sub send_dsn { 288 my $that = shift; 289 my $message = shift; 290 my $param = shift || {}; 291 my $status = shift; 292 my $diag = shift; 293 294 unless (Scalar::Util::blessed($message) 295 and $message->isa('Sympa::Message')) { 296 $log->syslog('err', 'object %s is not Message', $message); 297 return undef; 298 } 299 300 my $sender; 301 if (defined($sender = $message->{'envelope_sender'})) { 302 ## Won't reply to message with null envelope sender. 303 return 0 if $sender eq '<>'; 304 } elsif (!defined($sender = $message->{'sender'})) { 305 $log->syslog('err', 'No sender found'); 306 return undef; 307 } 308 309 $param->{listname} ||= $message->{localpart}; 310 if (ref $that eq 'Sympa::List') { 311 # List context 312 $param->{recipient} ||= 313 $param->{listname} . '@' . $that->{'domain'}; 314 $status ||= '5.1.1'; 315 316 if ($status eq '5.2.3') { 317 my $max_size = $that->{'admin'}{'max_size'}; 318 $param->{msg_size} = int($message->{'size'} / 1024); 319 $param->{max_size} = int($max_size / 1024); 320 } 321 } elsif (!ref $that and $that and $that ne '*') { 322 # Robot context 323 $param->{recipient} ||= 324 $param->{listname} . '@' . Conf::get_robot_conf($that, 'domain'); 325 $status ||= '5.1.1'; 326 } elsif ($that eq '*') { 327 # Site context 328 $param->{recipient} ||= 329 $param->{listname} . '@' . $Conf::Conf{'domain'}; 330 $status ||= '5.1.2'; 331 } else { 332 die 'bug in logic. Ask developer'; 333 } 334 335 # Diagnostic message. 336 $diag ||= $diag_messages{$status} || $diag_messages{'default'}; 337 # Delivery result, "failed" or "delivered". 338 my $action = (index($status, '2') == 0) ? 'delivered' : 'failed'; 339 340 # Attach original (not decrypted) content. 341 my $msg_string = $message->as_string(original => 1); 342 $msg_string =~ s/\AReturn-Path: (.*?)\n(?![ \t])//s; 343 my $header = 344 ($msg_string =~ /\A\r?\n/) 345 ? '' 346 : [split /(?<=\n)\r?\n/, $msg_string, 2]->[0]; 347 348 my $date = 349 (eval { DateTime->now(time_zone => 'local') } || DateTime->now) 350 ->strftime('%a, %{day} %b %Y %H:%M:%S %z'); 351 352 my $spindle = Sympa::Spindle::ProcessTemplate->new( 353 context => $that, 354 template => 'delivery_status_notification', 355 rcpt => $sender, 356 data => { 357 %$param, 358 'to' => $sender, 359 'date' => $date, 360 'msg' => $msg_string, 361 'header' => $header, 362 'auto_submitted' => 'auto-replied', 363 'action' => $action, 364 'status' => $status, 365 'diagnostic_code' => $diag, 366 }, 367 # Set envelope sender. DSN _must_ have null envelope sender. 368 envelope_sender => '<>', 369 ); 370 unless ($spindle and $spindle->spin and $spindle->{finish} eq 'success') { 371 $log->syslog('err', 'Unable to send DSN to %s', $sender); 372 return undef; 373 } 374 375 return 1; 376} 377 378# Old name: List::send_file() and List::send_global_file(). 379sub send_file { 380 $log->syslog('debug2', '(%s, %s, %s, ...)', @_); 381 my $that = shift; 382 my $tpl = shift; 383 my $who = shift; 384 my $context = shift || {}; 385 my %options = @_; 386 387 my $spindle = Sympa::Spindle::ProcessTemplate->new( 388 context => $that, 389 template => $tpl, 390 rcpt => $who, 391 data => $context, 392 %options 393 ); 394 unless ($spindle and $spindle->spin and $spindle->{finish} eq 'success') { 395 $log->syslog('err', 'Could not send template %s to %s', $tpl, $who); 396 return undef; 397 } 398 399 return 1; 400} 401 402# Old name: List::send_notify_to_listmaster() 403sub send_notify_to_listmaster { 404 $log->syslog('debug2', '(%s, %s, %s)', @_) unless $_[1] eq 'logs_failed'; 405 my $that = shift; 406 my $operation = shift; 407 my $data = shift; 408 409 my ($list, $robot_id); 410 if (ref $that eq 'Sympa::List') { 411 $list = $that; 412 $robot_id = $list->{'domain'}; 413 } elsif ($that and $that ne '*') { 414 $robot_id = $that; 415 } else { 416 $robot_id = '*'; 417 } 418 419 my @listmasters = Sympa::get_listmasters_email($that); 420 my $to = Sympa::get_address($robot_id, 'listmaster'); 421 422 if (ref $data ne 'HASH' and ref $data ne 'ARRAY') { 423 die 424 'Error on incoming parameter "$data", it must be a ref on HASH or a ref on ARRAY'; 425 } 426 427 if (ref $data ne 'HASH') { 428 my $d = {}; 429 foreach my $i ((0 .. $#{$data})) { 430 $d->{"param$i"} = $data->[$i]; 431 } 432 $data = $d; 433 } 434 435 $data->{'to'} = $to; 436 $data->{'type'} = $operation; 437 $data->{'auto_submitted'} = 'auto-generated'; 438 439 if ($operation eq 'no_db' or $operation eq 'db_restored') { 440 $data->{'db_name'} = Conf::get_robot_conf($robot_id, 'db_name'); 441 } 442 443 # When operation is either missing_dbd, no_db or db_restored, 444 # skip DB access because DB is not accessible. 445 my $spindle = Sympa::Spindle::ProcessTemplate->new( 446 context => $that, 447 template => 'listmaster_notification', 448 rcpt => [@listmasters], 449 data => $data, 450 451 splicing_to => ['Sympa::Spindle::ToListmaster'], 452 ); 453 unless ($spindle 454 and $spindle->spin 455 and $spindle->{finish} eq 'success') { 456 $log->syslog( 457 'notice', 458 'Unable to send template "listmaster_notification" to %s listmaster %s', 459 $robot_id, 460 join(', ', @listmasters), 461 ) unless $operation eq 'logs_failed'; 462 return undef; 463 } 464 465 return 1; 466} 467 468sub send_notify_to_user { 469 $log->syslog('debug2', '(%s, %s, %s, ...)', @_); 470 my $that = shift; 471 my $operation = shift; 472 my $user = shift; 473 my $param = shift || {}; 474 475 my ($list, $robot_id); 476 if (ref $that eq 'Sympa::List') { 477 $list = $that; 478 $robot_id = $list->{'domain'}; 479 } elsif ($that and $that ne '*') { 480 $robot_id = $that; 481 } else { 482 $robot_id = '*'; 483 } 484 485 $param->{'auto_submitted'} = 'auto-generated'; 486 487 die 'Missing parameter "operation"' unless $operation; 488 die 'missing parameter "user"' unless $user; 489 490 if (ref $param eq "HASH") { 491 $param->{'to'} = $user; 492 $param->{'type'} = $operation; 493 494 unless (Sympa::send_file($that, 'user_notification', $user, $param)) { 495 $log->syslog('notice', 496 'Unable to send template "user_notification" to %s', $user); 497 return undef; 498 } 499 } elsif (ref $param eq "ARRAY") { 500 my $data = { 501 'to' => $user, 502 'type' => $operation 503 }; 504 505 for my $i (0 .. $#{$param}) { 506 $data->{"param$i"} = $param->[$i]; 507 } 508 unless (Sympa::send_file($that, 'user_notification', $user, $data)) { 509 $log->syslog('notice', 510 'Unable to send template "user_notification" to %s', $user); 511 return undef; 512 } 513 } else { 514 $log->syslog( 515 'err', 516 'error on incoming parameter "%s", it must be a ref on HASH or a ref on ARRAY', 517 $param 518 ); 519 return undef; 520 } 521 return 1; 522} 523 524sub best_language { 525 my $that = shift; 526 my $accept_string = join ',', grep { $_ and $_ =~ /\S/ } @_; 527 $accept_string ||= $ENV{HTTP_ACCEPT_LANGUAGE} || '*'; 528 529 my @supported_languages; 530 my %supported_languages; 531 my @langs = (); 532 my $lang; 533 534 if (ref $that eq 'Sympa::List') { 535 @supported_languages = 536 Sympa::get_supported_languages($that->{'domain'}); 537 $lang = $that->{'admin'}{'lang'}; 538 } elsif (!ref $that) { 539 @supported_languages = Sympa::get_supported_languages($that || '*'); 540 $lang = Conf::get_robot_conf($that || '*', 'lang'); 541 } else { 542 die 'bug in logic. Ask developer'; 543 } 544 %supported_languages = map { $_ => 1 } @supported_languages; 545 push @langs, $lang 546 if $supported_languages{$lang}; 547 548 if (ref $that eq 'Sympa::List') { 549 my $lang = Conf::get_robot_conf($that->{'domain'}, 'lang'); 550 push @langs, $lang 551 if $supported_languages{$lang} and !grep { $_ eq $lang } @langs; 552 } 553 if (ref $that eq 'Sympa::List' or !ref $that and $that and $that ne '*') { 554 my $lang = $Conf::Conf{'lang'}; 555 push @langs, $lang 556 if $supported_languages{$lang} and !grep { $_ eq $lang } @langs; 557 } 558 foreach my $lang (@supported_languages) { 559 push @langs, $lang 560 if !grep { $_ eq $lang } @langs; 561 } 562 563 return Sympa::Language::negotiate_lang($accept_string, @langs) || $lang; 564} 565 566#FIXME: Inefficient. Would be cached. 567#FIXME: Would also accept Sympa::List object. 568# Old name: [trunk] Sympa::Site::supported_languages(). 569sub get_supported_languages { 570 my $robot = shift; 571 572 my @lang_list = (); 573 if (%Conf::Conf) { # configuration loaded. 574 my $supported_lang; 575 576 if ($robot and $robot ne '*') { 577 $supported_lang = Conf::get_robot_conf($robot, 'supported_lang'); 578 } else { 579 $supported_lang = $Conf::Conf{'supported_lang'}; 580 } 581 582 my $language = Sympa::Language->instance; 583 $language->push_lang; 584 @lang_list = 585 grep { $_ and $_ = $language->set_lang($_) } 586 split /[\s,]+/, $supported_lang; 587 $language->pop_lang; 588 } 589 @lang_list = ('en') unless @lang_list; 590 return @lang_list if wantarray; 591 return \@lang_list; 592} 593 594sub get_address { 595 my $that = shift || '*'; 596 my $type = shift || ''; 597 598 if (ref $that eq 'Sympa::List') { 599 unless ($type) { 600 return $that->{'name'} . '@' . $that->{'domain'}; 601 } elsif ($type eq 'owner') { 602 return $that->{'name'} . '-request' . '@' . $that->{'domain'}; 603 } elsif ($type eq 'editor') { 604 return $that->{'name'} . '-editor' . '@' . $that->{'domain'}; 605 } elsif ($type eq 'return_path') { 606 return $that->{'name'} 607 . Conf::get_robot_conf($that->{'domain'}, 608 'return_path_suffix') 609 . '@' 610 . $that->{'domain'}; 611 } elsif ($type eq 'subscribe') { 612 return $that->{'name'} . '-subscribe' . '@' . $that->{'domain'}; 613 } elsif ($type eq 'unsubscribe') { 614 return $that->{'name'} . '-unsubscribe' . '@' . $that->{'domain'}; 615 } elsif ($type eq 'sympa' 616 or $type eq 'sympaowner' 617 or $type eq 'listmaster') { 618 # robot address, for convenience. 619 return Sympa::get_address($that->{'domain'}, $type); 620 } 621 } elsif (ref $that eq 'Sympa::Family') { 622 # robot address, for convenience. 623 return Sympa::get_address($that->{'domain'}, $type); 624 } else { 625 unless ($type) { 626 return Conf::get_robot_conf($that, 'email') . '@' 627 . Conf::get_robot_conf($that, 'domain'); 628 } elsif ($type eq 'sympa') { # same as above, for convenience 629 return Conf::get_robot_conf($that, 'email') . '@' 630 . Conf::get_robot_conf($that, 'domain'); 631 } elsif ( 632 $type eq 'owner' or $type eq 'request' # for convenience 633 or $type eq 'sympaowner' 634 ) { 635 return 636 Conf::get_robot_conf($that, 'email') 637 . '-request' . '@' 638 . Conf::get_robot_conf($that, 'domain'); 639 } elsif ($type eq 'listmaster') { 640 return Conf::get_robot_conf($that, 'listmaster_email') . '@' 641 . Conf::get_robot_conf($that, 'domain'); 642 } elsif ($type eq 'return_path') { 643 return 644 Conf::get_robot_conf($that, 'email') 645 . Conf::get_robot_conf($that, 'return_path_suffix') . '@' 646 . Conf::get_robot_conf($that, 'domain'); 647 } 648 } 649 650 $log->syslog('err', 'Unknown type of address "%s" for %s', $type, $that); 651 return undef; 652} 653 654# Old names: 655# [6.2b] Conf::get_robot_conf(..., 'listmasters'), $Conf::Conf{'listmasters'}. 656# [trunk] Site::listmasters(). 657sub get_listmasters_email { 658 my $that = shift; 659 660 my $listmaster; 661 if (ref $that eq 'Sympa::List') { 662 $listmaster = Conf::get_robot_conf($that->{'domain'}, 'listmaster'); 663 } elsif (ref $that eq 'Sympa::Family') { 664 $listmaster = Conf::get_robot_conf($that->{'domain'}, 'listmaster'); 665 } elsif (not ref($that) and $that and $that ne '*') { 666 $listmaster = Conf::get_robot_conf($that, 'listmaster'); 667 } else { 668 $listmaster = Conf::get_robot_conf('*', 'listmaster'); 669 } 670 671 my @listmasters = 672 grep { Sympa::Tools::Text::valid_email($_) } split /\s*,\s*/, 673 $listmaster; 674 # If no valid adresses found, use listmaster of site config. 675 unless (@listmasters or (not ref $that and $that eq '*')) { 676 $log->syslog('notice', 'Warning: No listmasters found for %s', $that); 677 @listmasters = Sympa::get_listmasters_email('*'); 678 } 679 680 return wantarray ? @listmasters : [@listmasters]; 681} 682 683sub get_url { 684 my $that = shift; 685 my $action = shift; 686 my %options = @_; 687 688 my $robot_id = 689 (ref $that eq 'Sympa::List') ? $that->{'domain'} 690 : ($that and $that ne '*') ? $that 691 : '*'; 692 my $option_authority = $options{authority} || 'default'; 693 694 my $base; 695 if ($option_authority eq 'local') { 696 my $uri = URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url')); 697 698 # Override scheme. 699 if ($ENV{HTTPS} and $ENV{HTTPS} eq 'on') { 700 $uri->scheme('https'); 701 } 702 703 # Try authority locally given. 704 my ($host_port, $port); 705 my $hostport_re = Sympa::Regexps::hostport(); 706 my $ipv6_re = Sympa::Regexps::ipv6(); 707 unless ($host_port = $ENV{HTTP_HOST} 708 and $host_port =~ /\A$hostport_re\z/) { 709 # HTTP/1.0 or earlier? 710 $host_port = $ENV{SERVER_NAME}; 711 $port = $ENV{SERVER_PORT}; 712 } 713 if ($host_port) { 714 if ($host_port =~ /\A$ipv6_re\z/) { 715 # IPv6 address not enclosed. 716 $host_port = '[' . $host_port . ']'; 717 } 718 unless ($host_port =~ /:\d+\z/) { 719 $host_port .= ':' 720 . ($port ? $port : ($uri->scheme eq 'https') ? 443 : 80); 721 } 722 $uri->host_port($host_port); 723 } 724 725 # Override path with actual one. 726 if (my $path = $ENV{SCRIPT_NAME}) { 727 $uri->path($path); 728 } 729 730 $base = $uri->canonical->as_string; 731 } elsif ($option_authority eq 'omit') { 732 $base = 733 URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url'))->path; 734 } else { # 'default' 735 $base = Conf::get_robot_conf($robot_id, 'wwsympa_url'); 736 } 737 738 $base .= '/nomenu' if $options{nomenu}; 739 740 if (ref $that eq 'Sympa::List') { 741 $base .= '/' . ($action || 'info'); 742 return Sympa::Tools::Text::weburl($base, 743 [$that->{'name'}, @{$options{paths} || []}], %options); 744 } else { 745 $base .= '/' . $action if $action; 746 return Sympa::Tools::Text::weburl($base, $options{paths}, %options); 747 } 748} 749 750# Old names: [6.2b-6.2.3] Sympa::Robot::is_listmaster($who, $robot_id) 751sub is_listmaster { 752 my $that = shift; 753 my $who = Sympa::Tools::Text::canonic_email(shift); 754 755 return undef unless defined $who; 756 return 1 if grep { lc $_ eq $who } Sympa::get_listmasters_email($that); 757 return 1 if grep { lc $_ eq $who } Sympa::get_listmasters_email('*'); 758 return 0; 759} 760 761# Old name: tools::get_message_id(). 762sub unique_message_id { 763 my $that = shift; 764 765 my $domain; 766 if (ref $that eq 'Sympa::List') { 767 $domain = Conf::get_robot_conf($that->{'domain'}, 'domain'); 768 } elsif ($that and $that ne '*') { 769 $domain = Conf::get_robot_conf($that, 'domain'); 770 } else { 771 $domain = $Conf::Conf{'domain'}; 772 } 773 774 return sprintf '<sympa.%d.%d.%d@%s>', time, $PID, (int rand 999), $domain; 775} 776 7771; 778__END__ 779 780=encoding utf-8 781 782=head1 NAME 783 784Sympa - Future base class of Sympa functional objects 785 786=head1 DESCRIPTION 787 788This module aims to be the base class for functional objects of Sympa: 789Site, Robot, Family and List. 790 791=head2 Functions 792 793=head3 Finding config files and templates 794 795=over 4 796 797=item search_fullpath ( $that, $name, [ opt => val, ...] ) 798 799 # To get file name for global site 800 $file = Sympa::search_fullpath('*', $name); 801 # To get file name for a robot 802 $file = Sympa::search_fullpath($robot_id, $name); 803 # To get file name for a family 804 $file = Sympa::search_fullpath($family, $name); 805 # To get file name for a list 806 $file = Sympa::search_fullpath($list, $name); 807 808Look for a file in the list > robot > site > default locations. 809 810Possible values for options: 811 order => 'all' 812 subdir => directory ending each path 813 lang => language 814 lang_only => if paths without lang subdirectory would be omitted 815 816Returns full path of target file C<I<root>/I<subdir>/I<lang>/I<name>> 817or C<I<root>/I<subdir>/I<name>>. 818I<root> is the location determined by target object $that. 819I<subdir> and I<lang> are optional. 820If C<lang_only> option is set, paths without I<lang> subdirectory is omitted. 821 822=item get_search_path ( $that, [ opt => val, ... ] ) 823 824 # To make include path for global site 825 @path = @{Sympa::get_search_path('*')}; 826 # To make include path for a robot 827 @path = @{Sympa::get_search_path($robot_id)}; 828 # To make include path for a family 829 @path = @{Sympa::get_search_path($family)}; 830 # To make include path for a list 831 @path = @{Sympa::get_search_path($list)}; 832 833make an array of include path for tt2 parsing 834 835IN : 836 -$that(+) : ref(Sympa::List) | ref(Sympa::Family) | Robot | "*" 837 -%options : options 838 839Possible values for options: 840 subdir => directory ending each path 841 lang => language 842 lang_only => if paths without lang subdirectory would be omitted 843 844OUT : ref(ARRAY) of tt2 include path 845 846=begin comment 847 848Note: 849As of 6.2b, argument $lang is recommended to be IETF language tag, 850rather than locale name. 851 852=end comment 853 854=back 855 856=head3 Sending Notifications 857 858=over 4 859 860=item send_dsn ( $that, $message, 861[ { key => val, ... }, [ $status, [ $diag ] ] ] ) 862 863 # To send site-wide DSN 864 Sympa::send_dsn('*', $message, {'recipient' => $rcpt}, 865 '5.1.2', 'Unknown robot'); 866 # To send DSN related to a robot 867 Sympa::send_dsn($robot, $message, {'listname' => $name}, 868 '5.1.1', 'Unknown list'); 869 # To send DSN specific to a list 870 Sympa::send_dsn($list, $message, {}, '2.1.5', 'Success'); 871 872Sends a delivery status notification (DSN) to SENDER 873by parsing delivery_status_notification.tt2 template. 874 875=item send_file ( $that, $tpl, $who, [ $context, [ options... ] ] ) 876 877 # To send site-global (not relative to a list or a robot) 878 # message 879 Sympa::send_file('*', $template, $who, ...); 880 # To send global (not relative to a list, but relative to a 881 # robot) message 882 Sympa::send_file($robot, $template, $who, ...); 883 # To send message relative to a list 884 Sympa::send_file($list, $template, $who, ...); 885 886Send a message to user(s). 887Find the tt2 file according to $tpl, set up 888$data for the next parsing (with $context and 889configuration) 890Message is signed if the list has a key and a 891certificate 892 893Note: List::send_global_file() was deprecated. 894 895=item send_notify_to_listmaster ( $that, $operation, $data ) 896 897 # To send notify to super listmaster(s) 898 Sympa::send_notify_to_listmaster('*', 'css_updated', ...); 899 # To send notify to normal (per-robot) listmaster(s) 900 Sympa::send_notify_to_listmaster($robot, 'web_tt2_error', ...); 901 # To send notify to normal listmaster(s) of robot the list belongs to. 902 Sympa::send_notify_to_listmaster($list, 'request_list_creation', ...); 903 904Sends a notice to (super or normal) listmaster by parsing 905listmaster_notification.tt2 template. 906 907Parameters: 908 909=over 910 911=item $self 912 913L<Sympa::List>, Robot or Site. 914 915=item $operation 916 917Notification type. 918 919=item $param 920 921Hashref or arrayref. 922Values for template parsing. 923 924=back 925 926Returns: 927 928C<1> or C<undef>. 929 930=item send_notify_to_user ( $that, $operation, $user, $param ) 931 932Send a notice to a user (sender, subscriber or another user) 933by parsing user_notification.tt2 template. 934 935Parameters: 936 937=over 938 939=item $that 940 941L<Sympa::List>, Robot or Site. 942 943=item $operation 944 945Notification type. 946 947=item $user 948 949E-mail of notified user. 950 951=item $param 952 953Hashref or arrayref. Values for template parsing. 954 955=back 956 957Returns: 958 959C<1> or C<undef>. 960 961=back 962 963=head3 Internationalization 964 965=over 966 967=item best_language ( LANG, ... ) 968 969 # To get site-wide best language. 970 $lang = Sympa::best_language('*', 'de', 'en-US;q=0.9'); 971 # To get robot-wide best language. 972 $lang = Sympa::best_language($robot, 'de', 'en-US;q=0.9'); 973 # To get list-specific best language. 974 $lang = Sympa::best_language($list, 'de', 'en-US;q=0.9'); 975 976Chooses best language under the context of List, Robot or Site. 977Arguments are language codes (see L<Language>) or ones with quality value. 978If no arguments are given, the value of C<HTTP_ACCEPT_LANGUAGE> environment 979variable will be used. 980 981Returns language tag or, if negotiation failed, lang of object. 982 983=item get_supported_languages ( $that ) 984 985I<Function>. 986Gets supported languages, canonicalized. 987In array context, returns array of supported languages. 988In scalar context, returns arrayref to them. 989 990=back 991 992=head3 Addresses and users 993 994These are accessors derived from configuration parameters. 995 996=over 997 998=item get_address ( $that, [ $type ] ) 999 1000 # Get address bound for super listmaster(s). 1001 Sympa::get_address('*', 'listmaster'); # <listmaster@DEFAULT_HOST> 1002 # Get address for command robot and robot listmaster(s). 1003 Sympa::get_address($robot, 'sympa'); # <sympa@HOST> 1004 Sympa::get_address($robot, 'listmaster'); # <listmaster@HOST> 1005 # Get address for command robot and robot listmaster(s). 1006 Sympa::get_address($family, 'sympa'); # <sympa@HOST> 1007 Sympa::get_address($family, 'listmaster'); # listmaster@HOST> 1008 # Get address bound for the list and its owner(s) etc. 1009 Sympa::get_address($list); # <NAME@HOST> 1010 Sympa::get_address($list, 'owner'); # <NAME-request@HOST> 1011 Sympa::get_address($list, 'editor'); # <NAME-editor@HOST> 1012 Sympa::get_address($list, 'return_path'); # <NAME-owner@HOST> 1013 1014Site or robot: 1015Returns the site or robot email address of type $type: email command address 1016(default, <sympa> address), "sympaowner" (<sympa-request> address) or 1017"listmaster". 1018 1019List: 1020Returns the list email address of type $type: posting address (default), 1021"owner" (<LIST-request> address), "editor", non-VERP "return_path" 1022(<LIST-owner> address), "subscribe" or "unsubscribe". 1023 1024Note: 1025 1026=over 1027 1028=item * 1029 1030%Conf::Conf or Conf::get_robot_conf() may return <sympa> and 1031<sympa-request> addresses by "sympa" and "request" arguments, respectively. 1032They are obsoleted. Use this function instead. 1033 1034=item * 1035 1036C<"sympaowner"> with robot context was introduced on 6.2.57b.2. 1037C<"owner"> and C<"request"> may also be used for convenience. 1038 1039=back 1040 1041=item get_listmasters_email ( $that ) 1042 1043 # To get addresses of super-listmasters. 1044 @addrs = Sympa::get_listmasters_email('*'); 1045 # To get addresses of normal listmasters of a robot. 1046 @addrs = Sympa::get_listmasters_email($robot); 1047 # To get addresses of normal listmasters of the robot of a family. 1048 @addrs = Sympa::get_listmasters_email($family); 1049 # To get addresses of normal listmasters of the robot of a list. 1050 @addrs = Sympa::get_listmasters_email($list); 1051 1052Gets valid email addresses of listmasters. In array context, returns array of 1053addresses. In scalar context, returns arrayref to them. 1054 1055=item get_url ( $that, $action, [ nomenu =E<gt> 1 ], [ paths =E<gt> \@paths ], 1056[ authority =E<gt> $mode ], 1057[ options... ] ) 1058 1059Returns URL for web interface. 1060 1061Parameters: 1062 1063=over 1064 1065=item $action 1066 1067Name of action. 1068This is inserted into URL intact. 1069 1070=item authority =E<gt> $mode 1071 1072C<'default'> respects C<wwsympa_url> parameter. 1073C<'local'> is similar but may replace host name and script path. 1074C<'omit'> omits scheme and authority, i.e. returns relative URI. 1075 1076Note that C<'local'> mode works correctly only under CGI environment. 1077See also a note below. 1078 1079=item nomenu =E<gt> 1 1080 1081Adds C<nomenu> modifier. 1082 1083=item paths =E<gt> \@paths 1084 1085Additional path components. 1086Note that they are percent-encoded as necessity. 1087 1088=item options... 1089 1090See L<Sympa::Tools::Text/"weburl">. 1091 1092=back 1093 1094Returns: 1095 1096A string. 1097 1098Note: 1099If $mode is C<'local'>, result is that Sympa server recognizes locally. 1100In other cases, result is the URI that is used by end users to access to web 1101interface. 1102When, for example, the server is placed behind a reverse-proxy, 1103C<Location:> field in HTTP response to cause redirection would be better 1104to contain C<'local'> URI. 1105 1106=item is_listmaster ( $that, $who ) 1107 1108Is the user listmaster? 1109 1110=item unique_message_id ( $that ) 1111 1112TBD 1113 1114=back 1115 1116=head1 SEE ALSO 1117 1118L<Sympa::Site> (not yet available), 1119L<Sympa::Robot> (not yet available), 1120L<Sympa::Family>, 1121L<Sympa::List>. 1122 1123=cut 1124