# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4

# Sympa - SYsteme de Multi-Postage Automatique
#
# Copyright (c) 1997, 1998, 1999 Institut Pasteur & Christophe Wolfhugel
# Copyright (c) 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
# 2006, 2007, 2008, 2009, 2010, 2011 Comite Reseau des Universites
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
# Copyright 2017, 2018, 2019, 2020, 2021, 2022 The Sympa Community. See the
# AUTHORS.md file at the top-level directory of this distribution and at
# <https://github.com/sympa-community/sympa.git>.
#
# 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/>.

## Note to developers:
## This corresponds to Sympa::ConfigurableObject (and Sympa::Site) package
## in trunk.

package Sympa;

use strict;
use warnings;
#use Cwd qw();
use DateTime;
use English qw(-no_match_vars);
use Scalar::Util qw();
use URI;

use Conf;
use Sympa::Constants;
use Sympa::Language;
use Sympa::Log;
use Sympa::Regexps;
use Sympa::Spindle::ProcessTemplate;
use Sympa::Tools::Text;
use Sympa::Tools::Time;

my $log = Sympa::Log->instance;

# Old name: List::compute_auth().
#DEPRECATED.  Reusable auth key is no longer used.
#sub compute_auth;

# Old name: List::request_auth().
# DEPRECATED.  Reusable auth keys are no longer used.
#sub request_auth;

# Old names:
# [<=6.2a] tools::get_filename()
# [6.2b] tools::search_fullpath()
# [trunk] Sympa::ConfigurableObject::get_etc_filename()
sub search_fullpath {
    $log->syslog('debug3', '(%s, %s, %s)', @_);
    my $that    = shift;
    my $name    = shift;
    my %options = @_;

    my (@try, $default_name);

    ## template refers to a language
    ## => extend search to default tpls
    ## FIXME: family path precedes to list path.  Is it appropriate?
    if ($name =~ /^(\S+)\.([^\s\/]+)\.tt2$/) {
        $default_name = $1 . '.tt2';
        @try =
            map { ($_ . '/' . $name, $_ . '/' . $default_name) }
            @{Sympa::get_search_path($that, %options)};
    } else {
        @try =
            map { $_ . '/' . $name }
            @{Sympa::get_search_path($that, %options)};
    }

    my @result;
    foreach my $f (@try) {
        next unless -r $f;
        $log->syslog('debug3', 'Name: %s; file %s', $name, $f);

        if ($options{'order'} and $options{'order'} eq 'all') {
            push @result, $f;
        } else {
            return $f;
        }
    }
    if ($options{'order'} and $options{'order'} eq 'all') {
        return @result;
    }

    return undef;
}

# Old names:
# [<=6.2a] tools::make_tt2_include_path()
# [6.2b] tools::get_search_path()
# [trunk] Sympa::ConfigurableObject::get_etc_include_path()
sub get_search_path {
    $log->syslog('debug3', '(%s, %s, %s)', @_);
    my $that    = shift;
    my %options = @_;

    my $subdir    = $options{'subdir'};
    my $lang      = $options{'lang'};
    my $lang_only = $options{'lang_only'};

    ## Get language subdirectories.
    my $lang_dirs;
    if ($lang) {
        ## For compatibility: add old-style "locale" directory at first.
        ## Add lang itself and fallback directories.
        $lang_dirs = [
            grep {$_} (
                Sympa::Language::lang2oldlocale($lang),
                Sympa::Language::implicated_langs($lang)
            )
        ];
    }

    return [_get_search_path($that, $subdir, $lang_dirs, $lang_only)];
}

sub _get_search_path {
    my $that = shift;
    my ($subdir, $lang_dirs, $lang_only) = @_;    # shift is not used

    my @search_path;

    if (ref $that and ref $that eq 'Sympa::List') {
        my $path_list;
        my $path_family;
        @search_path = _get_search_path($that->{'domain'}, @_);

        if ($subdir) {
            $path_list = $that->{'dir'} . '/' . $subdir;
        } else {
            $path_list = $that->{'dir'};
        }
        if ($lang_dirs) {
            unless ($lang_only) {
                unshift @search_path, $path_list;
            }
            unshift @search_path, map { $path_list . '/' . $_ } @$lang_dirs;
        } else {
            unshift @search_path, $path_list;
        }

        if (defined $that->get_family) {
            my $family = $that->get_family;
            if ($subdir) {
                $path_family = $family->{'dir'} . '/' . $subdir;
            } else {
                $path_family = $family->{'dir'};
            }
            if ($lang_dirs) {
                unless ($lang_only) {
                    unshift @search_path, $path_family;
                }
                unshift @search_path,
                    map { $path_family . '/' . $_ } @$lang_dirs;
            } else {
                unshift @search_path, $path_family;
            }
        }
    } elsif (ref $that and ref $that eq 'Sympa::Family') {
        my $path_family;
        @search_path = _get_search_path($that->{'domain'}, @_);

        if ($subdir) {
            $path_family = $that->{'dir'} . '/' . $subdir;
        } else {
            $path_family = $that->{'dir'};
        }
        if ($lang_dirs) {
            unless ($lang_only) {
                unshift @search_path, $path_family;
            }
            unshift @search_path, map { $path_family . '/' . $_ } @$lang_dirs;
        } else {
            unshift @search_path, $path_family;
        }
    } elsif (not ref $that and $that and $that ne '*') {    # Robot
        my $path_robot;
        @search_path = _get_search_path('*', @_);

        if ($subdir) {
            $path_robot = $Conf::Conf{'etc'} . '/' . $that . '/' . $subdir;
        } else {
            $path_robot = $Conf::Conf{'etc'} . '/' . $that;
        }
        if (-d $path_robot) {
            if ($lang_dirs) {
                unless ($lang_only) {
                    unshift @search_path, $path_robot;
                }
                unshift @search_path,
                    map { $path_robot . '/' . $_ } @$lang_dirs;
            } else {
                unshift @search_path, $path_robot;
            }
        }
    } elsif (not ref $that and $that eq '*') {    # Site
        my $path_etcbindir;
        my $path_etcdir;

        if ($subdir) {
            $path_etcbindir = Sympa::Constants::DEFAULTDIR . '/' . $subdir;
            $path_etcdir    = $Conf::Conf{'etc'} . '/' . $subdir;
        } else {
            $path_etcbindir = Sympa::Constants::DEFAULTDIR;
            $path_etcdir    = $Conf::Conf{'etc'};
        }
        if ($lang_dirs) {
            unless ($lang_only) {
                @search_path = (
                    (map { $path_etcdir . '/' . $_ } @$lang_dirs),
                    $path_etcdir,
                    (map { $path_etcbindir . '/' . $_ } @$lang_dirs),
                    $path_etcbindir
                );
            } else {
                @search_path = (
                    (map { $path_etcdir . '/' . $_ } @$lang_dirs),
                    (map { $path_etcbindir . '/' . $_ } @$lang_dirs)
                );
            }
        } else {
            @search_path = ($path_etcdir, $path_etcbindir);
        }
    } else {
        die 'bug in logic.  Ask developer';
    }

    return @search_path;
}

# Default diagnostic messages taken from IANA registry:
# http://www.iana.org/assignments/smtp-enhanced-status-codes/
# They should be modified to fit in Sympa.
my %diag_messages = (
    'default' => 'Other undefined Status',

    # Destination address valid
    # [Sympa] held message was distributed by moderator
    '2.1.5' => 'Message was successfully delivered',

    # Other or undefined mail system status
    # [Sympa] forwarded to moderators
    '2.3.0' => 'Message has been forwarded to the list moderator(s)',

    # Mailbox disabled, not accepting messages
    # [Sympa] no available family, dynamic list creation failed, etc.
    '4.2.1' => 'List could not be created',

    # Mailing list expansion problem
    # [Sympa] no subscribers in dynamic list
    '4.2.4' => 'List does not exist',

    # Other or undefined mail system status
    # [Sympa] held for moderation
    # Currently 2.3.0 is used instead. See GH issue #1699.
    '4.3.0' => 'Message has been forwarded to the list moderator(s)',

    # Bad destination mailbox address
    # [Sympa] unknown list in existing mail domain
    '5.1.1' => 'List does not exist',

    # Bad destination system address
    # [Sympa] unknown mail domain
    '5.1.2' => 'List does not exist',

    # Message length exceeds administrative limit
    '5.2.3' =>
        'Message could not be sent because its size was over the maximum size allowed on the list',

    # Mailing list expansion problem
    # [Sympa] no owners defined in list at all, no listmasters defined at all
    '5.2.4' =>
        'Impossible to forward message because of an internal server error',

    # Other or undefined mail system status
    # [Sympa] could not store message into spool or mailer
    '5.3.0' =>
        'Impossible to distribute message because of an internal server error',

    # System incorrectly configured
    # [Sympa] misconfigured family list
    '5.3.5' => 'List could not be created',

    # Routing loop detected
    # [Sympa] loop detected FIXME:Not really used.
    '5.4.6' => 'Loop detected',

    # Other or undefined media error
    # [Sympa] message contains commands
    '5.6.0' => 'Message contains a line that can be interpreted as a command',

    # Media not supported
    # [Sympa] no command found in message
    '5.6.1' => 'No command found in message',

    # Conversion Failed
    # [Sympa] failed to personalize the message
    '5.6.5' => 'Message cannot be personalized',

    # Other or undefined security status
    # [Sympa] virus found
    '5.7.0' => 'A virus in your mail',

    # Delivery not authorized, message refused
    # [Sympa] message is not authorized and is rejected
    '5.7.1' => 'You are not allowed to send this message',

    # Cryptographic failure
    # [Sympa] failed to re-encrypt decrypted message FIXME:Not yet used
    '5.7.5' => 'Failed to encrypt message',
);

# Old names: tools::send_dsn(), Sympa::ConfigurableObject::send_dsn().
sub send_dsn {
    my $that    = shift;
    my $message = shift;
    my $param   = shift || {};
    my $status  = shift;
    my $diag    = shift;

    unless (Scalar::Util::blessed($message)
        and $message->isa('Sympa::Message')) {
        $log->syslog('err', 'object %s is not Message', $message);
        return undef;
    }

    my $sender;
    if (defined($sender = $message->{'envelope_sender'})) {
        ## Won't reply to message with null envelope sender.
        return 0 if $sender eq '<>';
    } elsif (!defined($sender = $message->{'sender'})) {
        $log->syslog('err', 'No sender found');
        return undef;
    }

    $param->{listname} ||= $message->{localpart};
    if (ref $that eq 'Sympa::List') {
        # List context
        $param->{recipient} ||=
            $param->{listname} . '@' . $that->{'domain'};
        $status ||= '5.1.1';

        if ($status eq '5.2.3') {
            my $max_size = $that->{'admin'}{'max_size'};
            $param->{msg_size} = int($message->{'size'} / 1024);
            $param->{max_size} = int($max_size / 1024);
        }
    } elsif (!ref $that and $that and $that ne '*') {
        # Robot context
        $param->{recipient} ||=
            $param->{listname} . '@' . Conf::get_robot_conf($that, 'domain');
        $status ||= '5.1.1';
    } elsif ($that eq '*') {
        # Site context
        $param->{recipient} ||=
            $param->{listname} . '@' . $Conf::Conf{'domain'};
        $status ||= '5.1.2';
    } else {
        die 'bug in logic.  Ask developer';
    }

    # Diagnostic message.
    $diag ||= $diag_messages{$status} || $diag_messages{'default'};
    # Delivery result, "failed" or "delivered".
    my $action =
          ($status eq '4.3.0') ? 'delayed'
        : (0 == index $status, '2') ? 'delivered'
        :                             'failed';

    # Attach original (not decrypted) content.
    my $msg_string = $message->as_string(original => 1);
    $msg_string =~ s/\AReturn-Path: (.*?)\n(?![ \t])//s;
    my $header =
        ($msg_string =~ /\A\r?\n/)
        ? ''
        : [split /(?<=\n)\r?\n/, $msg_string, 2]->[0];

    my $date =
        (eval { DateTime->now(time_zone => 'local') } || DateTime->now)
        ->strftime('%a, %{day} %b %Y %H:%M:%S %z');

    my $spindle = Sympa::Spindle::ProcessTemplate->new(
        context  => $that,
        template => 'delivery_status_notification',
        rcpt     => $sender,
        data     => {
            %$param,
            'to'              => $sender,
            'date'            => $date,
            'msg'             => $msg_string,
            'header'          => $header,
            'auto_submitted'  => 'auto-replied',
            'action'          => $action,
            'status'          => $status,
            'diagnostic_code' => $diag,
        },
        # Set envelope sender.  DSN _must_ have null envelope sender.
        envelope_sender => '<>',
    );
    unless ($spindle and $spindle->spin and $spindle->{finish} eq 'success') {
        $log->syslog('err', 'Unable to send DSN to %s', $sender);
        return undef;
    }

    return 1;
}

# Old name: List::send_file() and List::send_global_file().
sub send_file {
    $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
    my $that    = shift;
    my $tpl     = shift;
    my $who     = shift;
    my $context = shift || {};
    my %options = @_;

    my $spindle = Sympa::Spindle::ProcessTemplate->new(
        context  => $that,
        template => $tpl,
        rcpt     => $who,
        data     => $context,
        %options
    );
    unless ($spindle and $spindle->spin and $spindle->{finish} eq 'success') {
        $log->syslog('err', 'Could not send template %s to %s', $tpl, $who);
        return undef;
    }

    return 1;
}

# Old name: List::send_notify_to_listmaster()
sub send_notify_to_listmaster {
    $log->syslog('debug2', '(%s, %s, %s)', @_) unless $_[1] eq 'logs_failed';
    my $that      = shift;
    my $operation = shift;
    my $data      = shift;

    my ($list, $robot_id);
    if (ref $that eq 'Sympa::List') {
        $list     = $that;
        $robot_id = $list->{'domain'};
    } elsif ($that and $that ne '*') {
        $robot_id = $that;
    } else {
        $robot_id = '*';
    }

    my @listmasters = Sympa::get_listmasters_email($that);
    my $to = Sympa::get_address($robot_id, 'listmaster');

    if (ref $data ne 'HASH' and ref $data ne 'ARRAY') {
        die
            'Error on incoming parameter "$data", it must be a ref on HASH or a ref on ARRAY';
    }

    if (ref $data ne 'HASH') {
        my $d = {};
        foreach my $i ((0 .. $#{$data})) {
            $d->{"param$i"} = $data->[$i];
        }
        $data = $d;
    }

    $data->{'to'}             = $to;
    $data->{'type'}           = $operation;
    $data->{'auto_submitted'} = 'auto-generated';

    if ($operation eq 'no_db' or $operation eq 'db_restored') {
        $data->{'db_name'} = Conf::get_robot_conf($robot_id, 'db_name');
    }

    # When operation is either missing_dbd, no_db or db_restored,
    # skip DB access because DB is not accessible.
    my $spindle = Sympa::Spindle::ProcessTemplate->new(
        context  => $that,
        template => 'listmaster_notification',
        rcpt     => [@listmasters],
        data     => $data,

        splicing_to => ['Sympa::Spindle::ToListmaster'],
    );
    unless ($spindle
        and $spindle->spin
        and $spindle->{finish} eq 'success') {
        $log->syslog(
            'notice',
            'Unable to send template "listmaster_notification" to %s listmaster %s',
            $robot_id,
            join(', ', @listmasters),
        ) unless $operation eq 'logs_failed';
        return undef;
    }

    return 1;
}

sub send_notify_to_user {
    $log->syslog('debug2', '(%s, %s, %s, ...)', @_);
    my $that      = shift;
    my $operation = shift;
    my $user      = shift;
    my $param     = shift || {};

    my ($list, $robot_id);
    if (ref $that eq 'Sympa::List') {
        $list     = $that;
        $robot_id = $list->{'domain'};
    } elsif ($that and $that ne '*') {
        $robot_id = $that;
    } else {
        $robot_id = '*';
    }

    $param->{'auto_submitted'} = 'auto-generated';

    die 'Missing parameter "operation"' unless $operation;
    die 'missing parameter "user"'      unless $user;

    if (ref $param eq "HASH") {
        $param->{'to'}   = $user;
        $param->{'type'} = $operation;

        unless (Sympa::send_file($that, 'user_notification', $user, $param)) {
            $log->syslog('notice',
                'Unable to send template "user_notification" to %s', $user);
            return undef;
        }
    } elsif (ref $param eq "ARRAY") {
        my $data = {
            'to'   => $user,
            'type' => $operation
        };

        for my $i (0 .. $#{$param}) {
            $data->{"param$i"} = $param->[$i];
        }
        unless (Sympa::send_file($that, 'user_notification', $user, $data)) {
            $log->syslog('notice',
                'Unable to send template "user_notification" to %s', $user);
            return undef;
        }
    } else {
        $log->syslog(
            'err',
            'error on incoming parameter "%s", it must be a ref on HASH or a ref on ARRAY',
            $param
        );
        return undef;
    }
    return 1;
}

sub best_language {
    my $that = shift;
    my $accept_string = join ',', grep { $_ and $_ =~ /\S/ } @_;
    $accept_string ||= $ENV{HTTP_ACCEPT_LANGUAGE} || '*';

    my @supported_languages;
    my %supported_languages;
    my @langs = ();
    my $lang;

    if (ref $that eq 'Sympa::List') {
        @supported_languages =
            Sympa::get_supported_languages($that->{'domain'});
        $lang = $that->{'admin'}{'lang'};
    } elsif (!ref $that) {
        @supported_languages = Sympa::get_supported_languages($that || '*');
        $lang = Conf::get_robot_conf($that || '*', 'lang');
    } else {
        die 'bug in logic.  Ask developer';
    }
    %supported_languages = map { $_ => 1 } @supported_languages;
    push @langs, $lang
        if $supported_languages{$lang};

    if (ref $that eq 'Sympa::List') {
        my $lang = Conf::get_robot_conf($that->{'domain'}, 'lang');
        push @langs, $lang
            if $supported_languages{$lang} and !grep { $_ eq $lang } @langs;
    }
    if (ref $that eq 'Sympa::List' or !ref $that and $that and $that ne '*') {
        my $lang = $Conf::Conf{'lang'};
        push @langs, $lang
            if $supported_languages{$lang} and !grep { $_ eq $lang } @langs;
    }
    foreach my $lang (@supported_languages) {
        push @langs, $lang
            if !grep { $_ eq $lang } @langs;
    }

    return Sympa::Language::negotiate_lang($accept_string, @langs) || $lang;
}

#FIXME: Inefficient.  Would be cached.
#FIXME: Would also accept Sympa::List object.
# Old name: [trunk] Sympa::Site::supported_languages().
sub get_supported_languages {
    my $robot = shift;

    my @lang_list = ();
    if (%Conf::Conf) {    # configuration loaded.
        my $supported_lang;

        if ($robot and $robot ne '*') {
            $supported_lang = Conf::get_robot_conf($robot, 'supported_lang');
        } else {
            $supported_lang = $Conf::Conf{'supported_lang'};
        }

        my $language = Sympa::Language->instance;
        $language->push_lang;
        @lang_list =
            grep { $_ and $_ = $language->set_lang($_) }
            split /[\s,]+/, $supported_lang;
        $language->pop_lang;
    }
    @lang_list = ('en') unless @lang_list;
    return @lang_list if wantarray;
    return \@lang_list;
}

sub get_address {
    my $that = shift || '*';
    my $type = shift || '';

    if (ref $that eq 'Sympa::List') {
        unless ($type) {
            return $that->{'name'} . '@' . $that->{'domain'};
        } elsif ($type eq 'owner') {
            return $that->{'name'} . '-request' . '@' . $that->{'domain'};
        } elsif ($type eq 'editor') {
            return $that->{'name'} . '-editor' . '@' . $that->{'domain'};
        } elsif ($type eq 'return_path') {
            return $that->{'name'}
                . Conf::get_robot_conf($that->{'domain'},
                'return_path_suffix')
                . '@'
                . $that->{'domain'};
        } elsif ($type eq 'subscribe') {
            return $that->{'name'} . '-subscribe' . '@' . $that->{'domain'};
        } elsif ($type eq 'unsubscribe') {
            return $that->{'name'} . '-unsubscribe' . '@' . $that->{'domain'};
        } elsif ($type eq 'sympa'
            or $type eq 'sympaowner'
            or $type eq 'listmaster') {
            # robot address, for convenience.
            return Sympa::get_address($that->{'domain'}, $type);
        }
    } elsif (ref $that eq 'Sympa::Family') {
        # robot address, for convenience.
        return Sympa::get_address($that->{'domain'}, $type);
    } else {
        unless ($type) {
            return Conf::get_robot_conf($that, 'email') . '@'
                . Conf::get_robot_conf($that, 'domain');
        } elsif ($type eq 'sympa') {    # same as above, for convenience
            return Conf::get_robot_conf($that, 'email') . '@'
                . Conf::get_robot_conf($that, 'domain');
        } elsif (
            $type eq 'owner' or $type eq 'request'    # for convenience
            or $type eq 'sympaowner'
        ) {
            return
                  Conf::get_robot_conf($that, 'email')
                . '-request' . '@'
                . Conf::get_robot_conf($that, 'domain');
        } elsif ($type eq 'listmaster') {
            return Conf::get_robot_conf($that, 'listmaster_email') . '@'
                . Conf::get_robot_conf($that, 'domain');
        } elsif ($type eq 'return_path') {
            return
                  Conf::get_robot_conf($that, 'email')
                . Conf::get_robot_conf($that, 'return_path_suffix') . '@'
                . Conf::get_robot_conf($that, 'domain');
        }
    }

    $log->syslog('err', 'Unknown type of address "%s" for %s', $type, $that);
    return undef;
}

# Old names:
# [6.2b] Conf::get_robot_conf(..., 'listmasters'), $Conf::Conf{'listmasters'}.
# [trunk] Site::listmasters().
sub get_listmasters_email {
    my $that = shift;

    my $listmaster;
    if (ref $that eq 'Sympa::List') {
        $listmaster = Conf::get_robot_conf($that->{'domain'}, 'listmaster');
    } elsif (ref $that eq 'Sympa::Family') {
        $listmaster = Conf::get_robot_conf($that->{'domain'}, 'listmaster');
    } elsif (not ref($that) and $that and $that ne '*') {
        $listmaster = Conf::get_robot_conf($that, 'listmaster');
    } else {
        $listmaster = Conf::get_robot_conf('*', 'listmaster');
    }

    my @listmasters =
        map  { Sympa::Tools::Text::canonic_email($_) }
        grep { Sympa::Tools::Text::valid_email($_) } split /\s*,\s*/,
        $listmaster;
    # If no valid addresses found, use listmaster of site config.
    unless (@listmasters or (not ref $that and $that eq '*')) {
        $log->syslog('notice', 'Warning: No listmasters found for %s', $that);
        @listmasters = Sympa::get_listmasters_email('*');
    }

    return wantarray ? @listmasters : [@listmasters];
}

sub get_url {
    my $that    = shift;
    my $action  = shift;
    my %options = @_;

    my $robot_id =
          (ref $that eq 'Sympa::List') ? $that->{'domain'}
        : ($that and $that ne '*') ? $that
        :                            '*';
    my $option_authority = $options{authority} || 'default';

    my $base;
    if ($option_authority eq 'local') {
        my $uri = URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url'));

        # Override scheme.
        if ($ENV{HTTPS} and $ENV{HTTPS} eq 'on') {
            $uri->scheme('https');
        }

        # Try authority locally given.
        my ($host_port, $port);
        my $hostport_re = Sympa::Regexps::hostport();
        my $ipv6_re     = Sympa::Regexps::ipv6();
        unless ($host_port = $ENV{HTTP_HOST}
            and $host_port =~ /\A$hostport_re\z/) {
            # HTTP/1.0 or earlier?
            $host_port = $ENV{SERVER_NAME};
            $port      = $ENV{SERVER_PORT};
        }
        if ($host_port) {
            if ($host_port =~ /\A$ipv6_re\z/) {
                # IPv6 address not enclosed.
                $host_port = '[' . $host_port . ']';
            }
            unless ($host_port =~ /:\d+\z/) {
                $host_port .= ':'
                    . ($port ? $port : ($uri->scheme eq 'https') ? 443 : 80);
            }
            $uri->host_port($host_port);
        }

        # Override path with actual one.
        if (my $path = $ENV{SCRIPT_NAME}) {
            $uri->path($path);
        }

        $base = $uri->canonical->as_string;
    } elsif ($option_authority eq 'omit') {
        $base =
            URI->new(Conf::get_robot_conf($robot_id, 'wwsympa_url'))->path;
    } else {    # 'default'
        $base = Conf::get_robot_conf($robot_id, 'wwsympa_url');
    }

    $base .= '/nomenu' if $options{nomenu};

    if (ref $that eq 'Sympa::List') {
        $base .= '/' . ($action || 'info');
        return Sympa::Tools::Text::weburl($base,
            [$that->{'name'}, @{$options{paths} || []}], %options);
    } else {
        $base .= '/' . $action if $action;
        return Sympa::Tools::Text::weburl($base, $options{paths}, %options);
    }
}

# Old names: [6.2b-6.2.3] Sympa::Robot::is_listmaster($who, $robot_id)
sub is_listmaster {
    my $that = shift;
    my $who  = Sympa::Tools::Text::canonic_email(shift);

    return undef unless defined $who;
    return 1 if grep { $_ eq $who } Sympa::get_listmasters_email($that);
    return 1 if grep { $_ eq $who } Sympa::get_listmasters_email('*');
    return 0;
}

# Old name: tools::get_message_id().
#
# Note:
# The boundary of multipart message is generated based on this function
# and its length, 2 octets longer, should be limited up to 70 octets
# (See RFC 2046, 5.1.1). So as of 6.2.74, the length of the domain part will
# be limited.  See also GH #1795.
sub unique_message_id {
    my $that = shift;

    my $domain =
          (ref $that eq 'Sympa::List') ? $that->{'domain'}
        : ($that and $that ne '*') ? $that
        :                            $Conf::Conf{'domain'};

    my ($time, $usec) = Sympa::Tools::Time::gettimeofday();
    my $base32 = sprintf '%s%s%s%s',
        _base32($time, 35), _base32($usec, 20), _base32($PID, 35),
        _base32(int(rand 1023), 10);

    return sprintf '<sympa.%s@%s>', $base32, substr $domain, -39;
}

my @base32_alphabets = split '', '0123456789ABCDEFGHJKMNPQRSTVWXYZ';

sub _base32 {
    my $dec = shift;
    my $prc = shift;

    # Convert a (possiblly signed) decimal $dec to binary in $prc bits
    # then encode it in base32.
    my $vec = substr sprintf("%0${prc}b", $dec), -$prc;
    return $vec =~ s/([01]{5})/$base32_alphabets[oct "0b$1"]/egr;
}

1;
__END__

=encoding utf-8

=head1 NAME

Sympa - Future base class of Sympa functional objects

=head1 DESCRIPTION

This module aims to be the base class for functional objects of Sympa:
Site, Robot, Family and List.

=head2 Functions

=head3 Finding config files and templates

=over 4

=item search_fullpath ( $that, $name, [ opt => val, ...] )

    # To get file name for global site
    $file = Sympa::search_fullpath('*', $name);
    # To get file name for a robot
    $file = Sympa::search_fullpath($robot_id, $name);
    # To get file name for a family
    $file = Sympa::search_fullpath($family, $name);
    # To get file name for a list
    $file = Sympa::search_fullpath($list, $name);

Look for a file in the list > robot > site > default locations.

Possible values for options:
    order     => 'all'
    subdir    => directory ending each path
    lang      => language
    lang_only => if paths without lang subdirectory would be omitted

Returns full path of target file C<I<root>/I<subdir>/I<lang>/I<name>>
or C<I<root>/I<subdir>/I<name>>.
I<root> is the location determined by target object $that.
I<subdir> and I<lang> are optional.
If C<lang_only> option is set, paths without I<lang> subdirectory is omitted.

=item get_search_path ( $that, [ opt => val, ... ] )

    # To make include path for global site
    @path = @{Sympa::get_search_path('*')};
    # To make include path for a robot
    @path = @{Sympa::get_search_path($robot_id)};
    # To make include path for a family
    @path = @{Sympa::get_search_path($family)};
    # To make include path for a list
    @path = @{Sympa::get_search_path($list)};

make an array of include path for tt2 parsing

IN :
      -$that(+) : ref(Sympa::List) | ref(Sympa::Family) | Robot | "*"
      -%options : options

Possible values for options:
    subdir    => directory ending each path
    lang      => language
    lang_only => if paths without lang subdirectory would be omitted

OUT : ref(ARRAY) of tt2 include path

=begin comment

Note:
As of 6.2b, argument $lang is recommended to be IETF language tag,
rather than locale name.

=end comment

=back

=head3 Sending Notifications

=over 4

=item send_dsn ( $that, $message,
[ { key => val, ... }, [ $status, [ $diag ] ] ] )

    # To send site-wide DSN
    Sympa::send_dsn('*', $message, {'recipient' => $rcpt},
        '5.1.2', 'Unknown robot');
    # To send DSN related to a robot
    Sympa::send_dsn($robot, $message, {'listname' => $name},
        '5.1.1', 'Unknown list');
    # To send DSN specific to a list
    Sympa::send_dsn($list, $message, {}, '2.1.5', 'Success');

Sends a delivery status notification (DSN) to SENDER
by parsing delivery_status_notification.tt2 template.

=item send_file ( $that, $tpl, $who, [ $context, [ options... ] ] )

    # To send site-global (not relative to a list or a robot)
    # message
    Sympa::send_file('*', $template, $who, ...);
    # To send global (not relative to a list, but relative to a
    # robot) message
    Sympa::send_file($robot, $template, $who, ...);
    # To send message relative to a list
    Sympa::send_file($list, $template, $who, ...);

Send a message to user(s).
Find the tt2 file according to $tpl, set up
$data for the next parsing (with $context and
configuration)
Message is signed if the list has a key and a
certificate

Note: List::send_global_file() was deprecated.

=item send_notify_to_listmaster ( $that, $operation, $data )

    # To send notify to super listmaster(s)
    Sympa::send_notify_to_listmaster('*', 'css_updated', ...);
    # To send notify to normal (per-robot) listmaster(s)
    Sympa::send_notify_to_listmaster($robot, 'web_tt2_error', ...);
    # To send notify to normal listmaster(s) of robot the list belongs to.
    Sympa::send_notify_to_listmaster($list, 'request_list_creation', ...);

Sends a notice to (super or normal) listmaster by parsing
listmaster_notification.tt2 template.

Parameters:

=over

=item $self

L<Sympa::List>, Robot or Site.

=item $operation

Notification type.

=item $param

Hashref or arrayref.
Values for template parsing.

=back

Returns:

C<1> or C<undef>.

=item send_notify_to_user ( $that, $operation, $user, $param )

Send a notice to a user (sender, subscriber or another user)
by parsing user_notification.tt2 template.

Parameters:

=over

=item $that

L<Sympa::List>, Robot or Site.

=item $operation

Notification type.

=item $user

E-mail of notified user.

=item $param

Hashref or arrayref.  Values for template parsing.

=back

Returns:

C<1> or C<undef>.

=back

=head3 Internationalization

=over

=item best_language ( LANG, ... )

    # To get site-wide best language.
    $lang = Sympa::best_language('*', 'de', 'en-US;q=0.9');
    # To get robot-wide best language.
    $lang = Sympa::best_language($robot, 'de', 'en-US;q=0.9');
    # To get list-specific best language.
    $lang = Sympa::best_language($list, 'de', 'en-US;q=0.9');

Chooses best language under the context of List, Robot or Site.
Arguments are language codes (see L<Language>) or ones with quality value.
If no arguments are given, the value of C<HTTP_ACCEPT_LANGUAGE> environment
variable will be used.

Returns language tag or, if negotiation failed, lang of object.

=item get_supported_languages ( $that )

I<Function>.
Gets supported languages, canonicalized.
In array context, returns array of supported languages.
In scalar context, returns arrayref to them.

=back

=head3 Addresses and users

These are accessors derived from configuration parameters.

=over

=item get_address ( $that, [ $type ] )

    # Get address bound for super listmaster(s).
    Sympa::get_address('*', 'listmaster');     # <listmaster@DEFAULT_HOST>
    # Get address for command robot and robot listmaster(s).
    Sympa::get_address($robot, 'sympa');       # <sympa@HOST>
    Sympa::get_address($robot, 'listmaster');  # <listmaster@HOST>
    # Get address for command robot and robot listmaster(s).
    Sympa::get_address($family, 'sympa');      # <sympa@HOST>
    Sympa::get_address($family, 'listmaster'); # listmaster@HOST>
    # Get address bound for the list and its owner(s) etc.
    Sympa::get_address($list);                 # <NAME@HOST>
    Sympa::get_address($list, 'owner');        # <NAME-request@HOST>
    Sympa::get_address($list, 'editor');       # <NAME-editor@HOST>
    Sympa::get_address($list, 'return_path');  # <NAME-owner@HOST>

Site or robot:
Returns the site or robot email address of type $type: email command address
(default, <sympa> address), "sympaowner" (<sympa-request> address) or
"listmaster".

List:
Returns the list email address of type $type: posting address (default),
"owner" (<LIST-request> address), "editor", non-VERP "return_path"
(<LIST-owner> address), "subscribe" or "unsubscribe".

Note:

=over

=item *

%Conf::Conf or Conf::get_robot_conf() may return <sympa> and
<sympa-request> addresses by "sympa" and "request" arguments, respectively.
They are obsoleted.  Use this function instead.

=item *

C<"sympaowner"> with robot context was introduced on 6.2.57b.2.
C<"owner"> and C<"request"> may also be used for convenience.

=back

=item get_listmasters_email ( $that )

    # To get addresses of super-listmasters.
    @addrs = Sympa::get_listmasters_email('*');
    # To get addresses of normal listmasters of a robot.
    @addrs = Sympa::get_listmasters_email($robot);
    # To get addresses of normal listmasters of the robot of a family.
    @addrs = Sympa::get_listmasters_email($family);
    # To get addresses of normal listmasters of the robot of a list.
    @addrs = Sympa::get_listmasters_email($list);

Gets valid email addresses of listmasters. In array context, returns array of
addresses. In scalar context, returns arrayref to them.

=item get_url ( $that, $action, [ nomenu =E<gt> 1 ], [ paths =E<gt> \@paths ],
[ authority =E<gt> $mode ],
[ options... ] )

Returns URL for web interface.

Parameters:

=over

=item $action

Name of action.
This is inserted into URL intact.

=item authority =E<gt> $mode

C<'default'> respects C<wwsympa_url> parameter.
C<'local'> is similar but may replace host name and script path.
C<'omit'> omits scheme and authority, i.e. returns relative URI.

Note that C<'local'> mode works correctly only under CGI environment.
See also a note below.

=item nomenu =E<gt> 1

Adds C<nomenu> modifier.

=item paths =E<gt> \@paths

Additional path components.
Note that they are percent-encoded as necessity.

=item options...

See L<Sympa::Tools::Text/"weburl">.

=back

Returns:

A string.

Note:
If $mode is C<'local'>, result is that Sympa server recognizes locally.
In other cases, result is the URI that is used by end users to access to web
interface.
When, for example, the server is placed behind a reverse-proxy,
C<Location:> field in HTTP response to cause redirection would be better
to contain C<'local'> URI.

=item is_listmaster ( $that, $who )

Is the user listmaster?

=item unique_message_id ( $that )

Generates a unique message ID enclosed by C<E<lt>> and C<E<gt>>,
then returns it.

=back

=head1 SEE ALSO

L<Sympa::Site> (not yet available),
L<Sympa::Robot> (not yet available),
L<Sympa::Family>,
L<Sympa::List>.

=cut
