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