ezmlm-web/ezmlm-web
3
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity
ezmlm-web/ezmlm-web.cgi
ckubu e06da8137d - If Environment variable EZMLM_WEB_RC ist set (e.g. at webservers vhost 
configuration), the applicatiom loads ezmlmwebrc from that setting. That 
   allows multiple Webinterfaces on the same host with different settings.

 - Subscribition of different adresses at once via textarea input (Closes #70)
   TODO: change concerning labels for language other than german or english

 - Fix setting of chaerset variable (Close #69 ?)

 - Fix en-/decoding (if system charset differs from charset of list)

 - Handling of all text files will be done from the list directory, even if
   the defaults are used.That makes the list robust against changing server
   default settings or moving list from one to another server.

 - conf-lang file will always be written, even if language is the default
   one. So users can see their language setting from the Options screen.

 - Print available listdomains in alphabetical order.

 - trailer is no longer editable from the Overview screen. Changing trailer
   can be done - like other textfiles - from the text screen.

 - Add configuration variable DEBUG. If enabled, application prints Error/Warning 
   messages instead of "Internal Server Error" page.
2011-01-05 01:21:43 +00:00

3085 lines
89 KiB
Perl
Executable file
Raw Blame History

#!/usr/bin/perl
#===========================================================================
# ezmlm-web.cgi - version 3.3.1
# $Id$
#
# This file is part of ezmlm-web.
#
# All user configuration happens in the config file ``ezmlmwebrc''
# POD documentation is at the end of this file
#
# Copyright (C) 1999-2000, Guy Antony Halse, All Rights Reserved.
# Copyright (C) 2005-2008, Lars Kruse, All Rights Reserved.
#
# ezmlm-web is distributed under a BSD-style license. Please refer to
# the copyright file included with the release for details.
# ==========================================================================
package ezmlm_web;
# Modules to include
use strict;
use Getopt::Std;
use ClearSilver;
use Mail::Ezmlm;
use File::Copy;
use File::Path;
use DB_File;
use CGI;
use IO::File;
use POSIX;
use English;
use MIME::QuotedPrint;
# optional modules - they will be loaded later if they are available
#Encode
#POSIX
#Mail::Ezmlm::GpgEzmlm
#Mail::Ezmlm::GpgKeyRing
#Mail::Address OR Email::Address
my $mail_address_package;
# we can use either the Mail::Address or the Email::Address module
# "Mail::Address" was used exclusively until ezmlm-web v3.2, thus it is proven
# to work with ezmlm-web
# the downside of Mail::Address is, that it is not available in the debian
# distribution
if (&safely_import_module("Mail::Address")) {
$mail_address_package = "Mail::Address";
} elsif (&safely_import_module("Email::Address")) {
$mail_address_package = "Email::Address";
} else {
die "Failed to import the Mail::Address and the Email::Address module.\n" .
"At least one of these modules is required for ezmlm-web.\n";
}
# the Encode module is optional - we do not break if it is absent
my $ENCODE_SUPPORT = 1;
unless (&safely_import_module("Encode")) {
$ENCODE_SUPPORT = 0;
warn "Encoding module is not available - charset conversion will fail!";
}
################## some preparations at the beginning ##################
# drop privileges (necessary for calling gpg)
# this should not do any other harm
$UID = $EUID;
$GID = $EGID;
my $VERSION;
$VERSION = '3.3.1';
my $q = new CGI;
$q->import_names('Q');
use vars qw[$opt_c $opt_d $opt_C];
getopts('cd:C:');
# Suid stuff requires a secure path.
# The following three lines are taken from "man perlrun"
$ENV{PATH} = '/bin';
$ENV{SHELL} = '/bin/sh' if exists $ENV{SHELL};
delete @ENV{qw(IFS CDPATH ENV BASH_ENV)};
# We run suid so we can't use $ENV{'HOME'} and $ENV{'USER'} to determine the
# user. :( Don't alter this line unless you are _sure_ you have to.
my @tmp = getpwuid($>); use vars qw[$USER]; $USER=$tmp[0];
# defined by our environment - see above
use vars qw[$HOME_DIR]; $HOME_DIR=$tmp[7];
# use strict is a good thing++
# some configuration settings
use vars qw[$DEFAULT_OPTIONS $UNSAFE_RM $ALIAS_USER $LIST_DIR];
use vars qw[$QMAIL_BASE $PRETTY_NAMES $DOTQMAIL_DIR];
use vars qw[$FILE_UPLOAD $WEBUSERS_FILE $MAIL_DOMAIN $HTML_TITLE];
use vars qw[$TEMPLATE_DIR $LANGUAGE_DIR $HTML_LANGUAGE];
use vars qw[$HTML_CSS_COMMON $HTML_CSS_COLOR];
use vars qw[$MAIL_ADDRESS_PREFIX @HTML_LINKS];
use vars qw[@INTERFACE_OPTIONS_BLACKLIST];
use vars qw[$DEBUG];
# default interface template (basic/normal/expert)
use vars qw[$DEFAULT_INTERFACE_TYPE];
# some settings for encrypted mailing lists
use vars qw[$ENCRYPTION_SUPPORT $GPG_KEYRING_DEFAULT_LOCATION];
# settings for multi-domain setups
use vars qw[%DOMAINS $CURRENT_DOMAIN];
# some deprecated configuration settings - they have to be registered
# otherwise old configuration files would break
use vars qw[$HTML_CSS_FILE]; # replaced by HTML_CSS_COMMON since v3.2
# Get user configuration stuff
my $config_file;
if (defined($opt_C)) {
$opt_C =~ /^([-\w.\/]+)$/; # security check by ooyama
$config_file = $1; # Command Line
} elsif (defined($ENV{EZMLM_WEB_RC}) && $ENV{EZMLM_WEB_RC} =~ /^(\/[^\`]+)$/) {
$config_file = $1;
} elsif (-e "$HOME_DIR/.ezmlmwebrc") {
$config_file = "$HOME_DIR/.ezmlmwebrc"; # User
} elsif (-e "/etc/ezmlm-web/ezmlmwebrc") {
$config_file = "/etc/ezmlm-web/ezmlmwebrc"; # System (new style - since v2.2)
} elsif (-e "/etc/ezmlm/ezmlmwebrc") {
$config_file = "/etc/ezmlm/ezmlmwebrc"; # System (old style - up to v2.1)
} else {
&fatal_error("Unable to find config file");
}
unless (my $return = do $config_file) {
if ($@) {
&fatal_error("Failed to parse the config file ($config_file): $@");
} elsif (!defined $return) {
&fatal_error("Failed to read the config file ($config_file): $!");
} else {
# the last statement of the config file return False -> this is ok
}
}
# define some more variables, that may not be manipulated via the config
# file
# "pagedata" contains the hdf tree for clearsilver
# "pagename" refers to the template file that should be used
# "ui_template" is one of "basic", "normal" and "expert"
use vars qw[$pagedata $pagename];
use vars qw[$error $customError $warning $customWarning $success];
use vars qw[$ui_template $LOGIN_NAME];
use vars qw[$posix_enabled $child_return];
# cached data
use vars qw[%CACHED_DATA];
# available features
use vars qw[%FEATURES];
####### validate configuration and apply some default settings ##########
# do we support encrypted mailing lists an keyring management?
$ENCRYPTION_SUPPORT = 0 unless defined($ENCRYPTION_SUPPORT);
if ($ENCRYPTION_SUPPORT) {
$FEATURES{GPGEZMLM} = (0==0)
if (&safely_import_module("Mail::Ezmlm::GpgEzmlm"));
$FEATURES{GPGKEYRING} = (0==0)
if (&safely_import_module("Mail::Ezmlm::GpgKeyRing"));
# did we load any modules?
if (scalar keys %FEATURES == 0) {
warn "WARNING: all of the supported encryption modules "
. "(Mail::Ezmlm::GpgEzmlm and Mail::Ezmlm::GpgKeyRing) failed "
. "to load. Encryption support is disabled.";
$ENCRYPTION_SUPPORT = 0;
}
}
# Allow suid wrapper to override default list directory ...
if (defined($opt_d)) {
$LIST_DIR = $1 if ($opt_d =~ /^([-\@\w.\/]+)$/);
}
# check required configuration settings
&fatal_error("Configuration setting 'LIST_DIR' not specified!")
unless (defined($LIST_DIR));
&fatal_error("Configuration setting 'LANGUAGE_DIR' not specified!")
unless (defined($LANGUAGE_DIR));
&fatal_error("Configuration setting 'TEMPLATE_DIR' not specified!")
unless (defined($TEMPLATE_DIR));
# If WEBUSERS_FILE is not defined in ezmlmwebrc (as before version 2.2),
# then use former default value for compatibility
$WEBUSERS_FILE = $LIST_DIR . '/webusers' unless (defined($WEBUSERS_FILE));
# check for non-default dotqmail directory
$DOTQMAIL_DIR = $HOME_DIR unless defined($DOTQMAIL_DIR);
# check default options for new mailing lists
$DEFAULT_OPTIONS = 'aBDFGHiJkLMNOpQRSTUWx' unless defined($DEFAULT_OPTIONS);
# check default language
$HTML_LANGUAGE = 'en' unless defined($HTML_LANGUAGE);
# check stylesheet
# HTML_CSS_FILE was replaced by HTML_CSS_COMMON in v3.2
unless (defined($HTML_CSS_COMMON)) {
# HTML_CSS_COMMON is undefined - we will check the deprecated setting first
if (defined($HTML_CSS_FILE)) {
# ok - we fall back to the deprecated setting
$HTML_CSS_COMMON = $HTML_CSS_FILE;
} else {
# nothing is defined - we use the default value
$HTML_CSS_COMMON = '/ezmlm-web/default.css';
}
}
# CSS color scheme
$HTML_CSS_COLOR = '/ezmlm-web/color-red-blue.css'
unless defined($HTML_CSS_COLOR);
# check template directory
$TEMPLATE_DIR = 'template' unless defined($TEMPLATE_DIR);
# check QMAIL_BASE
$QMAIL_BASE = '/var/qmail/control' unless defined($QMAIL_BASE);
# check UNSAFE_RM
$UNSAFE_RM = 0 unless defined($UNSAFE_RM);
# check PRETTY_NAMES
$PRETTY_NAMES = 0 unless defined($PRETTY_NAMES);
# check FILE_UPLOAD
$FILE_UPLOAD = 1 unless defined($FILE_UPLOAD);
# check ALIAS_USER
$ALIAS_USER = 'alias' unless defined($ALIAS_USER);
# check HTML_TITLE
$HTML_TITLE = '' unless defined($HTML_TITLE);
# check HTML_LINKS
@HTML_LINKS = () unless defined(@HTML_LINKS);
# check DEFAULT_INTERFACE_TYPE
$DEFAULT_INTERFACE_TYPE = 'normal' unless defined($DEFAULT_INTERFACE_TYPE);
# check possible blacklist of interface options (since v3.3)
@INTERFACE_OPTIONS_BLACKLIST = () unless defined(@INTERFACE_OPTIONS_BLACKLIST);
# check the configured detault location of gnupg keyrings
$GPG_KEYRING_DEFAULT_LOCATION = ".gnupg"
unless defined($GPG_KEYRING_DEFAULT_LOCATION);
# undef CURRENT_DOMAIN if it is invalid
if (%DOMAINS) {
undef $CURRENT_DOMAIN
if (defined($CURRENT_DOMAIN) && ($CURRENT_DOMAIN eq ''));
}
# determine MAIL_DOMAIN
unless (defined($MAIL_DOMAIN) && ($MAIL_DOMAIN ne '')) {
if ((-e "$QMAIL_BASE/virtualdomains")
&& open(VD, "<$QMAIL_BASE/virtualdomains")) {
# Work out if this user has a virtual host and set input accordingly ...
while(<VD>) {
last if (($MAIL_DOMAIN) = /(.+?):$USER/);
}
close VD;
}
# use 'defaultdomain' or 'me' if no matching virtualdomain was found
if (defined($MAIL_DOMAIN) && ($MAIL_DOMAIN ne '')) {
# the prefix is empty for virtual domains
$MAIL_ADDRESS_PREFIX = "" unless (defined($MAIL_ADDRESS_PREFIX));
} else {
# Work out default domain name from qmail (for David Summers)
if (open(GETHOST, "<$QMAIL_BASE/defaultdomain")
|| open(GETHOST, "<$QMAIL_BASE/me")) {
chomp($MAIL_DOMAIN = <GETHOST>);
close GETHOST;
} else {
&fatal_error("Unable to read $QMAIL_BASE/me: $!");
}
}
}
# check MAIL_ADDRESS_PREFIX
unless (defined($MAIL_ADDRESS_PREFIX)) {
if ($USER eq $ALIAS_USER) {
$MAIL_ADDRESS_PREFIX = "";
} else {
$MAIL_ADDRESS_PREFIX = "$USER-"
}
}
# check DEBUG - enable debug messages if set > 0
$DEBUG = 0 unless defined($DEBUG);
if ( $DEBUG > 0 ) {
eval "use warnings";
eval "use CGI::Carp qw(fatalsToBrowser warningsToBrowser)";
eval "use CGI qw(:standard)";
}
# get the current login name advertised to the webserver (if it is defined)
$LOGIN_NAME = lc($ENV{'REMOTE_USER'});
# Remove leading and trailing whitespace (they are ignored by http-auth).
# Otherwise the webauth check does not work properly.
$LOGIN_NAME =~ s/^\s+//;
$LOGIN_NAME =~ s/\s+$//;
# check if the POSIX module is available
$posix_enabled = &safely_import_module("POSIX");
###################### process a request ########################
# Untaint form input ...
&untaint;
my $pagedata = &init_hdf();
my $list;
my $action;
$action = defined($q->param('action'))
? $q->param('action')
: '';
# get the list object
if (defined($q->param('list'))) {
$list = get_list_object($q->param('list'));
} else {
$list = undef;
}
# This is where we decide what to do, depending on the form state and the
# user's chosen course of action ...
# TODO: unify all these "is list param set?" checks ...
if (defined($action) && ($action eq 'show_mime_examples')) {
&output_mime_examples();
exit 0;
} elsif (%DOMAINS
&& (!defined($CURRENT_DOMAIN) || ($action eq 'domain_select'))) {
# domain support is enabled, but no domain is selected
$pagename = 'domain_select';
# undef the currently selected domain
undef $CURRENT_DOMAIN;
} elsif (!&check_permission_for_action()) {
$pagename = 'list_select';
$error = 'Forbidden';
} elsif (defined($action) && ($action eq '' || $action eq 'list_select')) {
# Default action. Present a list of available lists to the user ...
$pagename = 'list_select';
} elsif ($action eq 'show_page') {
$pagename = $q->param('pagename');
unless (-e "$TEMPLATE_DIR/$pagename.cs") {
$pagename = 'list_select';
$error = 'UnknownAction';
}
} elsif ($action eq 'subscribers') {
# display list (or part list) subscribers
if ($list) {
$pagename = 'subscribers';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'address_del') {
# Delete a subscriber ...
if ($list) {
$success = 'DeleteAddress' if (&delete_address($list));
$pagename = 'subscribers';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'address_add') {
# Add a subscriber ...
# no selected addresses -> no error
if ($list) {
$success = 'AddAddress' if (&add_address($list));
$pagename = 'subscribers';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'download_subscribers') {
# requesting a text file of all subscribers
if ($list) {
&download_subscribers($list);
# just in case we return (something bad happened)
$pagename = 'subscribers';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'subscribe_log') {
if ($list) {
&set_pagedata_subscription_log($list);
$pagename = 'show_subscription_log';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'list_delete_ask') {
# Confirm list removal
if ($list) {
$pagename = 'list_delete';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($action eq 'list_delete_do') {
# User really wants to delete a list ...
if ($list) {
$success = 'DeleteList' if (&delete_list($list));
$list = undef;
} else {
$error = 'ParameterMissing';
}
$pagename = 'list_select';
} elsif ($action eq 'list_create_ask') {
# User wants to create a list ...
$pagename = 'list_create';
} elsif ($action eq 'list_create_do') {
# create the new list
# Message if list creation is unsuccessful ...
if (defined($q->param('new_list'))) {
if ($list = &create_list($q->param('new_list'))) {
$success = 'CreateList';
$pagename = 'subscribers';
} else {
$pagename = 'list_create';
}
} else {
$error = 'ParameterMissing';
}
} elsif (($action eq 'config_ask') || ($action eq 'config_do')) {
# User wants to see/change the configuration ...
my $subset = $q->param('config_subset');
if ($list && ($subset ne '')) {
if ($subset =~ m/^RESERVED-([\w_-]*)$/) {
$pagename = $1
} elsif (($subset =~ /^[\w]*$/)
&& (-e "$TEMPLATE_DIR/config_$subset" . ".cs")) {
$pagename = 'config_' . $subset;
} else {
$pagename = '';
}
if ($pagename ne '') {
$success = 'UpdateConfig'
if (($action eq 'config_do') && &update_config($list));
} else {
$error = 'UnknownConfigPage';
warn "missing config page: $subset";
$pagename = 'list_select';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($FEATURES{GPGEZMLM} && ($action eq 'gpgezmlm_convert_ask')) {
if ($list) {
$pagename = 'gpgezmlm_convert';
} else {
$pagename = 'list_select';
$error = 'ParameterMissing';
}
} elsif ($FEATURES{GPGEZMLM} && ($action eq 'gpgezmlm_convert_enable')) {
if (!defined($list)) {
$pagename = 'list_select';
$error = 'ParameterMissing';
} elsif (ref($list) && $list->isa("Mail::Ezmlm::GpgEzmlm")) {
$pagename = 'gpgezmlm_convert';
$warning = 'GpgEzmlmConvertAlreadyEnabled';
} else {
my $enc_list = Mail::Ezmlm::GpgEzmlm->convert_to_encrypted($list->thislist());
if ($enc_list) {
$list = $enc_list;
# if the keyring already contains a secret key, then we do not
# need to generate a new one
my $keyring = get_keyring($list);
my @secret_keys = $keyring->get_secret_keys();
if ($#secret_keys >= 0) {
$pagename = 'gnupg_secret';
} else {
$pagename = 'gnupg_generate_key';
}
$success = 'GpgEzmlmConvertEnable';
} else {
$pagename = 'gpgezmlm_convert';
$warning = 'GpgEzmlmConvertEnable';
}
}
} elsif ($FEATURES{GPGEZMLM} && ($action eq 'gpgezmlm_convert_disable')) {
if (!defined($list)) {
$pagename = 'list_select';
$error = 'ParameterMissing';
} elsif (ref($list) && $list->isa("Mail::Ezmlm::GpgEzmlm")) {
my $plain_list = $list->convert_to_plaintext();
if ($plain_list) {
$list = $plain_list;
$pagename = 'gpgezmlm_convert';
$success = 'GpgEzmlmConvertDisable';
} else {
$pagename = 'gpgezmlm_convert';
$warning = 'GpgEzmlmConvertDisable';
}
} else {
$pagename = 'gpgezmlm_convert';
$warning = 'GpgEzmlmConvertAlreadyDisabled';
}
} elsif ($FEATURES{GPGKEYRING} && (($action eq 'gnupg_ask') ||
($action eq 'gnupg_do'))) {
# User wants to manage keys (only for encrypted mailing lists)
my $subset = $q->param('gnupg_subset');
if ($list && ($subset ne '')) {
if (($subset =~ /^[\w]*$/)
&& (-e "$TEMPLATE_DIR/gnupg_$subset" . ".cs")) {
if ($action eq 'gnupg_do') {
if (&manage_gnupg_keys($list)) {
# some functions may set 'success' on their own
$success = 'UpdateGnupg' unless $success;
}
} else {
# warnings are defined in the respective subs
$pagename = 'gnupg_' . $subset;
}
} else {
$error = 'UnknownGnupgPage';
warn "missing gnupg page: $subset";
$pagename = 'list_select';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($FEATURES{GPGKEYRING} && ($action eq 'gnupg_export')) {
if ($list && defined($q->param('gnupg_keyid'))) {
if (&gnupg_export_key($list, $q->param('gnupg_keyid'))) {
# the key was printed to stdout - we can exit now
# TODO: this should be something like "skip_output" instead
exit 0;
} else {
$warning = 'GnupgExportKey';
# pagename is quite random here ...
$pagename = 'gnupg_public';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfiles') {
# Edit DIR/text ...
if ($list) {
$pagename = 'textfiles';
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfile_edit') {
# edit the content of a text file
if ($list && defined($q->param('file'))) {
if (!&check_filename($q->param('file'))) {
$error = 'InvalidFileName';
$pagename = 'textfiles';
} else {
$pagename = 'textfile_edit';
}
} else {
$error = 'ParameterMissing';
$pagename = 'list_select';
}
} elsif ($action eq 'textfile_save') {
# User wants to save a new version of something in DIR/text ...
if ($list && defined($q->param('file')) && defined($q->param('content'))) {
if (!&check_filename($q->param('file'))) {
$error = 'InvalidFileName';
$pagename = 'textfiles';
} elsif (&save_text($list)) {
$pagename = 'textfiles';
$success = 'SaveFile';
} else {
$warning = 'SaveFile';
$pagename = 'textfile_edit';
}
} else {
$error = 'ParameterMissing';
if ($list) {
$pagename = 'textfiles';
} else {
$pagename = 'list_select';
}
}
} elsif ($action eq 'textfile_reset') {
# User wants to remove a customized text file (idx >= 5) ...
if ($list && defined($q->param('file'))) {
if (!&check_filename($q->param('file'))) {
$error = 'InvalidFileName';
$pagename = 'textfiles';
} elsif (Mail::Ezmlm->get_version() < 5) {
$warning = 'RequiresIDX5';
$pagename = 'textfile_edit';
} elsif ($list->is_text_default($q->param('file'))) {
$warning = 'ResetFileIsDefault';
$pagename = 'textfile_edit';
} elsif ($list->reset_text($q->param('file'))) {
$success = 'ResetFile';
$pagename = 'textfiles';
} else {
$warning = 'ResetFile';
$pagename = 'textfile_edit';
}
} else {
$error = 'ParameterMissing';
if ($list) {
$pagename = 'textfiles';
} else {
$pagename = 'list_select';
}
}
} else {
$pagename = 'list_select';
$error = 'UnknownAction';
}
# read the current state (after the changes are done)
&set_pagedata($list);
# set default action, if there is no list available and the user is
# allowed to create a new one
if (((!defined($action)) || ($action eq ''))
&& ((%DOMAINS && defined($CURRENT_DOMAIN)) || (!%DOMAINS))
&& &webauth_create_list($WEBUSERS_FILE)
&& ($pagedata->getValue('Data.Lists.0','') eq '')) {
$pagename = 'list_create';
}
# Print page and exit :) ...
&output_page;
exit;
# =========================================================================
sub init_hdf {
# initialize the data for clearsilver
my $hdf = ClearSilver::HDF->new();
&fatal_error("Language data dir ($LANGUAGE_DIR) not found!")
unless (-e $LANGUAGE_DIR);
$hdf->setValue("LanguageDir", "$LANGUAGE_DIR/");
&fatal_error("Template dir ($TEMPLATE_DIR) not found!")
unless (-e $TEMPLATE_DIR);
$hdf->setValue("TemplateDir", "$TEMPLATE_DIR/");
# easy/normal/expert
my $one_template;
my @all_templates = &get_available_interfaces();
if (defined($q->param('template'))) {
foreach $one_template (@all_templates) {
$ui_template = $q->param('template')
if ($q->param('template') eq $one_template);
}
}
$ui_template = $DEFAULT_INTERFACE_TYPE unless defined($ui_template);
$hdf->setValue("Config.UI.LinkAttrs.template", $ui_template);
# retrieve available interface sets and add them to the dataset
my %interfaces = &get_available_interfaces();
my $interface;
foreach $interface (keys %interfaces) {
$hdf->setValue("Config.UI.Interfaces.$interface",
$interfaces{$interface});
}
# retrieve available languages and add them to the dataset
my %languages = &get_available_interface_languages();
my $lang;
foreach $lang (sort keys %languages) {
$hdf->setValue("Config.UI.Languages.$lang", $languages{$lang});
}
$hdf = &load_interface_language($hdf);
$hdf->setValue("ScriptName", $ENV{SCRIPT_NAME})
if (defined($ENV{SCRIPT_NAME}));
$hdf->setValue("Stylesheet.0", "$HTML_CSS_COMMON");
$hdf->setValue("Stylesheet.1", "$HTML_CSS_COLOR");
$hdf->setValue("Config.PageTitle", "$HTML_TITLE");
my $i;
for $i (0 .. $#HTML_LINKS) {
$hdf->setValue("Config.PageLinks.$i.name", $HTML_LINKS[$i]{name});
$hdf->setValue("Config.PageLinks.$i.url", $HTML_LINKS[$i]{url});
$i++;
}
# support for encryption?
$hdf->setValue("Config.Features.GpgEzmlm", 1) if ($FEATURES{GPGEZMLM});
$hdf->setValue("Config.Features.GpgKeyRing", 1) if ($FEATURES{GPGKEYRING});
# enable some features that are only available for specific versions
# of ezmlm-idx
if (Mail::Ezmlm->get_version() >= 5.1) {
$hdf->setValue("Config.Features.KeepFiles", 1);
}
if (Mail::Ezmlm->get_version() >= 5) {
$hdf->setValue("Config.Features.LanguageSelect", 1);
$hdf->setValue("Config.Features.CharsetSelect", 1);
$hdf->setValue("Config.Features.CopyLines", 1);
}
$hdf->setValue("Config.Version.ezmlm_web", "$VERSION");
return $hdf;
}
# =========================================================================
sub output_page {
# Print the page
my $ui_template_file = "$TEMPLATE_DIR/ui/${ui_template}.hdf";
&fatal_error("UI template file ($ui_template_file) not found")
unless (-e $ui_template_file);
$pagedata->readFile($ui_template_file);
$pagedata->setValue('Data.Success', "$success") if (defined($success));
$pagedata->setValue('Data.Error', "$error") if (defined($error));
$pagedata->setValue('Data.Warning', "$warning") if (defined($warning));
$pagedata->setValue('Data.customError', "$customError")
if (defined($customError));
$pagedata->setValue('Data.customWarning', "$customWarning")
if (defined($customWarning));
$pagedata->setValue('Data.Action', "$pagename");
my $pagefile = $TEMPLATE_DIR . "/main.cs";
&fatal_error("main template ($pagefile) not found!")
unless (-e "$pagefile");
&fatal_error("sub template ($TEMPLATE_DIR/$pagename.cs) not found!")
unless (-e "$TEMPLATE_DIR/$pagename.cs");
# print http header
print "Content-Type: text/html; charset=utf-8\n\n";
my $cs = ClearSilver::CS->new($pagedata);
$cs->parseFile($pagefile);
my $output;
if ($output = $cs->render()) {
print $output;
} else {
&fatal_error($cs->displayError());
}
}
# ---------------------------------------------------------------------------
# create the list object - also check for encryption and other modules
sub get_list_object {
my $listname = shift;
my ($list, @module_order, $one_module);
@module_order = ();
# gpg-ezmlm
push(@module_order, "Mail::Ezmlm::GpgEzmlm")
if ($FEATURES{GPGEZMLM});
# default
push(@module_order, "Mail::Ezmlm");
for $one_module (@module_order) {
$list = $one_module->new("$LIST_DIR/$listname");
# invalid lists are undef
return $list if (defined($list) && (defined($list->thislist())));
}
return undef;
}
# ---------------------------------------------------------------------------
sub load_interface_language {
my ($data) = @_;
my $config_language;
# load default language (configured or 'en') first
# this will serve as a fallback
#
# we do not have to load 'en' separately as a fallback, because partly
# translated language files always include the English default for all
# missing strings
if (&check_interface_language($HTML_LANGUAGE)) {
$config_language = "$HTML_LANGUAGE";
} else {
$config_language = 'en';
}
$data->readFile("$LANGUAGE_DIR/$config_language" . ".hdf");
# check for preferred browser language
my $prefLang = &get_browser_language();
# take it, if a supported browser language was found
$config_language = $prefLang unless ($prefLang eq '');
######### temporary language setting? ############
# the default language can be overriden by the language selection form
if ($q->param('web_lang')) {
my $weblang = $q->param('web_lang');
if (&check_interface_language($weblang)) {
# load the data
$config_language = "$weblang";
} else {
# no valid language was selected - so you may ignore it
$warning = 'InvalidLanguage';
}
}
# add the setting to every link
$data->setValue('Config.UI.LinkAttrs.web_lang', "$config_language");
# import the configured resp. the temporarily selected language
$data->readFile("$LANGUAGE_DIR/$config_language" . ".hdf");
return $data;
}
# ---------------------------------------------------------------------------
sub get_browser_language {
# look for preferred browser language setting
# this code was adapted from Per Cederberg
# http://www.percederberg.net/home/perl/select.perl
# it returns an empty string, if no supported language was found
my ($lang_main, $lang_sub, $lang_name, $one_lang, @langs, @res);
my (@main_langs);
# Use language preference settings
if (defined($ENV{HTTP_ACCEPT_LANGUAGE})
&& ($ENV{HTTP_ACCEPT_LANGUAGE} ne '')) {
@langs = split(/,/, $ENV{HTTP_ACCEPT_LANGUAGE});
} else {
return "";
}
foreach $one_lang (@langs) {
# get the first part of the language setting
$one_lang =~ m/^([a-z]+)(_[A-Z]+)?/;
$lang_main = defined($1) ? $1 : "";
$lang_sub = defined($2) ? $2 : "";
$lang_name = $lang_main . $lang_sub;
# check, if it is available
if (&check_interface_language($lang_name)) {
$res[$#res+1] = $lang_name;
} else {
# remember the main languages of all non-supported regional
# languages (only if the main language ist supported)
$main_langs[$#main_langs+1] = $lang_main
if (&check_interface_language($lang_main));
}
}
# add the previously remembered main languages to the list of
# preferred languages
# useful, if someone configured 'de_AT' without the general 'de'
$res[$#res+1] = $_ foreach (@main_langs);
# if everything fails - return empty string
$res[0] = "" if ($#res lt 0);
return $res[0];
}
# ---------------------------------------------------------------------------
sub set_pagedata_domains {
my $domain_name;
# multi-domain setup?
if (defined($CURRENT_DOMAIN)) {
$pagedata->setValue("Config.UI.LinkAttrs.domain", $CURRENT_DOMAIN);
$pagedata->setValue("Data.CurrentDomain", $CURRENT_DOMAIN);
$pagedata->setValue("Data.CurrentDomain.Description",
$DOMAINS{$CURRENT_DOMAIN}{name});
}
foreach $domain_name (sort keys %DOMAINS) {
if (&webauth_visible_domain($domain_name)) {
$pagedata->setValue("Data.Domains.$domain_name",
$DOMAINS{$domain_name}{'name'});
}
}
}
# ---------------------------------------------------------------------------
sub set_pagedata_list_of_lists {
my (@files, $i, $num);
# for a multi-domain setup there are no lists available if no domain
# is selected
return (0==0) if (%DOMAINS && !defined($CURRENT_DOMAIN));
# undefined $LIST_DIR?
return (0==0) if (!defined($LIST_DIR) || ($LIST_DIR eq ''));
# Read the list directory for mailing lists.
return (0==0) unless (opendir DIR, $LIST_DIR);
@files = sort grep !/^\./, readdir DIR;
closedir DIR;
$num = 0;
# Check that they actually are lists and add good ones to pagedata ...
foreach $i (0 .. $#files) {
if ((-e "$LIST_DIR/$files[$i]/lock") &&
(&webauth_access_list($files[$i], $WEBUSERS_FILE))) {
$pagedata->setValue("Data.Lists." . $num, "$files[$i]");
$num++;
}
}
}
# ---------------------------------------------------------------------------
sub set_pagedata {
my $list = shift;
# read available list of lists
&set_pagedata_list_of_lists();
# multi domain support?
&set_pagedata_domains() if (%DOMAINS);
$pagedata->setValue("Data.LocalPrefix", $MAIL_ADDRESS_PREFIX);
$pagedata->setValue("Data.HostName", $MAIL_DOMAIN);
# modules
# TODO: someone should test, if the mysql support works
$pagedata->setValue("Data.Modules.mySQL",
($Mail::Ezmlm::MYSQL_BASE)? 1 : 0);
# permission for list creation
my $create_allowed;
# for a multi-domain setup we disallow list creation until a domain
# is selected
if (%DOMAINS && (!defined($CURRENT_DOMAIN) || ($CURRENT_DOMAIN eq ''))) {
$create_allowed = (0==1);
} else {
$create_allowed = &webauth_create_list($WEBUSERS_FILE);
}
$pagedata->setValue("Data.Permissions.Create", $create_allowed ? 1 : 0);
# file upload permission
$pagedata->setValue("Data.Permissions.FileUpload", ($FILE_UPLOAD)? 1 : 0);
# ezmlm-idx v5.0 stuff
$pagedata->setValue('Data.areDefaultTextsAvailable',
(Mail::Ezmlm->get_version() >= 5)? 1 : 0);
# get available languages for all lists
# no results for ezmlm-idx < 5.0
my $i = 0;
my $item;
foreach $item (sort Mail::Ezmlm->get_available_languages()) {
$pagedata->setValue("Data.AvailableLanguages." . $i, $item);
$i++;
}
# display webuser textfield?
$pagedata->setValue("Data.WebUser.show", (-e "$WEBUSERS_FILE")? 1 : 0);
# default username for webuser file
$pagedata->setValue("Data.WebUser.UserName", $LOGIN_NAME || 'ALL');
# list specific configuration - use defaults if no list is selected
if ($list) {
&set_pagedata4options($list, $list->getconfig());
&set_pagedata4list($list, &get_list_part());
} else {
&set_pagedata4options($list, $DEFAULT_OPTIONS);
}
# add module-specific pagedata
if ($list) {
if (ref($list) && $list->isa("Mail::Ezmlm::GpgEzmlm")) {
set_pagedata_gpgezmlm($list);
}
}
}
# ---------------------------------------------------------------------------
sub set_pagedata4list {
my $list = shift;
my $part_type = shift;
if (! -e $list->thislist() . "/lock" ) {
$warning = 'ListDoesNotExist' if ($warning eq '');
return (1==0);
}
$pagedata->setValue("Data.List.Name", get_listname($list));
$pagedata->setValue("Data.List.Address", &get_listaddress($list));
# set global or module-specific blacklist of list options
&set_pagedata_options_blacklist($list);
# do we support encryption? Show a possible keyring ...
&set_pagedata_keyring($list) if ($FEATURES{GPGKEYRING});
# is this a moderation/administration list?
&set_pagedata4part_list($list, $part_type) if ($part_type ne '');
&set_pagedata_subscribers($list, $part_type);
&set_pagedata_misc_configfiles($list);
&set_pagedata_textfiles($list);
&set_pagedata_webusers($list);
&set_pagedata_localization($list);
return (0==0);
}
# ---------------------------------------------------------------------------
sub set_pagedata_options_blacklist {
my $list = shift;
my ($item, @list_blacklist);
# check if the function "get_options_blacklist" exists for the list object
eval {@list_blacklist = $list->get_options_blacklist();};
# use an empty blacklist, if the member function was not defined
@list_blacklist = () if ($@);
foreach $item (@list_blacklist, @INTERFACE_OPTIONS_BLACKLIST) {
$pagedata->setValue("Data.List.OptionsBlackList." . $item, $item);
}
}
# ---------------------------------------------------------------------------
sub get_keyring {
my $list = shift;
my $keyring_location;
if ($list->can("get_keyring_location")) {
$keyring_location = $list->get_keyring_location();
} elsif ($GPG_KEYRING_DEFAULT_LOCATION =~ m#^/#) {
$keyring_location = $GPG_KEYRING_DEFAULT_LOCATION;
} else {
$keyring_location = $list->thislist()
. "/$GPG_KEYRING_DEFAULT_LOCATION";
}
return Mail::Ezmlm::GpgKeyRing->new($keyring_location);
}
# ---------------------------------------------------------------------------
sub set_pagedata_keyring {
my $list = shift;
my ($keyring, @gpg_keys);
$keyring = get_keyring($list);
# return without error, if the keyring is empty
return (0==0) unless (-r $keyring->get_location());
# retrieve the currently available public keys
@gpg_keys = $keyring->get_public_keys();
for (my $i = 0; $i < @gpg_keys; $i++) {
$pagedata->setValue("Data.List.gnupg_keys.public.$i.id",
$gpg_keys[$i]{id});
$pagedata->setValue("Data.List.gnupg_keys.public.$i.email",
$gpg_keys[$i]{email});
$pagedata->setValue("Data.List.gnupg_keys.public.$i.name",
$gpg_keys[$i]{name});
$pagedata->setValue("Data.List.gnupg_keys.public.$i.expires",
$gpg_keys[$i]{expires});
}
# retrieve the currently available secret keys
@gpg_keys = $keyring->get_secret_keys();
for (my $i = 0; $i < @gpg_keys; $i++) {
$pagedata->setValue("Data.List.gnupg_keys.secret.$i.id",
$gpg_keys[$i]{id});
$pagedata->setValue("Data.List.gnupg_keys.secret.$i.email",
$gpg_keys[$i]{email});
$pagedata->setValue("Data.List.gnupg_keys.secret.$i.name",
$gpg_keys[$i]{name});
$pagedata->setValue("Data.List.gnupg_keys.secret.$i.expires",
$gpg_keys[$i]{expires});
}
# enable "keyring" feature in the interface
$pagedata->setValue("Data.List.Features.GpgKeyRing", 1);
}
# ---------------------------------------------------------------------------
sub set_pagedata_gpgezmlm {
# extract hdf-data for encrypted lists
my $list = shift;
my (%config, $item);
$pagedata->setValue("Data.List.Features.GpgEzmlm", 1);
# read the configuration
%config = $list->getconfig_special();
foreach $item (keys %config) {
$pagedata->setValue("Data.List.Options.gpgezmlm_" . lc($item), $config{$item});
}
}
# ---------------------------------------------------------------------------
sub set_pagedata_misc_configfiles {
my $list = shift;
my ($item);
# Get the contents of some important files
$item = $list->getpart('prefix');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.Prefix", "$item");
# check reply_to setting
$item = $list->getpart('headeradd');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.HeaderAdd", "$item");
$pagedata->setValue("Data.List.Options.special_replytoself", 1)
if (&is_reply_to_self("$item"));
# 'headerremove' is ignored if 'headerkeep' exists (since ezmlm-idx v5)
if ((Mail::Ezmlm->get_version() >= 5.1)
&& (-e $list->thislist() . "/headerkeep")) {
$item = $list->getpart('headerkeep');
$pagedata->setValue("Data.List.HeaderKeep", "$item");
} else {
$item = $list->getpart('headerremove');
$pagedata->setValue("Data.List.HeaderRemove", "$item");
}
# 'mimeremove' is ignored if 'mimekeep' exists (since ezmlm-idx v5)
if ((Mail::Ezmlm->get_version() >= 5.1)
&& (-e $list->thislist() . "/mimekeep")) {
$item = $list->getpart('mimekeep');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.MimeKeep", "$item");
} else {
$item = $list->getpart('mimeremove');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.MimeRemove", "$item");
}
if (Mail::Ezmlm->get_version() >= 5) {
$item = $list->getpart('copylines');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.CopyLines", "$item");
}
$item = $list->getpart('mimereject');
$item = '' unless defined($item);
$pagedata->setValue("Data.List.MimeReject", "$item");
$item = $list->get_text_content('trailer');
my $content_webencoded = '';
if ( defined($item) ) {
my( @_charset, $charset);
@_charset = split(':',$list->get_charset());
if ( $_charset[0] eq '' ) {
$charset = 'us-ascii';
warn "Charset not set. Using default \"us-ascii\" ";
} else {
$charset = $_charset[0];
}
# first decode from web (usually utf8), then encode to charset of the list
eval { $content_webencoded = Encode::encode("utf8", Encode::decode($charset, $item)); };
if ($@) {
$content_webencoded = $item;
# no warning, if the encoding support is not available
warn "Conversion failed for charset '$charset'" if ($ENCODE_SUPPORT);
}
}
$pagedata->setValue("Data.List.TrailingText", "$content_webencoded");
# read message size limits
$item = $list->getpart('msgsize');
$item = '' unless defined($item);
$item =~ m/^\s*(\d*)\s*:\s*(\d*)\s*$/;
$pagedata->setValue("Data.List.MsgSize.Max", "$1") if defined($1);
$pagedata->setValue("Data.List.MsgSize.Min", "$2") if defined($2);
}
# ---------------------------------------------------------------------------
sub set_pagedata_subscribers {
my ($list, $part_type) = @_;
my ($i, $address, $addr_name, %pretty);
$i = 0;
tie %pretty, "DB_File", $list->thislist() . "/webnames" if ($PRETTY_NAMES);
foreach $address (sort $list->subscribers($part_type)) {
if ($address ne '') {
$pagedata->setValue("Data.List.Subscribers." . $i . '.address',
"$address");
$addr_name = ($PRETTY_NAMES)? $pretty{$address} : '';
$pagedata->setValue("Data.List.Subscribers." . $i . '.name',
$addr_name) if (defined($addr_name));
}
$i++;
}
untie %pretty if ($PRETTY_NAMES);
}
# ---------------------------------------------------------------------------
sub set_pagedata_textfiles {
# set the names of the textfiles of this list
my $list = shift;
my ($i, @files, $item);
@files = sort $list->get_available_text_files();
$i = 0;
foreach $item (@files) {
if ($list->is_text_default($item)) {
$pagedata->setValue('Data.List.DefaultFiles.' . $i , "$item");
} else {
$pagedata->setValue('Data.List.CustomizedFiles.' . $i , "$item");
}
$i++;
}
# text file specified?
if (defined($q->param('file')) && ($q->param('file') ne '')
&& ($q->param('file') =~ m/^[\w-]*$/)) {
my ($content, $charset, @_charset);
$content = $list->get_text_content($q->param('file'));
# get character set of current list (ignore ":Q" prefix)
@_charset = split(':',$list->get_charset());
if ( $_charset[0] eq '' ) {
# use default for ezmlm-idx<5.0
$charset = 'us-ascii';
warn "Charset not set. Using default \"us-ascii\" ";
} else {
$charset = $_charset[0];
}
my $content_utf8;
eval { $content_utf8 = Encode::encode ("utf8", Encode::decode($charset, $content)); };
# use $content if conversion failed somehow
if ($@) {
$content_utf8 = $content;
# no warning, if the encoding support is not available
warn "Conversion failed for charset '$charset'"
if ($ENCODE_SUPPORT);
}
$pagedata->setValue("Data.List.File.Name", $q->param('file'));
$pagedata->setValue("Data.List.File.Content", "$content_utf8");
$pagedata->setValue("Data.List.File.isDefault",
$list->is_text_default($q->param('file')) ? 1 : 0);
}
}
# ---------------------------------------------------------------------------
sub set_pagedata_localization {
my $list = shift;
my ($i, $item);
# get available languages for this list
# no result for ezmlm-idx < 5
$i = 0;
foreach $item (sort $list->get_available_languages()) {
$pagedata->setValue("Data.List.AvailableLanguages." . $i, $item);
$i++;
}
# charset of the list
if (Mail::Ezmlm->get_version() >= 5) {
my $charset = $list->get_charset();
$charset =~ s/^#.*$//m;
$pagedata->setValue('Data.List.CharSet', "$charset");
}
$pagedata->setValue('Data.List.Language', $list->get_lang());
}
# ---------------------------------------------------------------------------
sub set_pagedata_webusers {
my $list = shift;
my ($listname, $webusers);
$listname = get_listname($list);
# retrieve the users of the list by reading the webusers file
if (open(WEBUSER, "<$WEBUSERS_FILE")) {
while(<WEBUSER>) {
# ok - this is very short:
# $webusers becomes the matched group as soon as we find the
# line of the list - and: no, we do not need "=~" instead of "="
last if (($webusers) = m{^$listname\s*\:\s*(.+)$});
}
close WEBUSER;
}
# set default if there was no list definition
$webusers ||= $LOGIN_NAME || 'ALL';
$pagedata->setValue("Data.List.WebUsers", "$webusers");
}
# ---------------------------------------------------------------------------
sub set_pagedata4options {
my $list = shift;
my $options = shift;
# useful e.g. for lists with a missing config file (e.g. an gpg-ezmlm
# mailing list, that was converted outside of ezmlm-web)
$options = $DEFAULT_OPTIONS unless defined($options);
my($i, $key, $state, $value, $list_dir);
$i = 0;
$key = lc(substr($options, $i, 1));
# parse the first part of the options string
while ($key =~ m/\w/) {
# scan the first part of the options string for lower case letters
$state = ($options =~ /^\w*$key\w*\s*/);
# set the lower case option
$pagedata->setValue("Data.List.Options." . $key , ($state)? 1 : 0);
# also set the reverse value - see cs macro "check_active_selection"
$pagedata->setValue("Data.List.Options." . uc($key) , ($state)? 0 : 1);
$i++;
$key = lc(substr($options,$i,1));
}
# scan the config for settings
for ($i=0; $i<=9; $i++) {
unless (($i eq 1) || ($i eq 2)) {
$state = ($options =~ /\s-$i (?:'(.+?)')/);
# store the retrieved value (if possible)
$value = $1;
# reset "state" if the owner address starts with '/'
$state = (0==1) if (($i == 5) && ($state) && ($value =~ m/^\//));
unless ($state) {
# set default values
if ($i eq 0) {
$value = 'mainlist@' . $MAIL_DOMAIN;
} elsif ($i eq 3) {
$value = 'from_address@domain.org';
} elsif ($i eq 4) {
$value = '-t24 -m30 -k64';
} elsif ($i eq 5) {
$value = 'owner_address@domain.org';
} elsif ($i eq 6) {
$value = 'host:port:user:password:database:table';
} elsif (($i >= 7) && ($i <= 9)) {
if (defined($list)) {
$value = $list->thislist() . "/mod";
} else {
$value = "mod";
}
}
}
$pagedata->setValue("Data.List.Settings." . $i . ".value", $value);
$pagedata->setValue("Data.List.Settings." . $i . ".state",
$state ? 1 : 0);
}
}
# the list dependent stuff follows - we can stop if no list is selected
return unless (defined($list));
$list_dir = $list->thislist();
# the options "tpxmsr" are used to create a default value
# if they are unset, the next ezmlm-make will remove the appropriate files
# but: these files are used, if they exist - regardless of the flag
# we will look for the files, if someone created them without ezmlm-make
# this is easier for users, as the options now represent the current
# behaviour of the list and not the configured flag value
# this is especially necessary for "trailer", as this file can be created
# via ezmlm-web without touching the flag
$pagedata->setValue("Data.List.Options.t" , 1)
if (-e "$list_dir/trailer");
$pagedata->setValue("Data.List.Options.f" , 1)
if (-e "$list_dir/prefix");
$pagedata->setValue("Data.List.Options.m" , 1)
if (-e "$list_dir/modpost");
$pagedata->setValue("Data.List.Options.s" , 1)
if (-e "$list_dir/modsub");
$pagedata->setValue("Data.List.Options.r" , 1)
if (-e "$list_dir/remote");
# the option 'x' is always off, as we use it for resetting - this
# should be easier to understand for users
$pagedata->setValue("Data.List.Options.x" , 0);
}
# ---------------------------------------------------------------------------
sub download_subscribers {
# return a list of subscribers of a list for download
my $list = shift;
my ($listname, $filename, $part_type);
my (%pretty, $address, $address_name, @subscribers);
$listname = get_listname($list);
if (defined($q->param('part'))) {
$part_type = $q->param('part');
$filename = "mailinglist-$listname-$part_type.txt";
} else {
$filename = "mailinglist-$listname-subscribers.txt";
}
tie %pretty, "DB_File", $list->thislist() . "/webnames" if ($PRETTY_NAMES);
foreach $address (sort $list->subscribers($part_type)) {
if ($address ne '') {
if ($PRETTY_NAMES) {
$address_name = $pretty{$address};
if ($address_name eq '') {
push @subscribers, $address;
} else {
push @subscribers, "$address_name <$address>";
}
} else {
push @subscribers, $address;
}
}
}
untie %pretty if ($PRETTY_NAMES);
if ($#subscribers lt 0) {
$warning = 'EmptyList';
return (1==0);
}
print "Content-Type: text/plain\n";
# suggest a download filename
# (taken from http://www.bewley.net/perl/download.pl)
print "Content-Disposition: attachment; filename=$filename\n";
print "Content-Description: exported subscribers list of $listname\n\n";
foreach $address (@subscribers) {
print "$address\r\n";
}
exit;
}
# ---------------------------------------------------------------------------
sub check_filename {
my $filename = shift;
return ($filename =~ m/[^\w-]/) ? (1==0) : (0==0);
}
# ---------------------------------------------------------------------------
sub get_list_part {
# return the name of the part list (deny, allow, mod, digest or '')
if (defined($q->param('part'))) {
$q->param('part') =~ m/^(allow|deny|digest|mod)$/;
return $1;
} else {
return '';
}
}
# ---------------------------------------------------------------------------
sub get_dotqmail_files {
my $list = shift;
my (@files, $qmail_prefix);
# get the location of the dotqmail files of the list
# read 'dot' for idx v5
$qmail_prefix = $list->getpart('dot');
# untaint content (we trust in it)
if ($qmail_prefix) {
$qmail_prefix =~ m/^(.*)$/;
$qmail_prefix = $1;
}
# read 'config' (line starts with "T") for idx v4
unless ($qmail_prefix) {
my $config = $list->getpart('config');
$config =~ m/^T:(.*)$/m;
$qmail_prefix = $1;
}
chomp($qmail_prefix);
# return without result and print a warning, if no dotqmail files were found
unless ($qmail_prefix) {
warn "[ezmlm-web]: could not get the location of the dotqmail files of this list";
return ();
}
# get list of existing files (remove empty entries)
@files = grep {/./} map
{ (-e "$qmail_prefix$_")? "$qmail_prefix$_" : '' } (
'',
'-default',
'-owner',
'-return-default',
'-reject-default',
'-accept-default',
'-confirm-default',
'-discard-default',
'-digest-owner',
'-digest',
'-digest-return-default');
return @files;
}
# ---------------------------------------------------------------------------
# check if the input is a quoted string and decode it if necessary
# a quoted string could look like the following:
# =?ISO-8859-1?Q?S=E9rgio?= <sergio@example.org>
# as a regex:
# .*=\?ISO-[^\?]+\?Q\?.*\?=.*
sub decode_quoted_string {
my ($input) = @_;
my ($pre_text, $post_text, $charset, $encoded, $decoded);
if ($input =~ m/^(.*)=\?(ISO-[^\?]+)\?Q\?(.*)\?=(.*)$/) {
$pre_text = $1;
$charset = $2;
$encoded = $3;
$post_text = $4;
# decode the "quoted printable" encoding
$decoded = decode_qp($encoded);
# try to decode according to the given charset
eval { $decoded = Encode::decode($charset, $decoded); };
return $pre_text . $decoded . $post_text;
} else {
return $input;
}
}
# ---------------------------------------------------------------------------
sub set_pagedata_subscription_log {
my ($list) = @_;
my ($log_file, $i, $line);
my ($datetext, $epoch_seconds, $action, $action_details, $address);
$log_file = $list->thislist() . "/Log";
# break if there is no log_file
return unless (-e "$log_file");
unless (open LOG_FILE, "<$log_file") {
warn "Failed to open log file: $log_file";
$warning = 'LogFile';
return (1==0);
}
$i = 0;
while (<LOG_FILE>) {
chomp;
$line = $_;
# a line of the log file could look like the following:
# 748392136 +manual foo@bar.org Foo Bar <foo@bar.org>
# for encoded sender names see "decode_quoted_string" above
$line =~ m/^(\d+) ([+-])(\w*) ([^ ]*) ?(.*)$/;
if (defined($5)) {
$epoch_seconds = $1;
$action = $2;
$action_details = $3;
$address = decode_quoted_string($5 ? $5 : $4);
$datetext = localtime($epoch_seconds);
# the date in gmt format - this should be sufficient
$pagedata->setValue("Data.List.SubscribeLog.$i.date", $datetext);
# the the action should be +/-
$pagedata->setValue("Data.List.SubscribeLog.$i.action", $action);
# manual, probe (removal) or auto (empty details)
$pagedata->setValue("Data.List.SubscribeLog.$i.details",
$action_details);
$pagedata->setValue("Data.List.SubscribeLog.$i.address", $address);
$i++;
}
}
close LOG_FILE;
}
# ---------------------------------------------------------------------------
sub delete_list {
# Delete a list ...
my $list = shift;
my $listname = get_listname($list);
if ($UNSAFE_RM == 0) {
# This doesn't actually delete anything ... It just moves them so that
# they don't show up. That way they can always be recovered by a helpful
# sysadmin should he/she be in the mood :)
my $SAFE_DIR = "$LIST_DIR/_deleted_lists";
mkdir "$SAFE_DIR", 0700 if (! -e "$SAFE_DIR");
# look for an unused directory name
my $i = 0;
while (-e "$SAFE_DIR/$listname-$i") { $i++; }
$SAFE_DIR .= "/$listname-$i";
my @files = &get_dotqmail_files($list);
# remove list directory
my $oldfile = $list->thislist();
unless (move($oldfile, $SAFE_DIR)) {
$warning = 'SafeRemoveRenameDirFailed';
return (1==0);
}
# remove dotqmail files
foreach (@files) {
unless (move($_, "$SAFE_DIR")) {
$warning = 'SafeRemoveMoveDotQmailFailed';
return (1==0);
}
}
warn "List '$oldfile' moved (deleted)";
} else {
# This, however, does DELETE the list. I don't like the idea, but I was
# asked to include support for it so ...
my @files = &get_dotqmail_files($list);
my $olddir = $list->thislist();
if (unlink(@files) <= 0) {
$warning = 'UnsafeRemoveDotQmailFailed';
return (1==0);
}
unless (File::Path::rmtree("$LIST_DIR/$olddir")) {
$warning = 'UnsafeRemoveListDirFailed';
return (1==0);
}
warn "List '" . $list->thislist() . "' deleted";
}
# remove the authorization line from the webusers file
webauth_remove_list($listname);
return (0==0);
}
# ------------------------------------------------------------------------
sub untaint {
# Go through all the CGI input and make sure it is not tainted. Log any
# tainted data that we come accross ... See the perlsec(1) man page ...
# maybe it was read from a file - so we should untaint it
$MAIL_DOMAIN = $1 if $MAIL_DOMAIN =~ /^([\w\d\.-]+)$/;
my (@params, $i, $param);
@params = $q->param;
foreach $i (0 .. $#params) {
my(@values);
next if ($params[$i] eq 'mailaddressfile');
next if ($params[$i] eq 'gnupg_key_file');
next if ($params[$i] eq 'content');
# the button description may contain non-ascii characters - skip check
next if ($params[$i] eq 'send');
foreach $param ($q->param($params[$i])) {
next if $param eq '';
if ($param =~ /^([#-\@\w\.\/\[\]\:\n\r\>\< _"']+)$/) {
push @values, $1;
} else {
warn "Tainted input in '$params[$i]': " . $q->param($params[$i]);
}
$q->param(-name=>$params[$i], -values=>\@values);
}
}
# special stuff
# check the list name
if (defined($q->param('list'))) {
# reset the 'list' input parameter, if it contains invalid characters
if ($q->param('list') !~ m/^[\w\d\_\-\.\@]+$/) {
$warning = 'InvalidListName' if ($warning eq '');
$q->param(-name=>'list', -values=>'');
}
}
}
# ------------------------------------------------------------------------
sub check_permission_for_action {
# test if the user is allowed to modify the choosen list or to create a
# new one the user would still be allowed to fill out the create-form
# (however he got there), but the final creation is omitted
my $ret;
if (defined($action) &&
(($action eq 'list_create_ask' || $action eq 'list_create_do'))) {
$ret = &webauth_create_list($WEBUSERS_FILE);
} elsif (defined($q->param('list'))) {
$ret = &webauth_access_list($q->param('list'), $WEBUSERS_FILE);
} else {
$ret = (0==0);
}
return $ret;
}
# ------------------------------------------------------------------------
sub add_address {
# Add an address to a list ..
my $list = shift;
my ($address, $part, @addresses, $fail_count, $success_count);
$part = &get_list_part();
$fail_count = 0;
$success_count = 0;
if (($q->param('mailaddressfile')) && ($FILE_UPLOAD)) {
# Sanity check
my $fileinfo = $q->uploadInfo($q->param('mailaddressfile'));
my $filetype = $fileinfo->{'Content-Type'};
unless ($filetype =~ m{^text/}i) {
$warning = 'InvalidFileFormat';
warn "[ezmlm-web] mime type of uploaded file rejected: $filetype";
return (1==0);
}
# Handle file uploads of addresses
my($fh) = $q->param('mailaddressfile');
while (<$fh>) {
next if (/^\s*$/ or /^#/); # blank, comments
if ( /(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)/) {
chomp();
push @addresses, "$_";
} else {
$fail_count++;
}
}
# TODO: is CLOSE necessary?
}
# User typed in an address
if ($q->param('mailaddress_add') ne '') {
my ($_address_string, @_addresses);
$_address_string = $q->param('mailaddress_add');
# line breaks
$_address_string =~ s/[\r]?\n/#/g;
# delimeter
$_address_string =~ s/[,;]/#/g;
# email comments at the beginning
$_address_string =~ s/^[^@]+\s+//;
# email coments
$_address_string =~ s/[#\s][^@]+[#\s]/#/g;
# "<local@domain> --> local@domain"
$_address_string =~ s/[\s#]+<([^\s^<^#]+@[^\s^>^#]+)>/#$1/g;
# white spaces
$_address_string =~ s/\s+/#/g;
# multiple delimeter
$_address_string =~ s/#+/#/g;
# don't start with delimeter
$_address_string =~ s/^#+//g;
@_addresses = split(/#/ , $_address_string);
foreach $address (@_addresses) {
$address .= $MAIL_DOMAIN if ($address =~ /\@$/);
if ($address =~ m/(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)/) {
push @addresses, "$address";
} else {
warn "invalid address to add: $address to $part";
$warning = 'AddAddress';
}
}
}
my %pretty;
my $add;
tie %pretty, "DB_File", $list->thislist() . "/webnames" if ($PRETTY_NAMES);
foreach $address (@addresses) {
# call the "parse" function of either "Mail::Address" or "Email::Address"
# based on the perl cookbook (chapter 12_14)
# we have to disable 'strict refs' for the call
no strict 'refs';
($add) = ($mail_address_package . "::parse")->($mail_address_package, $address);
use strict 'refs';
if (($add->address() =~ m/^(\w[\w\.\!\#\$\%\&\'\`\*\+\-\/\=\?\^\{\|\}\~]*)@(\w[\-\w_\.]+)$/)
&& !($list->issub($add->address(), $part))) {
# it seems, that we cannot trust the return value of "$list->sub"
$list->sub($add->address(), $part);
if (defined($add->name()) && $PRETTY_NAMES) {
$pretty{$add->address()} = $add->name();
}
$success_count++;
} else {
$fail_count++;
}
}
untie %pretty if ($PRETTY_NAMES);
if ($fail_count gt 0) {
$warning = 'AddAddress';
return (1==0);
} elsif ($success_count eq 0) {
# no subscribers - we report an error without issuing a warning
return (1==0);
} else {
# no failures and at least one subscriber -> success
return (0==0);
}
}
# ------------------------------------------------------------------------
sub delete_address {
# Delete an address from a list ...
my $list = shift;
my @address;
my $part = &get_list_part();
return (1==0) if ($q->param('mailaddress_del') eq '');
@address = $q->param('mailaddress_del');
if ($list->unsub(@address, $part) != 1) {
$warning = 'DeleteAddress';
return (1==0);
}
if ($PRETTY_NAMES) {
my(%pretty, $add);
tie %pretty, "DB_File", $list->thislist() . "/webnames";
foreach $add (@address) {
delete $pretty{$add};
}
untie %pretty;
}
}
# ------------------------------------------------------------------------
sub set_pagedata4part_list {
# Deal with list parts ....
my($list, $part) = @_;
$pagedata->setValue("Data.List.PartType", "$part");
if ($part eq 'mod') {
# do we store things in different directories?
my $config = $list->getconfig();
# empty values represent default settings - everything else is considered as evil :)
my $postpath = $config =~ m{-7\s*'([^']+)'};
my $subpath = $config =~ m{-8\s*'([^']+)'};
my $remotepath = $config =~ m{-9\s*'([^']+)'};
$pagedata->setValue("Data.List.hasCustomizedPostModPath", ($postpath ne '')? 1 : 0);
$pagedata->setValue("Data.List.hasCustomizedSubModPath", ($subpath ne '')? 1 : 0);
$pagedata->setValue("Data.List.hasCustomizedAdminPath", ($remotepath ne '')? 1 : 0);
}
}
# ------------------------------------------------------------------------
sub create_list {
# Create a list according to user selections ...
my $listname = shift;
my ($qmail, $options, $i);
# Check if the list directory exists and create if necessary ...
unless ((-e $LIST_DIR) || (mkdir $LIST_DIR, 0700)) {
warn "Unable to create directory ($LIST_DIR): $!";
$warning = 'ListDirAccessDenied';
return undef;
}
# Some taint checking ...
$qmail = $1 if $q->param('inlocal') =~ /(?:$MAIL_ADDRESS_PREFIX)?([^\<\>\\\/\s]+)$/;
# dots have to be turned into colons
# see http://www.qmail.org/man/man5/dot-qmail.html
$qmail =~ s/\./:/g;
# dotqmail files may not contain uppercase letters
$qmail = lc($qmail);
# are there only valid characters?
if ($listname !~ m/^[\w\d\_\-\.\@]+$/) {
$warning = 'InvalidListName';
return undef;
}
# Sanity Checks ...
if ($listname eq '') {
$warning = 'EmptyListName';
return undef;
}
# the "magic" names are not allowed
if (($listname =~ m/^ALL$/i) || ($listname =~ m/^ALLOW_CREATE$/i)) {
$warning = 'ReservedListName';
return undef;
}
if ($qmail eq '') {
$warning = 'InvalidLocalPart';
return undef;
}
if (-e "$LIST_DIR/$listname/lock") {
$warning = 'ListNameAlreadyExists';
return undef;
}
if (-e "$DOTQMAIL_DIR/.qmail-$qmail") {
$warning = 'ListAddressAlreadyExists';
return undef;
}
$options = &extract_options_from_params($listname);
my($list) = new Mail::Ezmlm;
unless ($list->make(-dir=>"$LIST_DIR/$listname",
-qmail=>"$DOTQMAIL_DIR/.qmail-$qmail",
-name=>$q->param('inlocal'),
-host=>$q->param('inhost'),
-switches=>$options,
-user=>$USER)
) {
# fatal error
$customError = "[ezmlm-make] " . $list->errmsg();
return undef;
}
if (defined($q->param('list_language'))) {
if (&check_list_language($list, $q->param('list_language'))) {
$list->set_lang($q->param('list_language'));
} else {
$warning = 'InvalidListLanguage';
}
}
# handle MySQL stuff
if (defined($q->param('setting_state_6')) && $options =~ m/-6\s+/) {
$customWarning = $list->errmsg() unless ($list->createsql());
}
if (defined($q->param('webusers'))) {
# no error returned - just a warning
$warning = 'WebUsersUpdate'
unless (&update_webusers($listname, $q->param('webusers')));
}
return get_list_object($listname);
}
# ------------------------------------------------------------------------
sub extract_options_from_params {
# Work out the command line options ...
my $listname = shift;
my ($options, $settings, $i);
my ($old_options, $state, $old_key);
# NOTE: we have to define _every_ (even unchanged) setting
# as ezmlm-make removes any undefined value
if (-e "$LIST_DIR/$listname") {
# the list does already exist
my $list = get_list_object($listname);
$old_options = $list->getconfig();
$old_options = $DEFAULT_OPTIONS unless defined($old_options);
} else {
# creating a new list
$old_options = $DEFAULT_OPTIONS;
}
################ options ################
$i = 0;
$options = '';
$old_key = substr($old_options,$i,1);
# some special selections
my @avail_selections = ('archive', 'subscribe', 'posting');
# parse the first part of the options string
while ($old_key =~ m/\w/) {
# scan the first part of the options string for lower case letters
if (lc($old_key) eq 'x') {
# the 'x' setting does not really represent the mimeremove
# ezmlm-idx is ugly: 'X' -> remove file / 'x' -> reset file to default
if (-e "$LIST_DIR/$listname/mimeremove") {
$options .= 'x';
# we have to delete 'mimeremove' if the 'x' checkbox was activated
# as ezmlm-make will only reset it, if the file does not exist
unlink("$LIST_DIR/$listname/mimeremove")
if (defined($q->param('option_x')));
} else {
$options .= 'X';
}
} elsif (defined($q->param('available_option_' . uc($old_key)))) {
# inverted checkbox
my $form_var_name = "option_" . uc($old_key);
# this option was visible for the user
if (defined($q->param($form_var_name))) {
$options .= uc($old_key);
} else {
$options .= lc($old_key);
}
} elsif (defined($q->param('available_option_' . lc($old_key)))) {
# non inverted checkbox
my $form_var_name = "option_" . lc($old_key);
# this option was visible for the user
if (defined($q->param($form_var_name))) {
$options .= lc($old_key);
} else {
$options .= uc($old_key);
}
} elsif (&is_option_in_selections(lc($old_key))) {
# enabled due to some special selection
$options .= lc($old_key);
} elsif (&is_option_in_selections(uc($old_key))) {
# disabled due to some special selection
$options .= uc($old_key);
} elsif ("cevz" =~ m/$old_key/i) {
# ignore invalid settings (the output of "getconfig" is really weird!)
} else {
# import the previously set option
$options .= $old_key;
}
$i++;
$old_key = substr($old_options,$i,1);
}
############### settings ################
for ($i=0; $i<=9; $i++) {
if (defined($q->param('available_setting_' . $i))) {
# this setting was visible for the user
if (defined($q->param("setting_state_$i"))) {
$options .= " -$i '" . $q->param("setting_value_$i") . "'";
} else {
if ($i != 5) {
# everything except for the "owner" attribute:
# do not set the value to an empty string,
# as ezmlm-idx 5.0 does not work correctly for this case
# just skip this setting - this works for 0.4x and 5.0
#$options .= " -$i ''";
} else {
# the "owner" attribute needs something special for reset:
$options .= " -5 '$LIST_DIR/$listname/Mailbox'";
}
}
} else {
# import the previous setting
$state = ($old_options =~ /\s-$i (?:'(.+?)')/);
$options .= " -$i '$1'" if ($state);
}
}
return $options;
}
# ------------------------------------------------------------------------
sub manage_gnupg_keys {
# manage gnupg keys
my $list = shift;
my ($upload_file, $subset);
$subset = $q->param('gnupg_subset');
if (defined($q->param('gnupg_key_file'))) {
$pagename = 'gnupg_public';
return &gnupg_import_key($list, $q->param('gnupg_key_file'));
} elsif (($subset eq 'public') || ($subset eq 'secret')) {
$pagename = "gnupg_$subset";
return &gnupg_remove_key($list);
} elsif ($subset eq 'generate_key') {
if (&gnupg_generate_key($list)) {
$pagename = 'gnupg_secret';
return (0==0);
} else {
$pagename = 'gnupg_generate_key';
return (0==1);
}
} else {
$error = 'UnknownAction';
return (1==0);
}
}
# ------------------------------------------------------------------------
sub gnupg_export_key {
my $list = shift;
my $keyid = shift;
my $keyring = get_keyring($list);
# get the name of the key (for the download filename)
my @all_keys = $keyring->get_public_keys();
my ($i, $key, $name);
for ($i = 0; $i < @all_keys; $i++) {
$name = $all_keys[$i]{name} if ($keyid eq $all_keys[$i]{id});
}
if ($name) {
$name =~ s/\W+/_/g;
$name .= '.asc';
} else {
$name = "public_key.asc";
}
my $key_armor;
if ($key_armor = $keyring->export_key($keyid)) {
print "Content-Type: text/plain\n";
# suggest a download filename
# (taken from http://www.bewley.net/perl/download.pl)
print "Content-Disposition: attachment; filename=$name\n";
print "Content-Description: exported key\n\n";
print $key_armor;
return (0==0);
} else {
return (0==1);
}
}
# ------------------------------------------------------------------------
sub gnupg_import_key {
my ($list, $upload_file) = @_;
my $keyring = get_keyring($list);
if ($upload_file) {
# Sanity check
my $fileinfo = $q->uploadInfo($upload_file);
my $filetype = $fileinfo->{'Content-Type'};
unless (($filetype =~ m{^text/}i)
|| ($filetype eq 'application/pgp-encrypted')) {
$warning = 'InvalidFileFormat';
warn "[ezmlm-web] mime type of uploaded file rejected: $filetype";
return (1==0);
}
# Handle key upload
my @ascii_key = <$upload_file>;
if ($keyring->import_key(join ('',@ascii_key))) {
$success = 'GnupgKeyImport';
return (0==0);
} else {
$error = 'GnupgKeyImport';
return (0==1);
}
} else {
$warning = 'GnupgNoKeyFile';
return (1==0);
}
}
# ------------------------------------------------------------------------
# cleanup child processes, that are finished
sub reap_child {
# we may not overwrite the current error setting
local $!;
wait();
$child_return = $?;
}
# ------------------------------------------------------------------------
sub gnupg_generate_key {
my $list = shift;
my ($keyring, $key_name, $key_comment, $key_size, $key_expires);
my ($child_pid);
$keyring = get_keyring($list);
if (defined($q->param('gnupg_keyname'))) {
$key_name = $q->param('gnupg_keyname');
} else {
$key_name = get_listname($list);
}
if (defined($q->param('gnupg_keycomment'))) {
$key_comment = $q->param('gnupg_keycomment');
} else {
$key_comment = "Mailing list";
}
if (defined($q->param('gnupg_keysize'))) {
$key_size = $q->param('gnupg_keysize');
} else {
$key_size = 2048;
}
if (defined($q->param('gnupg_keyexpires'))) {
$key_expires = $q->param('gnupg_keyexpires');
} else {
$key_expires = 0;
}
unless ($key_name) {
$warning = 'GnupgNoName';
return (0==1);
}
unless ($key_expires =~ m/^[0-9]+[wmy]?$/) {
$warning = 'GnupgInvalidExpiration';
return (1==0);
}
unless ($key_size =~ m/^[0-9]*$/) {
$warning = 'GnupgInvalidKeySize';
return (1==0);
}
# do the key generation - preferably in the background
if ($posix_enabled) {
# we can try to put the key generation into the background
$child_return = 0;
# we need to cleanup zombie processes
local $SIG{CHLD} = \&reap_child;
$child_pid = POSIX::fork();
if (!defined($child_pid)) {
# forking failed
warn "[ezmlm-web] failed to fork process for key generation: $!";
$error = 'GnupgGenerateKey';
return (0==1);
} elsif ($child_pid == 0) {
# this is the child process
# we will disconnect from the parent process and call gpg
# the following code is taken from "man perlipc"
chdir('/') or die "Can't chdir to /: $!";
open(STDIN, '/dev/null') or die "Can't read /dev/null: $!";
open(STDOUT, '>/dev/null') or die "Can't write to /dev/null: $!";
# the child continues ...
POSIX::setsid() or die "Can't start a new session: $!";
open(STDERR, '>&STDOUT') or die "Can't dup stdout: $!";
# now we are completely disconnected from the parent process
if ($keyring->generate_private_key($key_name, $key_comment,
&get_listaddress($list), $key_size, $key_expires)) {
# the child process finished its job
# avoid to call destructors and so on - just use "_exit" instead
# of "exit".
POSIX::_exit(0);
} else {
# report an eror back
POSIX::_exit(1);
}
} else {
# this is the parent process - we will wait for the child for about
# five seconds. If it still did not return an error, then the key
# generation seems to be running without problems.
sleep 5;
# check if the child process is still alive
if ($child_return == 0) {
# the child did return an error - it seems to run successfully
$pagename = 'gnupg_secret';
$success = 'GnupgGenerateKeyInBackground';
return (0==0);
} else {
# the child died with an error
$error = 'GnupgGenerateKey';
return (0==1);
}
}
} else {
# no POSIX module available - thus we will run the key generation
# directly. This will most likely block the web interface for some time.
if ($keyring->generate_private_key($key_name, $key_comment,
&get_listaddress($list), $key_size, $key_expires)) {
$pagename = 'gnupg_secret';
$success = 'GnupgGenerateKey';
return (0==0);
} else {
$error = 'GnupgGenerateKey';
return (0==1);
}
}
}
# ------------------------------------------------------------------------
sub gnupg_remove_key {
my ($list) = @_;
my $keyring = get_keyring($list);
my $removed = 0;
my $key_id;
my @all_keys = grep /^gnupg_key_[0-9A-F]*$/, $q->param;
foreach $key_id (@all_keys) {
$key_id =~ /^gnupg_key_([0-9A-F]*)$/;
$keyring->delete_key($1) && $removed++;
}
if ($removed == 0) {
$error = 'GnupgDelKey';
return (1==0);
} elsif ($#all_keys > $removed) {
$warning = 'GnupgDelKey';
return (0==0);
} else {
return (0==0);
}
}
# ------------------------------------------------------------------------
# save gpg-ezmlm settings
# This function should be called after all "common" list options are configured.
# Only encryption-settings are handled - the rest is ignored.
sub update_config_gpgezmlm {
my $list = shift;
my (%switches, $one_switch, $one_value, $key, @all_params, @blacklist);
my ($forbidden_switch, $is_allowed);
# which options are not allowed?
@blacklist = ("gnupg_keyring_dir", );
%switches = ();
# retrieve the configuration settings from the CGI input
@all_params = $q->param;
foreach $one_switch (@all_params) {
if ($one_switch =~ /^available_option_gpgezmlm_(\w*)$/) {
$key = lc($1);
# the gnupg directory setting may not be accessible via the web
# interface, as this would expose the private keys of other lists
# this would be VERY, VERY ugly!
# Result: we use the blacklist above
$is_allowed = (0==0);
foreach $forbidden_switch (@blacklist) {
$is_allowed = (0==1) if ($key eq $forbidden_switch);
}
if ($is_allowed) {
$switches{$key} =
defined($q->param('option_gpgezmlm_' . $key)) ? 1 : 0;
}
}
}
# Any changes? Otherwise just return.
# "scalar keys %..." calculates the length the length of a hash
if (scalar keys %switches == 0) {
return (0==0);
} else {
# update the configuration file
if ($list->update_special(%switches)) {
return (0==0);
} else {
return (1==0);
}
}
}
# ------------------------------------------------------------------------
# update the configuration of a list
# This calls the "common" list configuration update. Afterwards possible
# module-specific options are configured via "update_config_???".
sub update_config {
my $list = shift;
my $error = (1==0);
$error = (0==0) unless (update_config_common($list));
if (ref($list) && $list->isa("Mail::Ezmlm::GpgEzmlm")) {
$error = (0==0) unless (update_config_gpgezmlm($list));
}
return (!$error);
}
# ------------------------------------------------------------------------
sub update_config_common {
# Save the new user entered config ...
my $list = shift;
my ($options, @inlocal, @inhost, $old_msgsize);
$options = &extract_options_from_params(get_listname($list));
# save the settings, that are generally overwritten by ezmlm-make :(((
# good candidates are: msgsize, inhost, inlocal and outhost
# maybe there are some others?
$old_msgsize = $list->getpart('msgsize');
# Actually update the list ...
unless ($list->update($options)) {
$warning = 'UpdateConfig';
return (1==0);
}
# update trailing text
#if (defined($q->param('trailing_text'))) {
if (defined($q->param('option_t'))) {
# TODO: the trailer _must_ be followed by a newline
#$list->set_text_content('trailer', $q->param('trailing_text'));
$list->set_text_content('trailer', $list->get_text_default_content('trailer'))
unless (-e "$list->{'LIST_NAME'}/text/trailer");
} else {
# ezmlm-make automatically removes this file
}
#}
# update prefix text
if (defined($q->param('prefix'))) {
if (defined($q->param('option_f'))) {
$list->setpart('prefix', $q->param('prefix'))
} else {
# ezmlm-make automatically removes this file
}
}
# update mimeremove/keep
if (defined($q->param('mimefilter_action'))) {
if ($q->param('mimefilter_action') eq "remove") {
# the checkbox 'x' is only used for reset - so we may not write,
# if a reset was requested
$list->setpart('mimeremove', $q->param('mimefilter'))
unless (defined($q->param('option_x')));
# remove 'mimekeep' as it is dominating
my $keep_file = $list->thislist() . "/mimekeep";
unlink ($keep_file) if (-e $keep_file);
} elsif ($q->param('mimefilter_action') eq "keep") {
$list->setpart('mimekeep', $q->param('mimefilter'))
# it is not necessary to remove 'mimeremove' - see above
} else {
warn "Invalid value for 'mimefilter_action': "
. ($q->param('mimefilter_action') =~ s/\W/_/g);
}
}
# update mimereject - we do not care for 'x'
$list->setpart('mimereject', $q->param('mimereject'))
if (defined($q->param('mimereject')));
# Update headeradd if this option is visible
# afterwards we will care about a single 'options_special_replytoself'
if (defined($q->param('headeradd'))
|| defined($q->param('available_option_special_replytoself'))) {
my $headers;
if (defined($q->param('headeradd'))) {
$headers = $q->param('headeradd');
} else {
$headers = $list->getpart('headeradd');
}
chomp($headers);
if (defined($q->param('available_option_special_replytoself'))) {
if (!defined($q->param('option_special_replytoself'))
&& (&is_reply_to_self("$headers"))) {
# remove the header line
$headers =~ s/^Reply-To:\s+.*$//m;
} elsif (defined($q->param('option_special_replytoself'))
&& (!&is_reply_to_self("$headers"))) {
# add the header line
chomp($headers);
$headers .= "\nReply-To: <#l#>@<#h#>";
}
}
$list->setpart('headeradd', "$headers");
}
# update headerremove/keep
if (defined($q->param('headerfilter_action'))) {
if ($q->param('headerfilter_action') eq "remove") {
$list->setpart('headerremove', $q->param('headerfilter'));
# remove 'headerkeep' as it is dominating
my $keep_file = $list->thislist() . "/headerkeep";
unlink ($keep_file) if (-e $keep_file);
} elsif ($q->param('headerfilter_action') eq "keep") {
$list->setpart('headerkeep', $q->param('headerfilter'))
# it is not necessary to remove 'headerremove' - see above
} else {
warn "Invalid value for 'headerfilter_action': "
. ($q->param('headerfilter_action') =~ s/\W/_/g);
}
}
# 'copylines' setting (since ezmlm-idx v5)
if (defined($q->param('copylines'))) {
my $copylines;
$copylines = (defined($q->param('copylines'))) ?
$q->param('copylines') : 0;
if (defined($q->param('copylines_enabled')) && ($copylines)) {
$list->setpart('copylines', "$copylines");
} else {
my $copyfile = $list->thislist() . "/copylines";
unlink ($copyfile) if (-e $copyfile);
}
}
# 'msgsize' setting
if (defined($q->param('msgsize_max_value'))
&& defined($q->param('msgsize_min_value'))) {
my ($minsize, $maxsize);
$maxsize = (defined($q->param('msgsize_max_state'))) ?
$q->param('msgsize_max_value') : 0;
$minsize = (defined($q->param('msgsize_min_state'))) ?
$q->param('msgsize_min_value') : 0;
$list->setpart('msgsize', "$maxsize:$minsize");
} else {
# restore the original value, as ezmlm-make always overrides these
# values :(((
$list->setpart('msgsize', "$old_msgsize") if (defined($old_msgsize));
}
# update charset
# only if it is different from the previous value and the language was NOT changed
# otherwise it could overwrite the default of a new selected language
# this has to be done before updating the language
if (defined($q->param('list_charset'))) {
if ((defined($q->param('list_language')))
&& ($q->param('list_language') ne $list->get_lang())
&& ($list->get_charset() eq $q->param('list_charset'))) {
$list->set_charset('');
} else {
$list->set_charset($q->param('list_charset'));
}
}
# update language
# this _must_ happen after set_charset to avoid accidently overriding
# the default charset
if (defined($q->param('list_language'))) {
if (&check_list_language($list, $q->param('list_language'))) {
$list->set_lang($q->param('list_language'));
} else {
$warning = 'InvalidListLanguage';
}
}
# change webuser setting
if (defined($q->param('webusers'))) {
$warning = 'WebUsersUpdate'
unless (&update_webusers(get_listname($list),
$q->param('webusers')));
}
return (0==0);
}
# ------------------------------------------------------------------------
sub is_reply_to_self {
# check if the header lines of the list contain a reply-to-self line
my ($header_lines) = @_;
return (0==0) if ($header_lines =~ m/^Reply-To:\s+<#l#>@<#h#>/m);
return (1==0);
}
# ------------------------------------------------------------------------
sub is_option_in_selections {
# check if the given 'key' is defined in any of the special selection
# form fields ('archive', 'subscribe', 'posting'). Case for key matters!
my $key = shift;
my @avail_selections = ('archive', 'subscribe', 'posting');
my $one_selection;
foreach $one_selection (@avail_selections) {
my $form_name = "selection_$one_selection";
return (0==0) if (defined($q->param($form_name))
&& ($q->param($form_name) =~ m/$key/));
}
return (1==0);
}
# ------------------------------------------------------------------------
sub update_webusers {
# replace existing webusers-line or add a new one
# empty "webusers_input" results in the removal of the line
my $listname = shift;
my $webusers_input = shift;
my ($temp_file, $fh, $matched, @admins, $admin);
# Back up web users file
# generate a temporary filename (as suggested by the Perl Cookbook)
do { $temp_file = POSIX::tmpnam() }
until $fh = IO::File->new($temp_file, O_RDWR|O_CREAT|O_EXCL);
close $fh;
unless (open(TMP, ">$temp_file")) {
warn "could not open a temporary file";
return (1==0);
}
open(WU, "<$WEBUSERS_FILE");
while(<WU>) { print TMP; }
close WU; close TMP;
$matched = 0;
# remove any insecure characters (e.g. a line break :))
$webusers_input =~ s/[^\w,_\.\-\@]/ /gs;
# replace commas by space and reduce multiple space
# strip leading and trailing whitespace
$webusers_input =~ s/,/ /g;
$webusers_input =~ s/^\s+//;
$webusers_input =~ s/\s+$//;
# reduce multiple whitespaces to a single space
$webusers_input =~ s/\s+/ /g;
# turn everything into lowercase (except for "ALL")
@admins = ();
foreach $admin (split(/ /, $webusers_input)) {
$admin = lc($admin) unless ($admin eq 'ALL');
push @admins, $admin;
}
# concatenate the lowercase usernames again
$webusers_input = join(' ', @admins);
# create the updated webusers file
open(TMP, "<$temp_file");
unless (open(WU, ">$WEBUSERS_FILE")) {
warn "the webusers file ($WEBUSERS_FILE) is not writable";
return (0==1);
}
while(<TMP>) {
if ($_ =~ m/^$listname\s*:/i) {
if ($matched == 0) {
# print the new permission only if it is non-empty
# this allows to reuse the code for list removal
print WU $listname . ': ' . $webusers_input . "\n"
if ($webusers_input);
$matched = 1;
}
} else {
print WU $_;
}
}
# append the line, if there was no matching line found before
print WU $listname . ': ' . $webusers_input . "\n" if ($matched == 0);
close TMP; close WU;
unlink "$temp_file";
}
# ------------------------------------------------------------------------
sub output_mime_examples {
# print an incomplete list of possible mime types (taken from ezmlm-idx 6.0)
my $example_file = "$TEMPLATE_DIR/mime_type_examples.txt";
print "Content-Type: text/plain\n\n";
if (open(MTF, "<$example_file")) {
while (<MTF>) {
print $_;
}
close MTF;
} else {
warn "Failed to open the example file ($example_file): $!\n";
print "Failed to open the example file ($example_file): $!\n";
}
}
# ------------------------------------------------------------------------
sub get_listname {
my $list = shift;
my @list_dir = split "/", $list->thislist();
return $list_dir[$#list_dir];
}
# ------------------------------------------------------------------------
sub get_listaddress {
# Work out the address of this list ...
my $list = shift;
my $listaddress;
chomp($listaddress = $list->getpart('outlocal'));
$listaddress .= '@';
chomp($listaddress .= $list->getpart('outhost'));
return $listaddress;
}
# ------------------------------------------------------------------------
sub save_text {
# Save new text in DIR/text ...
my $list = shift;
my ($content, $charset, @_charset);
$content = $q->param('content');
@_charset = split(':',$list->get_charset());
if ( $_charset[0] eq '' ) {
$charset = 'us-ascii';
warn "Charset not set. Using default \"us-ascii\" ";
} else {
$charset = $_charset[0];
}
# untaint 'content' unconditionally (treating the whole string as a single line)
$content =~ m/^(.*)$/s;
$content = $1;
my $content_encoded;
# first decode from web ( utf8), then encode to charset of the list
eval { $content_encoded = Encode::encode($charset, Encode::decode("utf8", $content)); };
if ($@) {
$content_encoded = $content;
# no warning, if the encoding support is not available
warn "Conversion failed for charset '$charset'" if ($ENCODE_SUPPORT);
}
unless ($list->set_text_content($q->param('file'), $content_encoded)) {
$warning = 'SaveFile';
return (1==0);
}
return (0==0);
}
# ------------------------------------------------------------------------
# check if the given domain contains configurable lists for the current login
# in case of doubt: return True
# The %DOMAINS hash needs to contain a 'webusers_file' item for each domain
# or an item 'list_dir' which points to a directory containing the file
# 'webusers'. The example multidomain.conf is configured accordingly.
sub webauth_visible_domain {
my $domain_name = shift;
my $webusers_file;
if (defined($DOMAINS{$domain_name})) {
if (defined($DOMAINS{$domain_name}{webusers_file})
&& (-e $DOMAINS{$domain_name}{webusers_file})) {
$webusers_file = "$DOMAINS{$domain_name}{webusers_file}";
} elsif (defined($DOMAINS{$domain_name}{list_dir})
&& (-e $DOMAINS{$domain_name}{list_dir} . '/webusers')) {
$webusers_file = "$DOMAINS{$domain_name}{list_dir}/webusers";
} else {
# no webusers file is configured as it should be
# Grant access to this domain, since there seems to be no way to
# figure out its permission settings.
warn "[ezmlm-web] Warning: can't check visibility of domain '"
. "$domain_name' due to a missing hash key 'webusers_file' "
. "or due to a missing 'webusers' file.";
return (0==0);
}
if (&webauth_access_list('', $webusers_file)
|| &webauth_create_list($webusers_file)) {
# the user has access or create permissions within this domain
return (0==0);
} else {
# no accessible lists available
return (0==1);
}
} else {
warn "[ezmlm-web] invalid domain: $domain_name";
return (1==0);
}
}
# ------------------------------------------------------------------------
# check if the currently logged in user is allowed to access a list
# an empty listname ('') is interpreted as "is _any_ list accessible?"
sub webauth_access_list {
my $listname = shift;
my $webusers_file = shift;
# if there was no user authentication, then everything is allowed
return (0==0) if (!$LOGIN_NAME);
# Check if webusers file exists - if not, then access is granted
unless (-e "$webusers_file") {
warn "[ezmlm-web] no 'webusers' file found ('$webusers_file'): "
. "access denied.";
return (1==0);
}
# Read authentication level from webusers file. Format of this file is
# somewhat similar to the unix groups file
unless (open (USERS, "<$webusers_file")) {
warn "Unable to read webusers file ($webusers_file): $!";
$warning = 'WebUsersRead';
return (1==0);
}
# just check if _any_ list can be accessed, if $listname is ''
$listname = "[^:]+" if ($listname eq '');
# TODO: check, why "directly after creating a new list" this does not
# work without the "m" switch for the regexp - very weird!
# the same goes for webauth_create_list
# maybe the creating action changed some file access defaults?
while(<USERS>) {
if (/^($listname|ALL):/im) {
# the following line should be synchronized with the
# webauth_create_list sub
if (/^[^:]*:(|.*[\s,])($LOGIN_NAME|ALL)(,|\s|$)/m) {
close USERS;
return (0==0);
}
}
}
close USERS;
return (1==0);
}
# ---------------------------------------------------------------------------
sub webauth_create_list {
my $webusers_file = shift;
# Check if we were called with the deprecated
# argument "-c" (allow to create lists)
return (0==0) if (defined($opt_c));
# if there was no user authentication, then everything is allowed
return (0==0) if (!$LOGIN_NAME);
# Check if webusers file exists - if not, then access is granted
if (! -e "$webusers_file") {
warn "[ezmlm-web] no 'webusers' file found ('$webusers_file'): "
. "access denied.";
return (1==0);
}
# Read create-permission from webusers file.
# the special listname "ALLOW_CREATE" controls, who is allowed to do it
unless (open (USERS, "<$webusers_file")) {
warn "Unable to read webusers file ($webusers_file): $!";
$warning = 'WebUsersRead';
return (1==0);
}
while(<USERS>) {
if (/^ALLOW_CREATE:/im) {
# the following line should be synchronized with the webauth sub
if (/[:\s,]($LOGIN_NAME|ALL)(,|\s|$)/m) {
close USERS;
return (0==0);
}
}
}
close USERS;
return (1==0);
}
# ---------------------------------------------------------------------------
sub webauth_remove_list {
my $listname = shift;
# call "update_webusers" with an empty string -> removal
return (update_webusers($listname, ''));
}
# ---------------------------------------------------------------------------
sub get_available_interface_languages {
my (%languages, @files, $file);
%languages = ();
# already cached? otherwise we have to retrieve the data first
if (exists($CACHED_DATA{'interface_languages'})) {
# we only store a reference to the languages hash
%languages = %{$CACHED_DATA{'interface_languages'}};
} else {
opendir(DIR, $LANGUAGE_DIR)
or &fatal_error ("Language directory ($LANGUAGE_DIR) "
. "is not accessible!");
@files = sort grep { /.*\.hdf$/ } readdir(DIR);
close(DIR);
foreach $file (@files) {
my $hdf = ClearSilver::HDF->new();
$hdf->readFile("$LANGUAGE_DIR/$file");
substr($file, -4) = "";
my $lang_name = $hdf->getValue("Lang.Name", "$file");
$languages{$file} = $lang_name;
}
$CACHED_DATA{'interface_languages'} = \%languages;
}
return %languages;
}
# ---------------------------------------------------------------------------
sub get_available_interfaces {
my (%interfaces, @files, $file);
# already cached? otherwise we have to retrieve the data first
if (exists($CACHED_DATA{'interfaces'})) {
# we only store a reference to the interfaces hash
%interfaces = %{$CACHED_DATA{'interfaces'}};
} else {
opendir(DIR, "$TEMPLATE_DIR/ui")
or &fatal_error ("Interface directory ($TEMPLATE_DIR/ui)"
. "is not accessible!");
@files = sort grep { /.*\.hdf$/ } readdir(DIR);
close(DIR);
foreach $file (@files) {
substr($file, -4) = "";
$interfaces{$file} = $file;
}
$CACHED_DATA{'interfaces'} = \%interfaces;
}
return %interfaces;
}
# ---------------------------------------------------------------------------
sub check_interface_language {
my ($language) = @_;
my %languages = &get_available_interface_languages();
return defined($languages{$language});
}
# ---------------------------------------------------------------------------
sub check_list_language {
my ($list, $lang) = @_;
my $found = 0;
my $item;
foreach $item ($list->get_available_languages()) {
$found++ if ($item eq $q->param('list_language'));
}
return ($found > 0);
}
# ---------------------------------------------------------------------------
sub safely_import_module {
# import a module if it exists
# otherwise False is returned
my ($mod_name) = @_;
eval "use $mod_name";
if ($@) {
# we do not need the warning message
# warn "Failed to load module '$mod_name': $@";
return (1==0);
} else {
return (0==0);
}
}
# ---------------------------------------------------------------------------
sub fatal_error() {
my $text = shift;
print "Content-Type: text/html; charset=utf-8\n\n";
print "<html><head>\n";
print "<title>ezmlm-web</title></head>\n";
print "<body><h1>a fatal error occoured!</h1>\n";
print "<p><strong><big>$text</big></strong></p>\n";
print "<p>check the error log of your web server for details</p>\n";
print "</body></html>\n";
die "$text";
}
# ------------------------------------------------------------------------
# End of ezmlm-web.cgi
# ------------------------------------------------------------------------
__END__
=head1 NAME
ezmlm-web - A web configuration interface to ezmlm mailing lists
=head1 SYNOPSIS
ezmlm-web [B<-c>] [B<-C> E<lt>F<config file>E<gt>] [B<-d> E<lt>F<list directory>E<gt>]
=head1 DESCRIPTION
=over 4
=item B<-C>
Specify an alternate configuration file given as F<config file>
If not specified, ezmlm-web checks first in the users home directory, then the
current directory (filename: .ezmlmwebrc) and then F</etc/ezmlm-web/ezmlmwebrc>.
=item B<-d>
Specify an alternate directory where lists live. This is now
depreciated in favour of using a custom ezmlmwebrc, but is left for backward
compatibility.
=back
=head1 SUID WRAPPER
Create a suid binary wrapper for every (virtual) mailing list account:
ezmlm-web-make-suid john ~john/public_html/cgi-bin/ezmlm-web
=head1 DOCUMENTATION/CONFIGURATION
Please refer to the example ezmlmwebrc which is well commented, and
to the README file in this distribution.
=head1 ENCRYPTED MAILING LISTS
Please refer to README.gnupg for details on how to manage encrypted
mailing lists with ezmlm-web.
=head1 FILES
=over
=item F<./.ezmlmwebrc>
=item F<~/.ezmlmwebrc>
=item F</etc/ezmlm-web/ezmlmwebrc>
=back
=head1 AUTHORS
=over
=item Guy Antony Halse <guy-ezmlm@rucus.ru.ac.za>
=item Lars Kruse <devel@sumpfralle.de>
=back
=head1 BUGS
None known yet. Please report bugs to the author.
=head1 S<SEE ALSO>
L<ezmlm-web-make-suid(1)>, L<ezmlm(5)>, L<ezmlm-cgi(1)>, L<Mail::Ezmlm(3)>
=over
=item L<https://systemausfall.org/toolforge/ezmlm-web/>
=item L<http://rucus.ru.ac.za/~guy/ezmlm/>
=item L<http://www.ezmlm.org/>
=item L<http://www.qmail.org/>
=back
Reference in a new issue View git blame Copy permalink