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, 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
28package Sympa::WWW::Tools;
29
30use strict;
31use warnings;
32use Digest::MD5;
33use English qw(-no_match_vars);
34use File::Path qw();
35use URI;
36use URI::Escape qw();
37
38use Sympa;
39use Conf;
40use Sympa::ConfDef;
41use Sympa::Constants;
42use Sympa::Language;
43use Sympa::List;
44use Sympa::LockedFile;
45use Sympa::Log;
46use Sympa::Regexps;
47use Sympa::Template;
48use Sympa::Tools::File;
49use Sympa::Tools::Text;
50
51my $log = Sympa::Log->instance;
52
53## Cookie expiration periods with corresponding entry in NLS
54our %cookie_period = (
55    0     => {'gettext_id' => "session"},
56    10    => {'gettext_id' => "10 minutes"},
57    30    => {'gettext_id' => "30 minutes"},
58    60    => {'gettext_id' => "1 hour"},
59    360   => {'gettext_id' => "6 hours"},
60    1440  => {'gettext_id' => "1 day"},
61    10800 => {'gettext_id' => "1 week"},
62    43200 => {'gettext_id' => "30 days"}
63);
64
65# File names with corresponding entry in NLS set
66our %filenames = (
67    'welcome.tt2'       => {'gettext_id' => "welcome message"},
68    'bye.tt2'           => {'gettext_id' => "unsubscribe message"},
69    'removed.tt2'       => {'gettext_id' => "deletion message"},
70    'message_header'    => {'gettext_id' => "message header"},
71    'message_footer'    => {'gettext_id' => "message footer"},
72    'remind.tt2'        => {'gettext_id' => "remind message"},
73    'reject.tt2'        => {'gettext_id' => "moderator rejection message"},
74    'invite.tt2'        => {'gettext_id' => "subscribing invitation message"},
75    'helpfile.tt2'      => {'gettext_id' => "help file"},
76    'lists.tt2'         => {'gettext_id' => "directory of lists"},
77    'global_remind.tt2' => {'gettext_id' => "global reminder message"},
78    'summary.tt2'       => {'gettext_id' => "summary message"},
79    'info'              => {'gettext_id' => "list description"},
80    'homepage'          => {'gettext_id' => "list homepage"},
81    'create_list_request.tt2' =>
82        {'gettext_id' => "list creation request message"},
83    'list_created.tt2' =>
84        {'gettext_id' => "list creation notification message"},
85    'your_infected_msg.tt2' => {'gettext_id' => "virus infection message"},
86    'list_aliases.tt2'      => {'gettext_id' => "list aliases template"}
87);
88
89# Taken from IANA registry:
90# <http://www.iana.org/assignments/smtp-enhanced-status-codes>
91our %bounce_status = (
92    '0.0'  => 'Other undefined Status',
93    '1.0'  => 'Other address status',
94    '1.1'  => 'Bad destination mailbox address',
95    '1.2'  => 'Bad destination system address',
96    '1.3'  => 'Bad destination mailbox address syntax',
97    '1.4'  => 'Destination mailbox address ambiguous',
98    '1.5'  => 'Destination address valid',
99    '1.6'  => 'Destination mailbox has moved, No forwarding address',
100    '1.7'  => 'Bad sender\'s mailbox address syntax',
101    '1.8'  => 'Bad sender\'s system address',
102    '1.9'  => 'Message relayed to non-compliant mailer',
103    '1.10' => 'Recipient address has null MX',
104    '2.0'  => 'Other or undefined mailbox status',
105    '2.1'  => 'Mailbox disabled, not accepting messages',
106    '2.2'  => 'Mailbox full',
107    '2.3'  => 'Message length exceeds administrative limit',
108    '2.4'  => 'Mailing list expansion problem',
109    '3.0'  => 'Other or undefined mail system status',
110    '3.1'  => 'Mail system full',
111    '3.2'  => 'System not accepting network messages',
112    '3.3'  => 'System not capable of selected features',
113    '3.4'  => 'Message too big for system',
114    '3.5'  => 'System incorrectly configured',
115    '3.6'  => 'Requested priority was changed',
116    '4.0'  => 'Other or undefined network or routing status',
117    '4.1'  => 'No answer from host',
118    '4.2'  => 'Bad connection',
119    '4.3'  => 'Directory server failure',
120    '4.4'  => 'Unable to route',
121    '4.5'  => 'Mail system congestion',
122    '4.6'  => 'Routing loop detected',
123    '4.7'  => 'Delivery time expired',
124    '5.0'  => 'Other or undefined protocol status',
125    '5.1'  => 'Invalid command',
126    '5.2'  => 'Syntax error',
127    '5.3'  => 'Too many recipients',
128    '5.4'  => 'Invalid command arguments',
129    '5.5'  => 'Wrong protocol version',
130    '5.6'  => 'Authentication Exchange line is too long',
131    '6.0'  => 'Other or undefined media error',
132    '6.1'  => 'Media not supported',
133    '6.2'  => 'Conversion required and prohibited',
134    '6.3'  => 'Conversion required but not supported',
135    '6.4'  => 'Conversion with loss performed',
136    '6.5'  => 'Conversion Failed',
137    '6.6'  => 'Message content not available',
138    '6.7'  => 'Non-ASCII addresses not permitted for that sender/recipient',
139    '6.8' =>
140        'UTF-8 string reply is required, but not permitted by the SMTP client',
141    '6.9' =>
142        'UTF-8 header message cannot be transferred to one or more recipients, so the message must be rejected',
143    #'6.10' => '',    # Duplicate of 6.8, deprecated.
144    '7.0'  => 'Other or undefined security status',
145    '7.1'  => 'Delivery not authorized, message refused',
146    '7.2'  => 'Mailing list expansion prohibited',
147    '7.3'  => 'Security conversion required but not possible',
148    '7.4'  => 'Security features not supported',
149    '7.5'  => 'Cryptographic failure',
150    '7.6'  => 'Cryptographic algorithm not supported',
151    '7.7'  => 'Message integrity failure',
152    '7.8'  => 'Authentication credentials invalid',
153    '7.9'  => 'Authentication mechanism is too weak',
154    '7.10' => 'Encryption Needed',
155    '7.11' => 'Encryption required for requested authentication mechanism',
156    '7.12' => 'A password transition is needed',
157    '7.13' => 'User Account Disabled',
158    '7.14' => 'Trust relationship required',
159    '7.15' => 'Priority Level is too low',
160    '7.16' => 'Message is too big for the specified priority',
161    '7.17' => 'Mailbox owner has changed',
162    '7.18' => 'Domain owner has changed',
163    '7.19' => 'RRVS test cannot be completed',
164    '7.20' => 'No passing DKIM signature found',
165    '7.21' => 'No acceptable DKIM signature found',
166    '7.22' => 'No valid author-matched DKIM signature found',
167    '7.23' => 'SPF validation failed',
168    '7.24' => 'SPF validation error',
169    '7.25' => 'Reverse DNS validation failed',
170    '7.26' => 'Multiple authentication checks failed',
171    '7.27' => 'Sender address has null MX',
172);
173
174## Load WWSympa configuration file
175##sub load_config
176## MOVED: use Conf::_load_wwsconf().
177
178## Load HTTPD MIME Types
179# Moved to Conf::_load_mime_types().
180#sub load_mime_types();
181
182## Returns user information extracted from the cookie
183# Deprecated.  Use Sympa::WWW::Session->new etc.
184#sub get_email_from_cookie;
185
186# NO LONGER USED.
187#sub new_passwd;
188
189## Basic check of an email address
190# DUPLICATE: Use Sympa::Tools::Text::valid_email().
191#sub valid_email($email);
192
193# 6.2b: added $robot parameter.
194# DEPRECATED.  No longer used.
195#sub init_passwd;
196
197# NOTE: As of 6.2.15, by default, less trustworthy "X-Forwarded-Host:" request
198# field is not referred and this function returns host name and path
199# respecting wwsympa_url robot parameter.  To change this behavior, use
200# "authority" option (See Sympa::get_url()).
201sub get_my_url {
202    my $robot   = shift;
203    my %options = @_;
204
205    my $path_info    = $ENV{PATH_INFO} // '';
206    my $query_string = $ENV{QUERY_STRING} // '';
207
208    return
209          Sympa::get_url($robot, undef, authority => $options{authority})
210        . Sympa::Tools::Text::encode_uri($path_info, omit => '/')
211        . (length $query_string ? '?' : '')
212        . $query_string;
213}
214
215# Determine robot.
216sub get_robot {
217    my @keys = @_;
218
219    # Get host part of script-URI from standard CGI environment variable
220    # SERVER_NAME.
221    # NOTE: As of 6.2.15, less trustworthy "X-Forwarded-Server:" request field
222    # is _no longer_ referred and this function returns only locally detected
223    # server name.
224    my $request_host = lc($ENV{SERVER_NAME} // '');
225    return unless length $request_host;
226    my $ipv6_re = Sympa::Regexps::ipv6();
227    if ($request_host =~ /\A$ipv6_re\z/) {    # IPv6 address
228        $request_host = sprintf '[%s]', $request_host;
229    }
230
231    # Since CGI of some HTTP servers might split script-path and extra-path of
232    # script-URI inproperly, we'd be better to reconstruct them from these
233    # standard CGI environment variables:
234    #   - SCRIPT_NAME: a URI path which could identify the CGI script.
235    #   - PATH_INFO: derived from the portion of the URI path hierarchy
236    #     following the part that identifies the script itself.
237    # Note that they are not URL-encoded, unlike non-standard REQUEST_URI.
238    my $org_script_name = $ENV{SCRIPT_NAME} // '';
239    my $org_path_info   = $ENV{PATH_INFO} // '';
240    return unless '' eq $org_script_name or 0 == index $org_script_name, '/';
241    return unless '' eq $org_path_info   or 0 == index $org_path_info,   '/';
242    my $request_path = $org_script_name . $org_path_info;
243
244    # Find mail domain (a.k.a. "robot") of which web URL matches script-URI.
245    my ($robot_id, $script_path) = (undef, undef);
246    foreach my $rid (Sympa::List::get_robots()) {
247        my $local_url;
248        foreach my $key (@keys) {
249            $local_url = Conf::get_robot_conf($rid, $key);
250            last if $local_url;
251        }
252        next unless $local_url;
253
254        if ($local_url =~ m{\A[-+\w]+:}) {
255            ;
256        } elsif ($local_url =~ m{\A//}) {
257            $local_url = 'http:' . $local_url;
258        } else {
259            $local_url = 'http://' . $local_url;
260        }
261
262        my $uri = URI->new($local_url);
263        next
264            unless $uri
265            and $uri->scheme
266            and grep { $uri->scheme eq $_ } qw(http https);
267
268        my $host = lc URI::Escape::uri_unescape($uri->host // '');
269        my $path = URI::Escape::uri_unescape($uri->path // '');
270        next unless $request_host eq $host;
271        next
272            unless $request_path eq $path
273            or 0 == index $request_path, $path . '/';
274
275        # The longest path wins.
276        ($robot_id, $script_path) = ($rid, $path)
277            if not defined $script_path
278            or length $script_path < length $path;
279    }
280
281    return unless $robot_id;
282    return
283        wantarray
284        ? ($robot_id, $script_path, substr $request_path, length $script_path)
285        : $robot_id;
286}
287
288# Old name: (part of) get_header_field() in wwsympa.fcgi.
289# No longer used.
290#sub _get_server_name;
291
292# Old name: (part of) get_header_field() in wwsympa.fcgi.
293# NOTE: As of 6.2.15, less trustworthy "X-Forwarded-Host:" request field is
294# _no longer_ referred and this function returns only locally detected host
295# information.
296sub get_http_host {
297    my ($host, $port);
298
299    my $hostport_re = Sympa::Regexps::hostport();
300    my $ipv6_re     = Sympa::Regexps::ipv6();
301    unless ($host = $ENV{HTTP_HOST} and $host =~ /\A$hostport_re\z/) {
302        $host = $ENV{SERVER_NAME};
303        $port = $ENV{SERVER_PORT};
304    }
305    return undef unless $host;
306
307    if ($host =~ /\A$ipv6_re\z/) {    # IPv6 address
308        $host = "[$host]";
309    }
310    unless ($host =~ /:\d+\z/) {
311        $host = "$host:$port" if $port;
312    }
313
314    return lc $host;
315}
316
317# Determin cookie domain.
318sub get_cookie_domain {
319    my $robot = shift;
320
321    # In case HTTP_HOST does not match cookie_domain, use former.
322    # N.B. As of 6.2.15, the cookie domain will match with the host name
323    # locally detected by server.  If remotely detected name should be differ,
324    # the proxy must adjust it.
325    my $cookie_domain = Conf::get_robot_conf($robot, 'cookie_domain');
326    my $http_host = Sympa::WWW::Tools::get_http_host() || '';
327    $http_host =~ s/:\d+\z//;    # Suppress port.
328    my $dotdom = lc $cookie_domain;
329    $dotdom =~ s/\A(?![.])/./;
330
331    unless (substr($http_host, -length($dotdom)) eq $dotdom
332        or ".$http_host" eq $dotdom
333        or $cookie_domain eq 'localhost') {
334        $log->syslog('debug',
335            '(%s) Does NOT match HTTP_HOST; setting cookie_domain to %s',
336            $cookie_domain, $http_host);
337        return $http_host;
338    }
339
340    return $cookie_domain;
341}
342
343# Uploade source file to the destination on the server
344# DEPRECATED.  No longer used.
345#sub upload_file_to_server;
346
347# DEPRECATED: No longer used.
348#sub no_slash_end;
349
350# DEPRECATED: No longer used.
351#sub make_visible_path;
352
353## returns a mailto according to list spam protection parameter
354# DEPRECATED.  Use [%|mailto()%] and [%|obfuscate()%] filters in template.
355#sub mailto;
356
357# DEPRECATED: No longer used.
358#sub find_edit_mode;
359
360# DEPRECATED: No longer used.
361#sub merge_edit;
362
363# Moved: Use Sympa::WWW::SharedDocument::_load_desc_file().
364#sub get_desc_file;
365
366# DEPRECATED: No longer used.
367#sub get_directory_content;
368
369# DEPRECATED: No longer used (a subroutine of get_directory_content()).
370#sub select_my_files;
371
372# Moved to Sympa::WWW::SharedDocument::_get_icon().
373#sub get_icon;
374
375# Moved to: Conf::get_mime_type().
376#sub get_mime_type;
377
378## return a hash from the edit_list_conf file
379# Old name: tools::load_create_list_conf().
380sub _load_create_list_conf {
381    my $robot = shift;
382
383    my $file;
384    my $conf;
385
386    $file = Sympa::search_fullpath($robot, 'create_list.conf');
387    unless ($file) {
388        $log->syslog(
389            'info',
390            'Unable to read %s',
391            Sympa::Constants::DEFAULTDIR . '/create_list.conf'
392        );
393        return undef;
394    }
395
396    unless (open(FILE, $file)) {
397        $log->syslog('info', 'Unable to open config file %s', $file);
398        return undef;
399    }
400
401    while (<FILE>) {
402        next if /^\s*(\#.*|\s*)$/;
403
404        if (/^\s*(\S+)\s+(read|hidden)\s*$/i) {
405            $conf->{$1} = lc($2);
406        } else {
407            $log->syslog(
408                'info',
409                'Unknown parameter in %s (Ignored) %s',
410                "$Conf::Conf{'etc'}/create_list.conf", $_
411            );
412            next;
413        }
414    }
415
416    close FILE;
417    return $conf;
418}
419
420# Old name: tools::get_list_list_tpl().
421sub get_list_list_tpl {
422    my $robot = shift;
423
424    my $language = Sympa::Language->instance;
425
426    my $list_conf;
427    my $list_templates;
428    unless ($list_conf = _load_create_list_conf($robot)) {
429        return undef;
430    }
431
432    my %tpl_names;
433    foreach my $directory (
434        @{  Sympa::get_search_path(
435                $robot,
436                subdir => 'create_list_templates',
437                lang   => $language->get_lang
438            )
439        }
440    ) {
441        my $dh;
442        if (opendir $dh, $directory) {
443            foreach my $tpl_name (readdir $dh) {
444                next if $tpl_name =~ /\A\./;
445                next unless -d $directory . '/' . $tpl_name;
446
447                $tpl_names{$tpl_name} = 1;
448            }
449            closedir $dh;
450        }
451    }
452
453LOOP_FOREACH_TPL_NAME:
454    foreach my $tpl_name (keys %tpl_names) {
455        my $status = $list_conf->{$tpl_name}
456            || $list_conf->{'default'};
457        next if $status eq 'hidden';
458
459        # Look for a comment.tt2.
460        # Check old style locale first then canonic language and its
461        # fallbacks.
462        my $comment_tt2 = Sympa::search_fullpath(
463            $robot, 'comment.tt2',
464            subdir => 'create_list_templates/' . $tpl_name,
465            lang   => $language->get_lang
466        );
467        next unless $comment_tt2;
468
469        open my $fh, '<', $comment_tt2 or next;
470        my $tpl_string = do { local $RS; <$fh> };
471        close $fh;
472
473        pos $tpl_string = 0;
474        my %titles;
475        while ($tpl_string =~ /\G(title(?:[.][-\w]+)?[ \t]+(?:.*))(\n|\z)/cgi
476            or $tpl_string =~ /\G(\s*)(\n|\z)/cg) {
477            my $line = $1;
478            last if $line =~ /\A\s*\z/;
479
480            if ($line =~ /^title\.gettext\s+(.*)\s*$/i) {
481                $titles{'gettext'} = $1;
482            } elsif ($line =~ /^title\.(\S+)\s+(.*)\s*$/i) {
483                my ($lang, $title) = ($1, $2);
484                # canonicalize lang if possible.
485                $lang = Sympa::Language::canonic_lang($lang) || $lang;
486                $titles{$lang} = $title;
487            } elsif (/^title\s+(.*)\s*$/i) {
488                $titles{'default'} = $1;
489            }
490        }
491
492        $list_templates->{$tpl_name}{'html_content'} = substr $tpl_string,
493            pos $tpl_string;
494
495        # Set the title in the current language
496        foreach
497            my $lang (Sympa::Language::implicated_langs($language->get_lang))
498        {
499            if (exists $titles{$lang}) {
500                $list_templates->{$tpl_name}{'title'} = $titles{$lang};
501                next LOOP_FOREACH_TPL_NAME;
502            }
503        }
504        if ($titles{'gettext'}) {
505            $list_templates->{$tpl_name}{'title'} =
506                $language->gettext($titles{'gettext'});
507        } elsif ($titles{'default'}) {
508            $list_templates->{$tpl_name}{'title'} = $titles{'default'};
509        }
510    }
511
512    return $list_templates;
513}
514
515# Old name: tools::get_templates_list().
516sub get_templates_list {
517    $log->syslog('debug3', '(%s, %s, %s => %s)', @_);
518    my $that    = shift;
519    my $type    = shift;
520    my %options = @_;
521
522    my ($list, $robot_id);
523    if (ref $that eq 'Sympa::List') {
524        $list     = $that;
525        $robot_id = $that->{'domain'};
526    } elsif ($that and $that ne '*') {
527        $robot_id = $that;
528    } else {
529        die 'bug in logic. Ask developer';
530    }
531
532    my $listdir;
533
534    unless ($type and ($type eq 'web' or $type eq 'mail')) {
535        $log->syslog('info', 'Internal error incorrect parameter');
536    }
537
538    my $distrib_dir = Sympa::Constants::DEFAULTDIR . '/' . $type . '_tt2';
539    my $site_dir    = $Conf::Conf{'etc'} . '/' . $type . '_tt2';
540    my $robot_dir =
541        $Conf::Conf{'etc'} . '/' . $robot_id . '/' . $type . '_tt2';
542
543    my @try;
544
545    ## The 'ignore_global' option allows to look for files at list level only
546    unless ($options{ignore_global}) {
547        push @try, $distrib_dir;
548        push @try, $site_dir;
549        push @try, $robot_dir;
550    }
551
552    if ($list) {
553        $listdir = $list->{'dir'} . '/' . $type . '_tt2';
554        push @try, $listdir;
555    } else {
556        $listdir = '';
557    }
558
559    my $i = 0;
560    my $tpl;
561
562    foreach my $dir (@try) {
563        opendir my $dh, $dir or next;
564
565        foreach my $file (grep { !/\A[.]/ } readdir $dh) {
566            # Subdirectory for a lang
567            if (-d $dir . '/' . $file) {
568                #FIXME: Templates in subdirectories would be listed.
569                next unless Sympa::Language::canonic_lang($file);
570
571                my $lang = $file;
572                opendir my $dh_lang, $dir . '/' . $lang or next;
573
574                foreach my $file (grep { !/\A[.]/ } readdir $dh_lang) {
575                    next unless ($file =~ /\.tt2$/);
576                    if ($dir eq $distrib_dir) {
577                        $tpl->{$file}{'distrib'}{$lang} =
578                            $dir . '/' . $lang . '/' . $file;
579                    }
580                    if ($dir eq $site_dir) {
581                        $tpl->{$file}{'site'}{$lang} =
582                            $dir . '/' . $lang . '/' . $file;
583                    }
584                    if ($dir eq $robot_dir) {
585                        $tpl->{$file}{'robot'}{$lang} =
586                            $dir . '/' . $lang . '/' . $file;
587                    }
588                    if ($dir eq $listdir) {
589                        $tpl->{$file}{'list'}{$lang} =
590                            $dir . '/' . $lang . '/' . $file;
591                    }
592                }
593                closedir $dh_lang;
594
595            } else {
596                next unless ($file =~ /\.tt2$/);
597                if ($dir eq $distrib_dir) {
598                    $tpl->{$file}{'distrib'}{'default'} = $dir . '/' . $file;
599                }
600                if ($dir eq $site_dir) {
601                    $tpl->{$file}{'site'}{'default'} = $dir . '/' . $file;
602                }
603                if ($dir eq $robot_dir) {
604                    $tpl->{$file}{'robot'}{'default'} = $dir . '/' . $file;
605                }
606                if ($dir eq $listdir) {
607                    $tpl->{$file}{'list'}{'default'} = $dir . '/' . $file;
608                }
609            }
610        }
611        closedir $dh;
612    }
613    return ($tpl);
614
615}
616
617# Returns the path for a specific template.
618# Old name: tools::get_template_path().
619sub get_template_path {
620    $log->syslog('debug2', '(%s, %s. %s, %s, %s)', @_);
621    my $that  = shift;
622    my $type  = shift;
623    my $scope = shift;
624    my $tpl   = shift;
625    my $lang  = shift || 'default';
626
627    my ($list, $robot_id);
628    if (ref $that eq 'Sympa::List') {
629        $list     = $that;
630        $robot_id = $that->{'domain'};
631    } elsif ($that and $that ne '*') {
632        $robot_id = $that;
633    } else {
634        die 'bug in logic. Ask developer';
635    }
636
637    my $subdir = '';
638    # canonicalize language name which may be old-style locale name.
639    unless ($lang eq 'default') {
640        my $oldlocale = Sympa::Language::lang2oldlocale($lang);
641        unless ($oldlocale eq $lang) {
642            $subdir = Sympa::Language::canonic_lang($lang);
643            unless ($subdir) {
644                $log->syslog('info', 'Internal error incorrect parameter');
645                return undef;
646            }
647        }
648    }
649
650    unless ($type and ($type eq 'web' or $type eq 'mail')) {
651        $log->syslog('info', 'Internal error incorrect parameter');
652        return undef;
653    }
654
655    my $dir;
656    if ($scope eq 'list') {
657        unless ($list) {
658            $log->syslog('err', 'Missing parameter "list"');
659            return undef;
660        }
661        $dir = $list->{'dir'};
662    } elsif ($scope eq 'robot') {
663        $dir = $Conf::Conf{'etc'} . '/' . $robot_id;
664    } elsif ($scope eq 'site') {
665        $dir = $Conf::Conf{'etc'};
666    } elsif ($scope eq 'distrib') {
667        $dir = Sympa::Constants::DEFAULTDIR;
668    } else {
669        return undef;
670    }
671
672    $dir .= '/' . $type . '_tt2';
673    $dir .= '/' . $subdir if length $subdir;
674    return $dir . '/' . $tpl;
675}
676
677# Old name: Conf::update_css().
678# DEPRECATED.  No longer used.
679#sub update_css;
680
681my %hash;
682
683# get_css_url($robot, [ force => 1 ], [ lang => $lang | custom_css => $param ])
684# Old name: (part of) Conf::update_css().
685sub get_css_url {
686    my $robot   = shift;
687    my %options = @_;
688
689    my ($url, $hash);
690    if ($options{custom_css}) {
691        my $umask = umask 022;
692        ($url) = _get_css_url($robot, %options);
693        umask $umask;
694    } elsif ($options{lang}) {
695        my $lang = Sympa::Language::canonic_lang($options{lang});
696        return undef unless $lang;    # Malformed lang parameter.
697
698        my $umask = umask 022;
699        ($url, $hash) = _get_css_url($robot, %options, lang => $lang);
700        umask $umask;
701
702        $hash{$lang} = $hash if $hash;
703    } else {
704        my $umask = umask 022;
705        ($url, $hash) = _get_css_url($robot, %options);
706        umask $umask;
707
708        $hash{_main} = $hash if $hash;
709    }
710    return $url;
711}
712
713sub _get_css_url {
714    my $robot   = shift;
715    my %options = @_;
716
717    my %colors = %{$options{custom_css} || {}};
718    my $lang = $options{lang};
719
720    # Get parameters for parsing.
721    my $param = {};
722    foreach my $p (
723        grep { /_color\z/ or /\Acolor_/ or /_url\z/ }
724        map { $_->{name} }
725        grep { not $_->{obsolete} and $_->{name} } @Sympa::ConfDef::params
726    ) {
727        $param->{$p} = Conf::get_robot_conf($robot, $p);
728    }
729    if (%colors) {
730        # Override colors for parsing.
731        my @keys =
732            grep { defined $colors{$_} and length $colors{$_} } keys %colors;
733        @{$param}{@keys} = @colors{@keys};
734        $param->{custom_css} = 1;
735    } elsif ($lang) {
736        $param->{lang} = $lang;
737    }
738    $param->{css} = 'style.css';    # Compat. <= 6.2.16.
739
740    # Get path and mtime of template file.
741    my ($template_path, $template_mtime);
742    if ($lang) {
743        # Include only locale paths.
744        $template_path = Sympa::search_fullpath(
745            $robot, 'css.tt2',
746            subdir    => 'web_tt2',
747            lang      => $lang,
748            lang_only => 1
749        );
750        # No template for specified language.
751        return unless $template_path;
752    } else {
753        # Do not include locale paths (lang parameter).
754        # The css.tt2 by each locale will override styles in main CSS.
755        $template_path =
756            Sympa::search_fullpath($robot, 'css.tt2', subdir => 'web_tt2');
757        unless ($template_path) {    # Impossible case.
758            my $url = Sympa::Tools::Text::weburl($Conf::Conf{'css_url'},
759                [$robot, 'style.css']);
760            return ($url);
761        }
762    }
763    $template_mtime = Sympa::Tools::File::get_mtime($template_path);
764    $param->{path}  = $template_path;
765    $param->{mtime} = $template_mtime;
766
767    my $hash = Digest::MD5::md5_hex(
768        join ',',
769        map { $_ . '=' . $param->{$_} }
770            grep { defined $param->{$_} and length $param->{$_} }
771            sort keys %$param
772    );
773
774    my ($dir, $path, $url);
775    if (%colors) {
776        $dir = sprintf '%s/%s', $Conf::Conf{'css_path'}, $robot;
777        # Expire old files.
778        if (opendir my $dh, $dir) {
779            foreach my $file (readdir $dh) {
780                next unless $file =~ /\Astyle[.][0-9a-f]+[.]css\b/;
781                next unless -f $dir . '/' . $file;
782                next
783                    if time - 3600 <
784                    Sympa::Tools::File::get_mtime($dir . '/' . $file);
785                unlink $dir . '/' . $file;
786            }
787            closedir $dh;
788        }
789
790        $path = sprintf '%s/style.%s.css', $dir, $hash;
791        $url = Sympa::Tools::Text::weburl($Conf::Conf{'css_url'},
792            [$robot, sprintf 'style.%s.css', $hash]);
793    } elsif ($lang) {
794        $dir = sprintf '%s/%s/%s', $Conf::Conf{'css_path'}, $robot, $lang;
795
796        $path = sprintf '%s/lang.css', $dir;
797        $url = Sympa::Tools::Text::weburl(
798            $Conf::Conf{'css_url'},
799            [$robot, $lang, 'lang.css'],
800            query => {h => $hash}
801        );
802    } else {
803        # Use css_path and css_url parameters so that the user may provide
804        # their own CSS.
805        $dir = sprintf '%s/%s', $Conf::Conf{'css_path'}, $robot;
806
807        $path = $dir . '/style.css';
808        $url  = Sympa::Tools::Text::weburl(
809            $Conf::Conf{'css_url'},
810            [$robot, 'style.css'],
811            query => {h => $hash}
812        );
813    }
814
815    # Update the CSS if it is missing or if css.tt2 or configuration was
816    # changed.
817    if (-f $path and not $options{force}) {
818        if (%colors) {
819            return ($url);
820        } elsif (
821            (exists $hash{$lang || '_main'})
822            ? ($hash{$lang || '_main'} eq $hash)
823            : ($template_mtime < Sympa::Tools::File::get_mtime($path))
824        ) {
825            return ($url, $hash);
826        }
827    }
828
829    $log->syslog(
830        'notice',
831        'Template file %s or configuration has changed; updating CSS file %s',
832        $template_path,
833        $path
834    );
835
836    # Create directory if required
837    unless (-d $dir) {
838        my $error;
839        File::Path::make_path(
840            $dir,
841            {   mode  => 0755,
842                owner => Sympa::Constants::USER(),
843                group => Sympa::Constants::GROUP(),
844                error => \$error
845            }
846        );
847        if (@$error) {
848            my ($target, $err) = %{$error->[-1] || {}};
849
850            Sympa::send_notify_to_listmaster(
851                $robot,
852                'css_update_failed',
853                {   error   => 'cannot_mkdir',
854                    target  => $target,
855                    message => $err
856                }
857            );
858            $log->syslog('err', 'Failed to create %s: %s', $target, $err);
859
860            return;
861        }
862    }
863
864    # Lock file to prevent multiple processes from writing it.
865    my $lock_fh = Sympa::LockedFile->new($path, -1, '+');
866    unless ($lock_fh) {
867        return ($url);
868    }
869
870    my $fh;
871    unless (open $fh, '>', $path . '.new') {
872        my $errno = $ERRNO;
873        Sympa::send_notify_to_listmaster(
874            $robot,
875            'css_update_failed',
876            {   error   => 'cannot_open_file',
877                file    => $path,
878                message => $errno,
879            }
880        );
881        $log->syslog('err', 'Failed to open (write) file %s: %s',
882            $path, $errno);
883
884        return ($url) if -f $path;
885        return;
886    }
887
888    my $template;
889    if ($lang) {
890        $template = Sympa::Template->new(
891            $robot,
892            subdir    => 'web_tt2',
893            lang      => $lang,
894            lang_only => 1
895        );
896    } else {
897        $template = Sympa::Template->new($robot, subdir => 'web_tt2');
898    }
899    unless ($template->parse($param, 'css.tt2', $fh)) {
900        my $error = $template->{last_error};
901        $error = $error->as_string if ref $error;
902        Sympa::send_notify_to_listmaster($robot, 'css_update_failed',
903            {error => 'tt2_error', message => $error});
904        $log->syslog('err', 'Error while installing %s', $path);
905
906        # Keep previous file.
907        close $fh;
908        unlink $path . '.new';
909
910        return ($url) if -f $path;
911        return;
912    }
913
914    close $fh;
915
916    # Keep copy of previous file.
917    unless (
918        (not -f $path or rename($path, $path . '.' . time) or unlink $path)
919        and rename($path . '.new', $path)) {
920        my $errno = $ERRNO;
921        Sympa::send_notify_to_listmaster($robot, 'css_update_failed',
922            {error => 'cannot_rename_file', message => $errno});
923        $log->syslog('err', 'Error while installing %s: %s', $path, $errno);
924
925        return;
926    }
927
928    # Expire old files.
929    foreach my $file (<$path.*>) {
930        next
931            unless 0 == index($file, $path)
932            and substr($file, length $path) =~ /\A[.]\d+\z/
933            and -f $file;
934        unlink $file;
935    }
936
937    return ($url, $hash);
938}
939
940# Old name: tools::escape_html().
941# DEPRECATED.  No longer used.
942#sub escape_html_minimum;
943
944# Old name: tools::unescape_html().
945# DEPRECATED.  No longer used.
946#sub unescape_html_minimum;
947
9481;
949__END__
950