Tools.pm 30.2 KB
Newer Older
1
2
3
4
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4
# $Id$

5
# Sympa - SYsteme de Multi-Postage Automatique
6
7
8
9
#
# 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
10
# Copyright (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017 GIP RENATER
11
12
# Copyright 2017, 2018 The Sympa Community. See the AUTHORS.md file at the
# top-level directory of this distribution and at
13
# <https://github.com/sympa-community/sympa.git>.
14
15
16
17
18
19
20
21
22
23
24
25
#
# 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
26
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
27

IKEDA Soji's avatar
IKEDA Soji committed
28
package Sympa::WWW::Tools;
salaun's avatar
salaun committed
29

30
31
use strict;
use warnings;
IKEDA Soji's avatar
IKEDA Soji committed
32
use Digest::MD5;
33
use English qw(-no_match_vars);
34
use File::Path qw();
35
use URI;
36
use URI::Escape qw();
37

38
use Sympa;
39
use Conf;
40
use Sympa::ConfDef;
41
use Sympa::Constants;
42
use Sympa::Language;
43
use Sympa::List;
44
45
use Sympa::LockedFile;
use Sympa::Log;
46
use Sympa::Regexps;
47
48
use Sympa::Template;
use Sympa::Tools::File;
49
use Sympa::Tools::Text;
salaun's avatar
salaun committed
50

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

53
## Cookie expiration periods with corresponding entry in NLS
54
55
56
57
58
59
60
61
62
63
our %cookie_period = (
    0     => {'gettext_id' => "session"},
    10    => {'gettext_id' => "10 minutes"},
    30    => {'gettext_id' => "30 minutes"},
    60    => {'gettext_id' => "1 hour"},
    360   => {'gettext_id' => "6 hours"},
    1440  => {'gettext_id' => "1 day"},
    10800 => {'gettext_id' => "1 week"},
    43200 => {'gettext_id' => "30 days"}
);
64

65
# File names with corresponding entry in NLS set
66
67
68
69
our %filenames = (
    'welcome.tt2'       => {'gettext_id' => "welcome message"},
    'bye.tt2'           => {'gettext_id' => "unsubscribe message"},
    'removed.tt2'       => {'gettext_id' => "deletion message"},
70
71
    'message_header'    => {'gettext_id' => "message header"},
    'message_footer'    => {'gettext_id' => "message footer"},
72
    'remind.tt2'        => {'gettext_id' => "remind message"},
73
    'reject.tt2'        => {'gettext_id' => "moderator rejection message"},
74
75
76
    'invite.tt2'        => {'gettext_id' => "subscribing invitation message"},
    'helpfile.tt2'      => {'gettext_id' => "help file"},
    'lists.tt2'         => {'gettext_id' => "directory of lists"},
77
    'global_remind.tt2' => {'gettext_id' => "global reminder message"},
78
79
80
81
82
83
84
85
86
87
    'summary.tt2'       => {'gettext_id' => "summary message"},
    'info'              => {'gettext_id' => "list description"},
    'homepage'          => {'gettext_id' => "list homepage"},
    'create_list_request.tt2' =>
        {'gettext_id' => "list creation request message"},
    'list_created.tt2' =>
        {'gettext_id' => "list creation notification message"},
    'your_infected_msg.tt2' => {'gettext_id' => "virus infection message"},
    'list_aliases.tt2'      => {'gettext_id' => "list aliases template"}
);
salaun's avatar
salaun committed
88

89
90
# Taken from IANA registry:
# <http://www.iana.org/assignments/smtp-enhanced-status-codes>
91
our %bounce_status = (
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
    '0.0'  => 'Other undefined Status',
    '1.0'  => 'Other address status',
    '1.1'  => 'Bad destination mailbox address',
    '1.2'  => 'Bad destination system address',
    '1.3'  => 'Bad destination mailbox address syntax',
    '1.4'  => 'Destination mailbox address ambiguous',
    '1.5'  => 'Destination address valid',
    '1.6'  => 'Destination mailbox has moved, No forwarding address',
    '1.7'  => 'Bad sender\'s mailbox address syntax',
    '1.8'  => 'Bad sender\'s system address',
    '1.9'  => 'Message relayed to non-compliant mailer',
    '1.10' => 'Recipient address has null MX',
    '2.0'  => 'Other or undefined mailbox status',
    '2.1'  => 'Mailbox disabled, not accepting messages',
    '2.2'  => 'Mailbox full',
    '2.3'  => 'Message length exceeds administrative limit',
    '2.4'  => 'Mailing list expansion problem',
    '3.0'  => 'Other or undefined mail system status',
    '3.1'  => 'Mail system full',
    '3.2'  => 'System not accepting network messages',
    '3.3'  => 'System not capable of selected features',
    '3.4'  => 'Message too big for system',
    '3.5'  => 'System incorrectly configured',
    '3.6'  => 'Requested priority was changed',
    '4.0'  => 'Other or undefined network or routing status',
    '4.1'  => 'No answer from host',
    '4.2'  => 'Bad connection',
    '4.3'  => 'Directory server failure',
    '4.4'  => 'Unable to route',
    '4.5'  => 'Mail system congestion',
    '4.6'  => 'Routing loop detected',
    '4.7'  => 'Delivery time expired',
    '5.0'  => 'Other or undefined protocol status',
    '5.1'  => 'Invalid command',
    '5.2'  => 'Syntax error',
    '5.3'  => 'Too many recipients',
    '5.4'  => 'Invalid command arguments',
    '5.5'  => 'Wrong protocol version',
    '5.6'  => 'Authentication Exchange line is too long',
    '6.0'  => 'Other or undefined media error',
    '6.1'  => 'Media not supported',
    '6.2'  => 'Conversion required and prohibited',
    '6.3'  => 'Conversion required but not supported',
    '6.4'  => 'Conversion with loss performed',
    '6.5'  => 'Conversion Failed',
    '6.6'  => 'Message content not available',
    '6.7'  => 'Non-ASCII addresses not permitted for that sender/recipient',
    '6.8' =>
        'UTF-8 string reply is required, but not permitted by the SMTP client',
    '6.9' =>
        'UTF-8 header message cannot be transferred to one or more recipients, so the message must be rejected',
    #'6.10' => '',    # Duplicate of 6.8, deprecated.
    '7.0'  => 'Other or undefined security status',
    '7.1'  => 'Delivery not authorized, message refused',
    '7.2'  => 'Mailing list expansion prohibited',
    '7.3'  => 'Security conversion required but not possible',
    '7.4'  => 'Security features not supported',
    '7.5'  => 'Cryptographic failure',
    '7.6'  => 'Cryptographic algorithm not supported',
    '7.7'  => 'Message integrity failure',
    '7.8'  => 'Authentication credentials invalid',
    '7.9'  => 'Authentication mechanism is too weak',
    '7.10' => 'Encryption Needed',
    '7.11' => 'Encryption required for requested authentication mechanism',
    '7.12' => 'A password transition is needed',
    '7.13' => 'User Account Disabled',
    '7.14' => 'Trust relationship required',
    '7.15' => 'Priority Level is too low',
    '7.16' => 'Message is too big for the specified priority',
    '7.17' => 'Mailbox owner has changed',
    '7.18' => 'Domain owner has changed',
    '7.19' => 'RRVS test cannot be completed',
    '7.20' => 'No passing DKIM signature found',
    '7.21' => 'No acceptable DKIM signature found',
    '7.22' => 'No valid author-matched DKIM signature found',
    '7.23' => 'SPF validation failed',
    '7.24' => 'SPF validation error',
    '7.25' => 'Reverse DNS validation failed',
    '7.26' => 'Multiple authentication checks failed',
    '7.27' => 'Sender address has null MX',
172
);
173

salaun's avatar
salaun committed
174
## Load WWSympa configuration file
175
176
##sub load_config
## MOVED: use Conf::_load_wwsconf().
salaun's avatar
salaun committed
177
178

## Load HTTPD MIME Types
179
# Moved to Conf::_load_mime_types().
180
#sub load_mime_types();
salaun's avatar
salaun committed
181
182

## Returns user information extracted from the cookie
IKEDA Soji's avatar
IKEDA Soji committed
183
# Deprecated.  Use Sympa::WWW::Session->new etc.
184
#sub get_email_from_cookie;
salaun's avatar
salaun committed
185

IKEDA Soji's avatar
IKEDA Soji committed
186
187
# NO LONGER USED.
#sub new_passwd;
salaun's avatar
salaun committed
188
189

## Basic check of an email address
190
# DUPLICATE: Use Sympa::Tools::Text::valid_email().
191
#sub valid_email($email);
salaun's avatar
salaun committed
192

193
# 6.2b: added $robot parameter.
IKEDA Soji's avatar
IKEDA Soji committed
194
195
# DEPRECATED.  No longer used.
#sub init_passwd;
salaun's avatar
salaun committed
196

197
198
199
200
# NOTE: As of 6.2.15, by default, less trustworthy "X-Forwarded-Host:" request
# field is not referred and this function returns host name and path
# respecting wwsympa_url robot parameter.  To change this behavior, use
# "authority" option (See Sympa::get_url()).
201
sub get_my_url {
202
203
    my $robot   = shift;
    my %options = @_;
204

205
206
207
208
209
210
211
212
    my $path_info    = $ENV{PATH_INFO} // '';
    my $query_string = $ENV{QUERY_STRING} // '';

    return
          Sympa::get_url($robot, undef, authority => $options{authority})
        . Sympa::Tools::Text::encode_uri($path_info, omit => '/')
        . (length $query_string ? '?' : '')
        . $query_string;
213
}
salaun's avatar
salaun committed
214

215
216
217
218
# Determine robot.
sub get_robot {
    my @keys = @_;

219
220
221
222
223
224
225
226
227
228
229
    # Get host part of script-URI from standard CGI environment variable
    # SERVER_NAME.
    # NOTE: As of 6.2.15, less trustworthy "X-Forwarded-Server:" request field
    # is _no longer_ referred and this function returns only locally detected
    # server name.
    my $request_host = lc($ENV{SERVER_NAME} // '');
    return unless length $request_host;
    my $ipv6_re = Sympa::Regexps::ipv6();
    if ($request_host =~ /\A$ipv6_re\z/) {    # IPv6 address
        $request_host = sprintf '[%s]', $request_host;
    }
230

231
232
233
234
235
236
237
238
239
240
241
242
    # Since CGI of some HTTP servers might split script-path and extra-path of
    # script-URI inproperly, we'd be better to reconstruct them from these
    # standard CGI environment variables:
    #   - SCRIPT_NAME: a URI path which could identify the CGI script.
    #   - PATH_INFO: derived from the portion of the URI path hierarchy
    #     following the part that identifies the script itself.
    # Note that they are not URL-encoded, unlike non-standard REQUEST_URI.
    my $org_script_name = $ENV{SCRIPT_NAME} // '';
    my $org_path_info   = $ENV{PATH_INFO} // '';
    return unless '' eq $org_script_name or 0 == index $org_script_name, '/';
    return unless '' eq $org_path_info   or 0 == index $org_path_info,   '/';
    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.
IKEDA Soji's avatar
IKEDA Soji committed
245
    my ($robot_id, $script_path) = (undef, undef);
246
247
248
249
250
251
252
    foreach my $rid (Sympa::List::get_robots()) {
        my $local_url;
        foreach my $key (@keys) {
            $local_url = Conf::get_robot_conf($rid, $key);
            last if $local_url;
        }
        next unless $local_url;
253

254
255
256
257
258
259
260
        if ($local_url =~ m{\A[-+\w]+:}) {
            ;
        } elsif ($local_url =~ m{\A//}) {
            $local_url = 'http:' . $local_url;
        } else {
            $local_url = 'http://' . $local_url;
        }
261

262
263
264
265
266
        my $uri = URI->new($local_url);
        next
            unless $uri
            and $uri->scheme
            and grep { $uri->scheme eq $_ } qw(http https);
267

268
        my $host = lc URI::Escape::uri_unescape($uri->host // '');
IKEDA Soji's avatar
IKEDA Soji committed
269
        my $path = URI::Escape::uri_unescape($uri->path // '');
270
271
272
        next unless $request_host eq $host;
        next
            unless $request_path eq $path
IKEDA Soji's avatar
IKEDA Soji committed
273
            or 0 == index $request_path, $path . '/';
274
275
276

        # The longest path wins.
        ($robot_id, $script_path) = ($rid, $path)
IKEDA Soji's avatar
IKEDA Soji committed
277
278
            if not defined $script_path
            or length $script_path < length $path;
279
280
    }

281
282
283
284
285
    return unless $robot_id;
    return
        wantarray
        ? ($robot_id, $script_path, substr $request_path, length $script_path)
        : $robot_id;
286
287
}

288
# Old name: (part of) get_header_field() in wwsympa.fcgi.
289
290
# No longer used.
#sub _get_server_name;
291
292

# Old name: (part of) get_header_field() in wwsympa.fcgi.
293
294
295
# NOTE: As of 6.2.15, less trustworthy "X-Forwarded-Host:" request field is
# _no longer_ referred and this function returns only locally detected host
# information.
296
sub get_http_host {
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
    my ($host, $port);

    my $hostport_re = Sympa::Regexps::hostport();
    my $ipv6_re     = Sympa::Regexps::ipv6();
    unless ($host = $ENV{HTTP_HOST} and $host =~ /\A$hostport_re\z/) {
        $host = $ENV{SERVER_NAME};
        $port = $ENV{SERVER_PORT};
    }
    return undef unless $host;

    if ($host =~ /\A$ipv6_re\z/) {    # IPv6 address
        $host = "[$host]";
    }
    unless ($host =~ /:\d+\z/) {
        $host = "$host:$port" if $port;
    }

    return lc $host;
315
316
}

IKEDA Soji's avatar
IKEDA Soji committed
317
318
319
320
321
322
323
324
325
326
327
328
# Determin cookie domain.
sub get_cookie_domain {
    my $robot = shift;

    # In case HTTP_HOST does not match cookie_domain, use former.
    # N.B. As of 6.2.15, the cookie domain will match with the host name
    # locally detected by server.  If remotely detected name should be differ,
    # the proxy must adjust it.
    my $cookie_domain = Conf::get_robot_conf($robot, 'cookie_domain');
    my $http_host = Sympa::WWW::Tools::get_http_host() || '';
    $http_host =~ s/:\d+\z//;    # Suppress port.
    my $dotdom = lc $cookie_domain;
IKEDA Soji's avatar
typo.    
IKEDA Soji committed
329
    $dotdom =~ s/\A(?![.])/./;
IKEDA Soji's avatar
IKEDA Soji committed
330
331
332
333
334
335
336
337
338
339
340
341
342

    unless (substr($http_host, -length($dotdom)) eq $dotdom
        or ".$http_host" eq $dotdom
        or $cookie_domain eq 'localhost') {
        $log->syslog('debug',
            '(%s) Does NOT match HTTP_HOST; setting cookie_domain to %s',
            $cookie_domain, $http_host);
        return $http_host;
    }

    return $cookie_domain;
}

343
# Uploade source file to the destination on the server
344
345
# DEPRECATED.  No longer used.
#sub upload_file_to_server;
346

347
348
# DEPRECATED: No longer used.
#sub no_slash_end;
349

350
351
# DEPRECATED: No longer used.
#sub make_visible_path;
352
353

## returns a mailto according to list spam protection parameter
354
355
# DEPRECATED.  Use [%|mailto()%] and [%|obfuscate()%] filters in template.
#sub mailto;
356

357
358
# DEPRECATED: No longer used.
#sub find_edit_mode;
359

360
361
# DEPRECATED: No longer used.
#sub merge_edit;
362

IKEDA Soji's avatar
IKEDA Soji committed
363
# Moved: Use Sympa::WWW::SharedDocument::_load_desc_file().
364
#sub get_desc_file;
365

366
367
# DEPRECATED: No longer used.
#sub get_directory_content;
368

369
370
# DEPRECATED: No longer used (a subroutine of get_directory_content()).
#sub select_my_files;
371

IKEDA Soji's avatar
IKEDA Soji committed
372
# Moved to Sympa::WWW::SharedDocument::_get_icon().
IKEDA Soji's avatar
IKEDA Soji committed
373
#sub get_icon;
374

375
376
# Moved to: Conf::get_mime_type().
#sub get_mime_type;
377

378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
## return a hash from the edit_list_conf file
# Old name: tools::load_create_list_conf().
sub _load_create_list_conf {
    my $robot = shift;

    my $file;
    my $conf;

    $file = Sympa::search_fullpath($robot, 'create_list.conf');
    unless ($file) {
        $log->syslog(
            'info',
            'Unable to read %s',
            Sympa::Constants::DEFAULTDIR . '/create_list.conf'
        );
        return undef;
    }

    unless (open(FILE, $file)) {
        $log->syslog('info', 'Unable to open config file %s', $file);
        return undef;
    }

    while (<FILE>) {
        next if /^\s*(\#.*|\s*)$/;

        if (/^\s*(\S+)\s+(read|hidden)\s*$/i) {
            $conf->{$1} = lc($2);
        } else {
            $log->syslog(
                'info',
                'Unknown parameter in %s (Ignored) %s',
                "$Conf::Conf{'etc'}/create_list.conf", $_
            );
            next;
        }
    }

    close FILE;
    return $conf;
}

# Old name: tools::get_list_list_tpl().
sub get_list_list_tpl {
    my $robot = shift;

    my $language = Sympa::Language->instance;

    my $list_conf;
    my $list_templates;
    unless ($list_conf = _load_create_list_conf($robot)) {
        return undef;
    }

    my %tpl_names;
    foreach my $directory (
        @{  Sympa::get_search_path(
                $robot,
                subdir => 'create_list_templates',
                lang   => $language->get_lang
            )
        }
Luc Didry's avatar
Luc Didry committed
440
    ) {
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
        my $dh;
        if (opendir $dh, $directory) {
            foreach my $tpl_name (readdir $dh) {
                next if $tpl_name =~ /\A\./;
                next unless -d $directory . '/' . $tpl_name;

                $tpl_names{$tpl_name} = 1;
            }
            closedir $dh;
        }
    }

LOOP_FOREACH_TPL_NAME:
    foreach my $tpl_name (keys %tpl_names) {
        my $status = $list_conf->{$tpl_name}
            || $list_conf->{'default'};
        next if $status eq 'hidden';

        # Look for a comment.tt2.
        # Check old style locale first then canonic language and its
        # fallbacks.
        my $comment_tt2 = Sympa::search_fullpath(
            $robot, 'comment.tt2',
            subdir => 'create_list_templates/' . $tpl_name,
            lang   => $language->get_lang
        );
        next unless $comment_tt2;

        open my $fh, '<', $comment_tt2 or next;
        my $tpl_string = do { local $RS; <$fh> };
        close $fh;

        pos $tpl_string = 0;
        my %titles;
        while ($tpl_string =~ /\G(title(?:[.][-\w]+)?[ \t]+(?:.*))(\n|\z)/cgi
            or $tpl_string =~ /\G(\s*)(\n|\z)/cg) {
            my $line = $1;
            last if $line =~ /\A\s*\z/;

            if ($line =~ /^title\.gettext\s+(.*)\s*$/i) {
                $titles{'gettext'} = $1;
            } elsif ($line =~ /^title\.(\S+)\s+(.*)\s*$/i) {
                my ($lang, $title) = ($1, $2);
                # canonicalize lang if possible.
                $lang = Sympa::Language::canonic_lang($lang) || $lang;
                $titles{$lang} = $title;
            } elsif (/^title\s+(.*)\s*$/i) {
                $titles{'default'} = $1;
            }
        }

492
        $list_templates->{$tpl_name}{'html_content'} = substr $tpl_string,
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
            pos $tpl_string;

        # Set the title in the current language
        foreach
            my $lang (Sympa::Language::implicated_langs($language->get_lang))
        {
            if (exists $titles{$lang}) {
                $list_templates->{$tpl_name}{'title'} = $titles{$lang};
                next LOOP_FOREACH_TPL_NAME;
            }
        }
        if ($titles{'gettext'}) {
            $list_templates->{$tpl_name}{'title'} =
                $language->gettext($titles{'gettext'});
        } elsif ($titles{'default'}) {
            $list_templates->{$tpl_name}{'title'} = $titles{'default'};
        }
    }

    return $list_templates;
}

515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
# Old name: tools::get_templates_list().
sub get_templates_list {
    $log->syslog('debug3', '(%s, %s, %s => %s)', @_);
    my $that    = shift;
    my $type    = shift;
    my %options = @_;

    my ($list, $robot_id);
    if (ref $that eq 'Sympa::List') {
        $list     = $that;
        $robot_id = $that->{'domain'};
    } elsif ($that and $that ne '*') {
        $robot_id = $that;
    } else {
        die 'bug in logic. Ask developer';
    }

    my $listdir;

    unless ($type and ($type eq 'web' or $type eq 'mail')) {
        $log->syslog('info', 'Internal error incorrect parameter');
    }

    my $distrib_dir = Sympa::Constants::DEFAULTDIR . '/' . $type . '_tt2';
    my $site_dir    = $Conf::Conf{'etc'} . '/' . $type . '_tt2';
    my $robot_dir =
        $Conf::Conf{'etc'} . '/' . $robot_id . '/' . $type . '_tt2';

    my @try;

    ## The 'ignore_global' option allows to look for files at list level only
    unless ($options{ignore_global}) {
        push @try, $distrib_dir;
        push @try, $site_dir;
        push @try, $robot_dir;
    }

    if ($list) {
        $listdir = $list->{'dir'} . '/' . $type . '_tt2';
        push @try, $listdir;
    } else {
        $listdir = '';
    }

    my $i = 0;
    my $tpl;

    foreach my $dir (@try) {
        opendir my $dh, $dir or next;

        foreach my $file (grep { !/\A[.]/ } readdir $dh) {
            # Subdirectory for a lang
            if (-d $dir . '/' . $file) {
                #FIXME: Templates in subdirectories would be listed.
                next unless Sympa::Language::canonic_lang($file);

                my $lang = $file;
                opendir my $dh_lang, $dir . '/' . $lang or next;

                foreach my $file (grep { !/\A[.]/ } readdir $dh_lang) {
                    next unless ($file =~ /\.tt2$/);
                    if ($dir eq $distrib_dir) {
                        $tpl->{$file}{'distrib'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $site_dir) {
                        $tpl->{$file}{'site'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $robot_dir) {
                        $tpl->{$file}{'robot'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                    if ($dir eq $listdir) {
                        $tpl->{$file}{'list'}{$lang} =
                            $dir . '/' . $lang . '/' . $file;
                    }
                }
                closedir $dh_lang;

            } else {
                next unless ($file =~ /\.tt2$/);
                if ($dir eq $distrib_dir) {
                    $tpl->{$file}{'distrib'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $site_dir) {
                    $tpl->{$file}{'site'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $robot_dir) {
                    $tpl->{$file}{'robot'}{'default'} = $dir . '/' . $file;
                }
                if ($dir eq $listdir) {
                    $tpl->{$file}{'list'}{'default'} = $dir . '/' . $file;
                }
            }
        }
        closedir $dh;
    }
    return ($tpl);

}

# Returns the path for a specific template.
# Old name: tools::get_template_path().
sub get_template_path {
    $log->syslog('debug2', '(%s, %s. %s, %s, %s)', @_);
    my $that  = shift;
    my $type  = shift;
    my $scope = shift;
    my $tpl   = shift;
    my $lang  = shift || 'default';

    my ($list, $robot_id);
    if (ref $that eq 'Sympa::List') {
        $list     = $that;
        $robot_id = $that->{'domain'};
    } elsif ($that and $that ne '*') {
        $robot_id = $that;
    } else {
        die 'bug in logic. Ask developer';
    }

    my $subdir = '';
    # canonicalize language name which may be old-style locale name.
    unless ($lang eq 'default') {
        my $oldlocale = Sympa::Language::lang2oldlocale($lang);
        unless ($oldlocale eq $lang) {
            $subdir = Sympa::Language::canonic_lang($lang);
            unless ($subdir) {
                $log->syslog('info', 'Internal error incorrect parameter');
                return undef;
            }
        }
    }

    unless ($type and ($type eq 'web' or $type eq 'mail')) {
        $log->syslog('info', 'Internal error incorrect parameter');
        return undef;
    }

    my $dir;
    if ($scope eq 'list') {
        unless ($list) {
            $log->syslog('err', 'Missing parameter "list"');
            return undef;
        }
        $dir = $list->{'dir'};
    } elsif ($scope eq 'robot') {
        $dir = $Conf::Conf{'etc'} . '/' . $robot_id;
    } elsif ($scope eq 'site') {
        $dir = $Conf::Conf{'etc'};
    } elsif ($scope eq 'distrib') {
        $dir = Sympa::Constants::DEFAULTDIR;
    } else {
        return undef;
    }

    $dir .= '/' . $type . '_tt2';
    $dir .= '/' . $subdir if length $subdir;
    return $dir . '/' . $tpl;
}

677
# Old name: Conf::update_css().
678
679
680
# DEPRECATED.  No longer used.
#sub update_css;

681
682
my %hash;

683
684
685
686
# get_css_url($robot, [ force => 1 ], [ lang => $lang | custom_css => $param ])
# Old name: (part of) Conf::update_css().
sub get_css_url {
    my $robot   = shift;
687
688
    my %options = @_;

689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
    my ($url, $hash);
    if ($options{custom_css}) {
        my $umask = umask 022;
        ($url) = _get_css_url($robot, %options);
        umask $umask;
    } elsif ($options{lang}) {
        my $lang = Sympa::Language::canonic_lang($options{lang});
        return undef unless $lang;    # Malformed lang parameter.

        my $umask = umask 022;
        ($url, $hash) = _get_css_url($robot, %options, lang => $lang);
        umask $umask;

        $hash{$lang} = $hash if $hash;
    } else {
        my $umask = umask 022;
        ($url, $hash) = _get_css_url($robot, %options);
        umask $umask;

        $hash{_main} = $hash if $hash;
    }
    return $url;
}

sub _get_css_url {
    my $robot   = shift;
    my %options = @_;

    my %colors = %{$options{custom_css} || {}};
    my $lang = $options{lang};

720
721
722
723
724
    # Get parameters for parsing.
    my $param = {};
    foreach my $p (
        grep { /_color\z/ or /\Acolor_/ or /_url\z/ }
        map { $_->{name} } grep { $_->{name} } @Sympa::ConfDef::params
Luc Didry's avatar
Luc Didry committed
725
    ) {
726
727
        $param->{$p} = Conf::get_robot_conf($robot, $p);
    }
728
    if (%colors) {
729
730
731
732
733
        # Override colors for parsing.
        my @keys =
            grep { defined $colors{$_} and length $colors{$_} } keys %colors;
        @{$param}{@keys} = @colors{@keys};
        $param->{custom_css} = 1;
734
    } elsif ($lang) {
735
736
737
738
739
        $param->{lang} = $lang;
    }
    $param->{css} = 'style.css';    # Compat. <= 6.2.16.

    # Get path and mtime of template file.
740
    my ($template_path, $template_mtime);
741
742
743
744
745
746
747
748
749
    if ($lang) {
        # Include only locale paths.
        $template_path = Sympa::search_fullpath(
            $robot, 'css.tt2',
            subdir    => 'web_tt2',
            lang      => $lang,
            lang_only => 1
        );
        # No template for specified language.
750
        return unless $template_path;
751
752
753
754
755
756
    } else {
        # Do not include locale paths (lang parameter).
        # The css.tt2 by each locale will override styles in main CSS.
        $template_path =
            Sympa::search_fullpath($robot, 'css.tt2', subdir => 'web_tt2');
        unless ($template_path) {    # Impossible case.
757
758
            my $url = Sympa::Tools::Text::weburl($Conf::Conf{'css_url'},
                [$robot, 'style.css']);
759
            return ($url);
760
761
762
763
764
765
766
767
768
769
770
771
772
773
        }
    }
    $template_mtime = Sympa::Tools::File::get_mtime($template_path);
    $param->{path}  = $template_path;
    $param->{mtime} = $template_mtime;

    my $hash = Digest::MD5::md5_hex(
        join ',',
        map { $_ . '=' . $param->{$_} }
            grep { defined $param->{$_} and length $param->{$_} }
            sort keys %$param
    );

    my ($dir, $path, $url);
774
    if (%colors) {
775
        $dir = sprintf '%s/%s', $Conf::Conf{'css_path'}, $robot;
776
777
778
779
780
781
782
        # Expire old files.
        if (opendir my $dh, $dir) {
            foreach my $file (readdir $dh) {
                next unless $file =~ /\Astyle[.][0-9a-f]+[.]css\b/;
                next unless -f $dir . '/' . $file;
                next
                    if time - 3600 <
783
                    Sympa::Tools::File::get_mtime($dir . '/' . $file);
784
785
786
787
788
                unlink $dir . '/' . $file;
            }
            closedir $dh;
        }

789
790
791
        $path = sprintf '%s/style.%s.css', $dir, $hash;
        $url = Sympa::Tools::Text::weburl($Conf::Conf{'css_url'},
            [$robot, sprintf 'style.%s.css', $hash]);
792
    } elsif ($lang) {
793
        $dir = sprintf '%s/%s/%s', $Conf::Conf{'css_path'}, $robot, $lang;
794

795
796
797
798
        $path = sprintf '%s/lang.css', $dir;
        $url = Sympa::Tools::Text::weburl(
            $Conf::Conf{'css_url'},
            [$robot, $lang, 'lang.css'],
799
800
801
802
803
            query => {h => $hash}
        );
    } else {
        # Use css_path and css_url parameters so that the user may provide
        # their own CSS.
804
        $dir = sprintf '%s/%s', $Conf::Conf{'css_path'}, $robot;
805
806

        $path = $dir . '/style.css';
807
808
809
810
811
        $url  = Sympa::Tools::Text::weburl(
            $Conf::Conf{'css_url'},
            [$robot, 'style.css'],
            query => {h => $hash}
        );
812
813
    }

814
815
816
817
818
819
820
821
    # Update the CSS if it is missing or if css.tt2 or configuration was
    # changed.
    if (-f $path and not $options{force}) {
        if (%colors) {
            return ($url);
        } elsif (
            (exists $hash{$lang || '_main'})
            ? ($hash{$lang || '_main'} eq $hash)
IKEDA Soji's avatar
IKEDA Soji committed
822
            : ($template_mtime < Sympa::Tools::File::get_mtime($path))
Luc Didry's avatar
Luc Didry committed
823
        ) {
824
825
            return ($url, $hash);
        }
826
827
828
829
    }

    $log->syslog(
        'notice',
830
        'Template file %s or configuration has changed; updating CSS file %s',
831
832
833
        $template_path,
        $path
    );
834

835
836
837
838
839
840
841
842
843
844
845
846
847
    # Create directory if required
    unless (-d $dir) {
        my $error;
        File::Path::make_path(
            $dir,
            {   mode  => 0755,
                owner => Sympa::Constants::USER(),
                group => Sympa::Constants::GROUP(),
                error => \$error
            }
        );
        if (@$error) {
            my ($target, $err) = %{$error->[-1] || {}};
848

849
850
851
852
853
854
855
856
857
            Sympa::send_notify_to_listmaster(
                $robot,
                'css_update_failed',
                {   error   => 'cannot_mkdir',
                    target  => $target,
                    message => $err
                }
            );
            $log->syslog('err', 'Failed to create %s: %s', $target, $err);
858

859
            return;
860
        }
861
    }
862

863
864
865
    # Lock file to prevent multiple processes from writing it.
    my $lock_fh = Sympa::LockedFile->new($path, -1, '+');
    unless ($lock_fh) {
866
        return ($url);
867
    }
868

869
870
871
872
873
874
875
876
877
    my $fh;
    unless (open $fh, '>', $path . '.new') {
        my $errno = $ERRNO;
        Sympa::send_notify_to_listmaster(
            $robot,
            'css_update_failed',
            {   error   => 'cannot_open_file',
                file    => $path,
                message => $errno,
878
            }
879
880
881
        );
        $log->syslog('err', 'Failed to open (write) file %s: %s',
            $path, $errno);
882

883
884
        return ($url) if -f $path;
        return;
885
    }
886

887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
    my $template;
    if ($lang) {
        $template = Sympa::Template->new(
            $robot,
            subdir    => 'web_tt2',
            lang      => $lang,
            lang_only => 1
        );
    } else {
        $template = Sympa::Template->new($robot, subdir => 'web_tt2');
    }
    unless ($template->parse($param, 'css.tt2', $fh)) {
        my $error = $template->{last_error};
        $error = $error->as_string if ref $error;
        Sympa::send_notify_to_listmaster($robot, 'css_update_failed',
            {error => 'tt2_error', message => $error});
        $log->syslog('err', 'Error while installing %s', $path);

        # Keep previous file.
        close $fh;
        unlink $path . '.new';
908

909
910
        return ($url) if -f $path;
        return;
911
    }
912

913
914
915
916
917
918
919
920
921
922
923
    close $fh;

    # Keep copy of previous file.
    unless (
        (not -f $path or rename($path, $path . '.' . time) or unlink $path)
        and rename($path . '.new', $path)) {
        my $errno = $ERRNO;
        Sympa::send_notify_to_listmaster($robot, 'css_update_failed',
            {error => 'cannot_rename_file', message => $errno});
        $log->syslog('err', 'Error while installing %s: %s', $path, $errno);

924
        return;
925
    }
926

927
928
929
930
    # Expire old files.
    foreach my $file (<$path.*>) {
        next
            unless 0 == index($file, $path)
IKEDA Soji's avatar
IKEDA Soji committed
931
932
            and substr($file, length $path) =~ /\A[.]\d+\z/
            and -f $file;
933
934
935
        unlink $file;
    }

936
    return ($url, $hash);
937
938
}

939
# Old name: tools::escape_html().
940
941
# DEPRECATED.  No longer used.
#sub escape_html_minimum;
942
943

# Old name: tools::unescape_html().
944
945
# DEPRECATED.  No longer used.
#sub unescape_html_minimum;
946

salaun's avatar
salaun committed
947
1;
948
__END__