#!/usr/bin/perl -T #=========================================================================== # ezmlm-web.cgi - version 2.1 - 25/09/2000 # $Id: ezmlm-web.cgi,v 1.3 2000/09/25 19:58:07 guy Exp $ # # Copyright (C) 1999/2000, Guy Antony Halse, All Rights Reserved. # Please send bug reports and comments to guy-ezmlm@rucus.ru.ac.za # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are # met: # # Redistributions of source code must retain the above copyright notice, # this list of conditions and the following disclaimer. # # Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # # Neither name Guy Antony Halse nor the names of any contributors # may be used to endorse or promote products derived from this software # without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS # IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, # THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR # PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE # LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE # POSSIBILITY OF SUCH DAMAGE. # # ========================================================================== # All user configuration happens in the config file ``ezmlmwebrc'' # POD documentation is at the end of this file # ========================================================================== # Modules to include use strict; use Getopt::Std; use Mail::Ezmlm; use Mail::Address; use DB_File; use CGI; use CGI::Carp qw(fatalsToBrowser set_message); # These two are actually included later and are put here so we remember them. #use File::Find if ($UNSAFE_RM == 1); #use File::Copy if ($UNSAFE_RM == 0); my $q = new CGI; $q->import_names('Q'); use vars qw[$opt_d $opt_C]; getopts('d:C:'); # Suid stuff requires a secure path. $ENV{'PATH'} = '/bin'; # 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($>); my $USER=$tmp[0]; # use strict is a good thing++ use vars qw[$HOME_DIR]; $HOME_DIR=$tmp[7]; use vars qw[$DEFAULT_OPTIONS %EZMLM_LABELS $UNSAFE_RM $ALIAS_USER $LIST_DIR]; use vars qw[$QMAIL_BASE $EZMLM_CGI_RC $EZMLM_CGI_URL $HTML_BGCOLOR $PRETTY_NAMES]; use vars qw[%HELPER $HELP_ICON_URL $HTML_HEADER $HTML_FOOTER $HTML_TEXT $HTML_LINK]; use vars qw[%BUTTON %LANGUAGE $HTML_VLINK $HTML_TITLE $FILE_UPLOAD $WEBUSERS_FILE]; # Get user configuration stuff if(defined($opt_C)) { require "$opt_C"; # Command Line } elsif(-e "$HOME_DIR/.ezmlmwebrc") { require "$HOME_DIR/.ezmlmwebrc"; # User } elsif(-e "/etc/ezmlm/ezmlmwebrc") { require "/etc/ezmlm/ezmlmwebrc"; # System } elsif(-e "./ezmlmwebrc") { require "./ezmlmwebrc"; # Install } else { die "Unable to read config file"; } # Allow suid wrapper to over-ride default list directory ... if(defined($opt_d)) { $LIST_DIR = $1 if ($opt_d =~ /^([-\@\w.\/]+)$/); } # If WEBUSERS_FILE is not defined in ezmlmwebrc (as before version 2.2), then use former default value for compatibility if (!defined($WEBUSERS_FILE)) { $WEBUSERS_FILE = $LIST_DIR . '/webusers' } # Work out default domain name from qmail (for David Summers) my($DEFAULT_HOST); open (GETHOST, "<$QMAIL_BASE/me") || open (GETHOST, "<$QMAIL_BASE/defaultdomain") || die "Unable to read $QMAIL_BASE/me: $!"; chomp($DEFAULT_HOST = ); close GETHOST; # Untaint form input ... &untaint; # redirect must come before headers are printed if(defined($Q::action) && $Q::action eq '[Web Archive]') { print $q->redirect(&ezmlmcgirc); exit; } # Print header on every page ... print $q->header(-pragma=>'no-cache', '-cache-control'=>'no-cache', -expires=>'-1d', '-Content-Type'=>'text/html; charset=utf-8'); print $q->start_html(-title=>$HTML_TITLE, -author=>'guy-ezmlm@rucus.ru.ac.za', -BGCOLOR=>$HTML_BGCOLOR, -LINK=>$HTML_LINK, -VLINK=>$HTML_VLINK, -TEXT=>$HTML_TEXT, -expires=>'-1d'); print $HTML_HEADER; # check permissions &check_permission_for_action == 0 || die 'Error: you are not allowed to do this!'; # This is where we decide what to do, depending on the form state and the # users chosen course of action ... unless (defined($q->param('state'))) { # Default action. Present a list of available lists to the user ... &select_list; } elsif ($Q::state eq 'select') { # User selects an action to perform on a list ... if ($Q::action eq "[$BUTTON{'create'}]") { # Create a new list ... &allow_create_list; } elsif (defined($Q::list)) { if ($Q::action eq "[$BUTTON{'edit'}]") { # Edit an existing list ... &display_list; } elsif ($Q::action eq "[$BUTTON{'delete'}]") { # Delete a list ... &confirm_delete; } } else { &select_list; # NOP - Blank input ... } } elsif ($Q::state eq 'edit') { # User chooses to edit a list my($list); $list = $LIST_DIR . '/' . $q->param('list'); if ($Q::action eq "[$BUTTON{'deleteaddress'}]") { # Delete a subscriber ... &delete_address($list); &display_list; } elsif ($Q::action eq "[$BUTTON{'addaddress'}]") { # Add a subscriber ... &add_address($list); &display_list; } elsif ($Q::action eq "[$BUTTON{'moderators'}]") { # Edit the moderators ... &part_subscribers('mod'); } elsif ($Q::action eq "[$BUTTON{'denylist'}]") { # Edit the deny list ... &part_subscribers('deny'); } elsif ($Q::action eq "[$BUTTON{'allowlist'}]") { # edit the allow list ... &part_subscribers('allow'); } elsif ($Q::action eq "[$BUTTON{'digestsubscribers'}]") { # Edit the digest subscribers ... &part_subscribers('digest'); } elsif ($Q::action eq "[$BUTTON{'configuration'}]") { # Edit the config ... &list_config; } else { # Cancel - Return a screen ... &select_list; } } elsif ($Q::state eq 'allow' || $Q::state eq 'mod' || $Q::state eq 'deny' || $q->param('state') eq 'digest') { # User edits moderators || deny || digest ... my($part); # Which list directory are we using ... if($Q::state eq 'mod') { $part = 'mod'; } elsif($Q::state eq 'deny' ) { $part = 'deny'; } elsif($Q::state eq 'allow') { $part = 'allow'; } else { $part = 'digest'; } if ($Q::action eq '[Delete Address]') { # Delete a subscriber ... &delete_address("$LIST_DIR/$Q::list", $part); &part_subscribers($part); } elsif ($Q::action eq "[$BUTTON{'addaddress'}]") { # Add a subscriber ... &add_address("$LIST_DIR/$Q::list", $part); &part_subscribers($part); } else { # Cancel - Return to the list ... &display_list; } } elsif ($Q::state eq 'confirm_delete') { # User wants to delete a list ... &delete_list if($q->param('confirm') eq "[$BUTTON{'yes'}]"); # Do it ... $q->delete_all; &select_list; } elsif ($Q::state eq 'create') { # User wants to create a list ... if ($Q::action eq "[$BUTTON{'createlist'}]") { if (&create_list) { # Return if list creation is unsuccessful ... &allow_create_list; } else { &select_list; # Else choose a list ... } } else { # Cancel ... &select_list; } } elsif ($Q::state eq 'configuration') { # User updates configuration ... if ($Q::action eq "[$BUTTON{'updateconfiguration'}]") { # Save current settings ... &update_config; &display_list; } elsif ($Q::action eq "[$BUTTON{'edittexts'}]") { # Edit DIR/text ... &list_text; } else { # Cancel - Return to list editing screen ... &display_list; } } elsif ($Q::state eq 'list_text') { # User wants to edit texts associated with the list ... if ($Q::action eq "[$BUTTON{'editfile'}]") { &edit_text; } else { &list_config; # Cancel ... } } elsif ($Q::state eq 'edit_text') { # User wants to save a new version of something in DIR/text ... &save_text if ($Q::action eq "[$BUTTON{'savefile'}]"); &list_text; } else { print "

$Q::action

$LANGUAGE{'nop'}


"; } # Print HTML footer and exit :) ... print $HTML_FOOTER, $q->end_html; exit; # ========================================================================= sub select_list { # List all mailing lists (sub directories) in the list directory. # Allow the user to choose a course of action; either editing an existing # list, creating a new one, or deleting an old one. my (@lists, @files, $i, $scrollsize); # Read the list directory for mailing lists. opendir DIR, $LIST_DIR || die "Unable to read $LIST_DIR: $!"; @files = grep !/^\./, readdir DIR; closedir DIR; # Check that they actually are lists ... foreach $i (0 .. $#files) { if (-e "$LIST_DIR/$files[$i]/lock") { $lists[$#lists + 1] = $files[$i] if (&webauth($files[$i]) == 0); } } # Keep selection box a resonable size - suggested by Sebastian Andersson $scrollsize = 25 if(($scrollsize = $#lists + 1) > 25); # Print a form $q->delete_all; print $q->startform; print $q->hidden(-name=>'state', -default=>'select'); print '
'; print $q->scrolling_list(-name=>'list', -size=>$scrollsize, -values=>\@lists) if defined(@lists); print '', $LANGUAGE{'chooselistinfo'}; print $q->submit(-name=>'action', -value=>"[$BUTTON{'create'}]"), ' ' if (&webauth_create_allowed == 0); print $q->submit(-name=>'action', -value=>"[$BUTTON{'edit'}]"), ' ' if(defined(@lists)); print $q->submit(-name=>'action', -value=>"[$BUTTON{'delete'}]") if(defined(@lists)); print '
'; print $q->endform; } # ------------------------------------------------------------------------ sub confirm_delete { # Make sure that the user really does want to delete the list! # Print a form ... $q->delete('state'); print $q->startform; print $q->hidden(-name=>'state', -default=>'confirm_delete'); print $q->hidden(-name=>'list', -default=>$q->param('list')); print '

', $LANGUAGE{'confirmdelete'}, ' ', $q->param('list'), '


'; print $q->submit(-name=>'confirm', -value=>"[$BUTTON{'no'}]"), ' '; print $q->submit(-name=>'confirm', -value=>"[$BUTTON{'yes'}]"), '
'; } # ------------------------------------------------------------------------ sub display_list { # Show a list of subscribers to the user ... my ($i, $list, $listaddress, $moderated, @subscribers, $scrollsize); # Work out the address of this list ... $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); $listaddress = &this_listaddress; # Get a list of subscribers from ezmlm ... @subscribers = $list->subscribers; # Keep selection box a resonable size - suggested by Sebastian Andersson $scrollsize = 25 if(($scrollsize = $#subscribers + 1) > 25); # Print out a form of options ... $q->delete('state'); print "

$LANGUAGE{'subscribersto'} $Q::list ($listaddress)


"; print $q->start_multipart_form; print '
'; print $q->hidden(-name=>'state', -default=>'edit'); print $q->hidden(-name=>'list', -default=>$Q::list); print $q->scrolling_list(-name=>'delsubscriber', -size=>$scrollsize, -values=>\@subscribers, -labels=>&pretty_names, -multiple=>'true') if defined(@subscribers); print ''; print ' ', ($#subscribers + 1), ' ', $LANGUAGE{'subscribers'}, '
' if defined(@subscribers); print $q->submit(-name=>'action', -value=>"[$BUTTON{'deleteaddress'}]"), '

' if defined(@subscribers); print $q->textfield(-name=>'addsubscriber', -size=>'40'), '
'; print $q->filefield(-name=>'addfile', -size=>20, -maxlength=>100), '
' if ($FILE_UPLOAD); print $q->submit(-name=>'action', -value=>"[$BUTTON{'addaddress'}]"), '

'; print '', $LANGUAGE{'additionalparts'}, ':
' if($list->ismodpost || $list->ismodsub || $list->isremote || $list->isdeny || $list->isallow || $list->isdigest); print $q->submit(-name=>'action', -value=>"[$BUTTON{'moderators'}]"), ' ' if ($list->ismodpost || $list->ismodsub || $list->isremote); print $q->submit(-name=>'action', -value=>"[$BUTTON{'denylist'}]"), ' ' if ($list->isdeny); print $q->submit(-name=>'action', -value=>"[$BUTTON{'allowlist'}]"), ' ' if ($list->isallow); print $q->submit(-name=>'action', -value=>"[$BUTTON{'digestsubscribers'}]"), ' ' if ($list->isdigest); print '

'; print $q->submit(-name=>'action', -value=>"[$BUTTON{'webarchive'}]"), ' ' if(&ezmlmcgirc); print $q->submit(-name=>'action', -value=>"[$BUTTON{'configuration'}]"), '   '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'selectlist'}]"); print '

'; print $q->endform; } # ------------------------------------------------------------------------ sub delete_list { # Delete a list ... # Fixes a bug from the previous version ... when the .qmail file has a # different name to the list. We use outlocal to handle vhosts ... my ($list, $listaddress, $listadd); $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); if ($listadd = $list->getpart('outlocal')) { chomp($listadd); } else { $listadd = $q->param('list'); } $listaddress = $1 if ($listadd =~ /-?(\w+)$/); 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 be in the mood :) use File::Copy; my ($oldfile); $oldfile = "$LIST_DIR/$Q::list"; my ($newfile); $newfile = "$LIST_DIR/.$Q::list"; move($oldfile, $newfile) or die "Unable to rename list: $!"; mkdir "$HOME_DIR/deleted.qmail", 0700 if(!-e "$HOME_DIR/deleted.qmail"); opendir(DIR, "$HOME_DIR") or die "Unable to get directory listing: $!"; my @files = map { "$HOME_DIR/$1" if m{^(\.qmail.+)$} } grep { /^\.qmail-$listaddress/ } readdir DIR; closedir DIR; foreach (@files) { unless (move($_, "$HOME_DIR/deleted.qmail/")) { die "Unable to move .qmail files: $!"; } } 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 ... if (!rmtree("$LIST_DIR/$Q::list")) { die "Unable to delete list: $!"; } opendir(DIR, "$HOME_DIR") or die "Unable to get directory listing: $!"; my @files = map { "$HOME_DIR/$1" if m{^(\.qmail.+)$} } grep { /^\.qmail-$listaddress/ } readdir DIR; closedir DIR; if (unlink(@files) <= 0) { die "Unable to delete .qmail files: $!"; } warn "List '$list->thislist()' deleted"; } } # ------------------------------------------------------------------------ sub untaint { $DEFAULT_HOST = $1 if $DEFAULT_HOST =~ /^([\w\d\.-]+)$/; # 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 ... my (@params, $i, $param); @params = $q->param; foreach $i (0 .. $#params) { my(@values); next if($params[$i] eq 'addfile'); 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); } } $q->import_names('Q'); } # ------------------------------------------------------------------------ sub check_permission_for_action { # test if the user is allowed to modify the choosen list or to create an 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 ($Q::state eq 'create') { $ret = &webauth_create_allowed(); } elsif (defined($Q::list)) { $ret = &webauth($Q::list); } else { $ret = 0; } return $ret; } # ------------------------------------------------------------------------ sub add_address { # Add an address to a list .. my ($address, $list, @addresses, $count); my ($listname, $part) = @_; $list = new Mail::Ezmlm($listname); if($q->param('addfile')) { # Sanity check die "File upload must be of type text/*" unless($q->uploadInfo($q->param('addfile'))->{'Content-Type'} =~ m{^text/}); # Handle file uploads of addresses my($fh) = $q->upload('addfile'); return unless (defined($fh)); while (<$fh>) { next if (/^\s*$/ or /^#/); # blank, comments next unless (/\@/); # email address ... chomp(); push @addresses, $_; } } else { # User typed in an address return if ($q->param('addsubscriber') eq ''); $address = $q->param('addsubscriber'); $address .= $DEFAULT_HOST if ($q->param('addsubscriber') =~ /\@$/); push @addresses, $address; } foreach $address (@addresses) { my($add) = Mail::Address->parse($address); if(defined($add->name()) && $PRETTY_NAMES) { my(%pretty); tie %pretty, "DB_File", "$LIST_DIR/$Q::list/webnames"; $pretty{$add->address()} = $add->name(); untie %pretty; } if ($list->sub($add->address(), $part) != 1) { die "Unable to subscribe to list: $!"; } $count++; } $q->delete('addsubscriber'); } # ------------------------------------------------------------------------ sub delete_address { # Delete an address from a list ... my ($list, @address); my($listname, $part) = @_; $list = new Mail::Ezmlm($listname); return if ($q->param('delsubscriber') eq ''); @address = $q->param('delsubscriber'); if ($list->unsub(@address, $part) != 1) { die "Unable to unsubscribe from list $list: $!"; } if($PRETTY_NAMES) { my(%pretty, $add); tie %pretty, "DB_File", "$LIST_DIR/$Q::list/webnames"; foreach $add (@address) { delete $pretty{$add}; } untie %pretty; } $q->delete('delsubscriber'); } # ------------------------------------------------------------------------ sub part_subscribers { my($part) = @_; # Deal with list parts .... my ($i, $list, $listaddress, @subscribers, $moderated, $scrollsize, $type); # Work out the address of this list ... $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); $listaddress = &this_listaddress; if($part eq 'mod') { # Lets know what is moderated :) # do we store things in different directories? my $config = $list->getconfig; my($postpath) = $config =~ m{7\s*'([^']+)'}; my($subpath) = $config =~ m{8\s*'([^']+)'}; my($remotepath) = $config =~ m{9\s*'([^']+)'}; $moderated = '' if ($postpath); $moderated .= "[$LANGUAGE{'posting'}]" if ($list->ismodpost); $moderated .= '' if ($postpath); $moderated .= '' if ($subpath); $moderated .= " [$LANGUAGE{'subscription'}]" if($list->ismodsub); $moderated .= '' if ($subpath); $moderated .= '' if ($remotepath); $moderated .= " [$LANGUAGE{'remoteadmin'}]" if($list->isremote); $moderated .= '' if ($remotepath); } # What type of sublist is this? ($type) = $Q::action =~ m/^\[(.+)\]$/; # Get a list of moderators from ezmlm ... @subscribers = $list->subscribers($part); # Keep selection box a resonable size - suggested by Sebastian Andersson $scrollsize = 25 if(($scrollsize = $#subscribers + 1) > 25); # Print out a form of options ... $q->delete('state'); print "

$type $LANGUAGE{'for'} $listaddress


"; print "
$moderated

" if(defined($moderated)); print $q->start_multipart_form; print '

'; print $q->hidden(-name=>'state', -default=>$part); print $q->hidden(-name=>'list', -default=>$Q::list), "\n"; print $q->scrolling_list(-name=>'delsubscriber', -size=>$scrollsize, -values=>\@subscribers, -multiple=>'true', -labels=>&pretty_names) if defined(@subscribers); print '
'; print $q->submit(-name=>'action', -value=>"[$BUTTON{'deleteaddress'}]"), '

' if defined(@subscribers); print $q->textfield(-name=>'addsubscriber', -size=>'40'), '
'; print $q->filefield(-name=>'addfile', -size=>20, -maxlength=>100), '
' if ($FILE_UPLOAD); print $q->submit(-name=>'action', -value=>"[$BUTTON{'addaddress'}]"), '

'; print $q->submit(-name=>'action', -value=>"[$BUTTON{'subscribers'}]"); print '

'; print $q->endform; } # ------------------------------------------------------------------------ sub allow_create_list { # Let the user select options for list creation ... my($username, $hostname, %labels, $j); # Work out if this user has a virtual host and set input accordingly ... if(-e "$QMAIL_BASE/virtualdomains") { open(VD, "<$QMAIL_BASE/virtualdomains") || warn "Can't read virtual domains file: $!"; while() { last if(($hostname) = /(.+?):$USER/); } close VD; } if(!defined($hostname)) { $username = "$USER-" if ($USER ne $ALIAS_USER); $hostname = $DEFAULT_HOST; } # Print a form of options ... $q->delete_all; print '

', $LANGUAGE{'createnew'}, '


'; print $q->startform; print $q->hidden(-name=>'state', -value=>'create'); print '', $LANGUAGE{'listname'}, ': ', $q->textfield(-name=>'list', -size=>'20'), '

'; print '', $LANGUAGE{'listaddress'}, ': '; print $q->textfield(-name=>'inlocal', -default=>$username, -size=>'10'); print ' @ ', $q->textfield(-name=>'inhost', -default=>$hostname, -size=>'30'), '

'; print '

', $LANGUAGE{'listoptions'}, ':'; &display_options($DEFAULT_OPTIONS); # Allow creation of mysql table if the module allows it if($Mail::Ezmlm::MYSQL_BASE) { print '

', $q->checkbox(-name=>'sql', -label=>$LANGUAGE{'mysqlcreate'}, -on=>1); print ' '; } print '

', $LANGUAGE{'allowedtoedit'}, ': ', $q->textfield(-name=>'webusers', -value=>$ENV{'REMOTE_USER'}||'ALL', -size=>'30'), ' ', '
', $HELPER{'allowedit'}, '' if(-e "$WEBUSERS_FILE"); print '

', $q->submit(-name=>'action', -value=>"[$BUTTON{'createlist'}]"), ' '; print $q->reset(-value=>"[$BUTTON{'resetform'}]"), ' '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'cancel'}]"); print $q->endform; } # ------------------------------------------------------------------------ sub create_list { # Create a list acording to user selections ... # Check the list directory exists and create if necessary ... if(!-e $LIST_DIR) { die "Unable to create directory ($LIST_DIR): $!" unless mkdir $LIST_DIR, 0700; } my ($qmail, $listname, $options, $i); # Some taint checking ... $qmail = $1 if $q->param('inlocal') =~ /(?:$USER-)?([^\<\>\\\/\s]+)$/; $listname = $q->param('list'); $listname =~ s/ /_/g; # In case some git tries to put a space in the file name # Sanity Checks ... return 1 if ($listname eq '' || $qmail eq ''); if(-e ("$LIST_DIR/$listname/lock") || -e ("$HOME_DIR/.qmail-$qmail")) { print "

List '$listname' already exists :(

"; return 1; } # Work out the command line options foreach $i (grep {/\D/} keys %EZMLM_LABELS) { if (defined($q->param($i))) { $options .= $i; } else { $options .= uc($i); } } foreach $i (grep {/\d/} keys %EZMLM_LABELS) { if (defined($q->param($i))) { $options .= " -$i '" . $q->param("$i-value") . "'"; } } my($list) = new Mail::Ezmlm; unless ($list->make(-dir=>"$LIST_DIR/$listname", -qmail=>"$HOME_DIR/.qmail-$qmail", -name=>$q->param('inlocal'), -host=>$q->param('inhost'), -switches=>$options, -user=>$USER) ) { die 'List creation failed', $list->errmsg(); } # handle MySQL stuff if($q->param('sql') && $options =~ m/-6\s+/) { unless($list->createsql()) { die 'SQL table creation failed: ', $list->errmsg(); } } &update_webusers(); return 0; } # ------------------------------------------------------------------------ sub list_config { # Allow user to alter the list configuration ... my ($list, $listaddress, $listname, $options); my ($headeradd, $headerremove, $mimeremove, $prefix, $j); # Store some variables before we delete them ... $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); $listname = $q->param('list'); $listaddress = &this_listaddress; # Print a form of options ... $q->delete_all; print '

', $LANGUAGE{'editconfiguration'}, '


'; print $q->startform; print $q->hidden(-name=>'state', -value=>'configuration'); print $q->hidden(-name=>'list', -value=>$listname); print '', $LANGUAGE{'listname'}, ": $listname
"; print "$LANGUAGE{'listaddress'}: $listaddress

"; print '', $LANGUAGE{'listoptions'}, ':
'; # Print a list of options, selecting the ones that apply to this list ... &display_options($list->getconfig); # Get the contents of the headeradd, headerremove, mimeremove and prefix files $headeradd = $list->getpart('headeradd'); $headerremove = $list->getpart('headerremove'); $mimeremove = $list->getpart('mimeremove'); $prefix = $list->getpart('prefix'); print '

', $LANGUAGE{'prefix'}, ': ', $q->textfield(-name=>'prefix', -default=>$prefix, -size=>12), ' ' if defined($prefix); print '

', $LANGUAGE{'headerremove'}, ':
', $q->textarea(-name=>'headerremove', -default=>$headerremove, -rows=>5, -columns=>70); print '

', $LANGUAGE{'headeradd'}, ':
', $q->textarea(-name=>'headeradd', -default=>$headeradd, -rows=>5, -columns=>70); print '

', $LANGUAGE{'mimeremove'}, ':
', $q->textarea(-name=>'mimeremove', -default=>$mimeremove, -rows=>5, -columns=>70) if defined($mimeremove); if(open(WEBUSER, "<$WEBUSERS_FILE")) { my($webusers); while() { last if (($webusers) = m{^$listname\s*\:\s*(.+)$}); } close WEBUSER; $webusers ||= $ENV{'REMOTE_USER'} || 'ALL'; print '

', $LANGUAGE{'allowedtoedit'}, ': ', $q->textfield(-name=>'webusers', -value=>$webusers, -size=>'30'), ' ', '
', $HELPER{'allowedit'}, ''; } print '

', $q->submit(-name=>'action', -value=>"[$BUTTON{'updateconfiguration'}]"), ' '; print $q->reset(-value=>"[$BUTTON{'resetform'}]"), ' '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'cancel'}]"), ' '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'edittexts'}]"); print $q->endform; } # ------------------------------------------------------------------------ sub update_config { # Save the new user entered config ... my ($list, $options, $i, @inlocal, @inhost); $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); # Work out the command line options ... foreach $i (grep {/\D/} keys %EZMLM_LABELS) { if (defined($q->param($i))) { $options .= $i; } else { $options .= uc($i); } } foreach $i (grep {/\d/} keys %EZMLM_LABELS) { if (defined($q->param($i))) { $options .= " -$i '" . $q->param("$i-value") . "'"; } } # Actually update the list ... unless($list->update($options)) { die "List update failed"; } # Update headeradd, headerremove, mimeremove and prefix ... $list->setpart('headeradd', $q->param('headeradd')); $list->setpart('headerremove', $q->param('headerremove')); $list->setpart('mimeremove', $q->param('mimeremove')) if defined($q->param('mimeremove')); $list->setpart('prefix', $q->param('prefix')) if defined($q->param('prefix')); &update_webusers(); } # ------------------------------------------------------------------------ sub update_webusers { # replace existing webusers-line or add a new one if($Q::webusers) { # Back up web users file open(TMP, ">/tmp/ezmlm-web.$$"); open(WU, "<$WEBUSERS_FILE"); while() { print TMP; } close TMP; close WU; open(TMP, "$WEBUSERS_FILE"); while() { if(/^$Q::list\s*:/) { print WU "$Q::list\: $Q::webusers\n"; } else { print WU; } } close TMP; close WU; unlink "/tmp/ezmlm-web.$$"; } } # ------------------------------------------------------------------------ sub this_listaddress { # Work out the address of this list ... Used often so put in its own subroutine ... my ($list, $listaddress); $list = new Mail::Ezmlm("$LIST_DIR/$Q::list"); chomp($listaddress = $list->getpart('outlocal')); $listaddress .= '@'; chomp($listaddress .= $list->getpart('outhost')); return $listaddress; } # ------------------------------------------------------------------------ sub list_text { # Show a listing of what is in DIR/text ... my(@files, $list); $list = $LIST_DIR . '/' . $q->param('list'); # Read the list directory for text ... opendir DIR, "$list/text" || die "Unable to read DIR/text: $!"; @files = grep !/^\./, readdir DIR; closedir DIR; # Print a form ... $q->delete('state'); print $q->startform; print $q->hidden(-name=>'state', -default=>'list_text'); print $q->hidden(-name=>'list', -default=>$q->param('list')); print '

'; print $q->scrolling_list(-name=>'file', -values=>\@files); print ''; print $q->submit(-name=>'action', -value=>"[$BUTTON{'editfile'}]"), ' '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'cancel'}]"); print '

', $LANGUAGE{'edittextinfo'}, '

'; print $q->endform; } # ------------------------------------------------------------------------ sub edit_text { # Allow user to edit the contents of DIR/text ... my ($content); my($list) = new Mail::Ezmlm("$LIST_DIR/$Q::list"); $content = $list->getpart("text/$Q::file"); # Print a form ... $q->delete('state'); print '

', $LANGUAGE{'editingfile'}, ': ', $Q::file, '

'; print '
'; print $q->startform; print $q->hidden(-name=>'state', -default=>'edit_text'); print $q->hidden(-name=>'list', -default=>$q->param('list')); print $q->hidden(-name=>'file', -default=>$q->param('file')); print $q->textarea(-name=>'content', -default=>$content, -rows=>'25', -columns=>'72'); print ''; print $q->submit(-name=>'action', -value=>"[$BUTTON{'savefile'}]"), ' '; print $q->reset(-value=>"[$BUTTON{'resetform'}]"), ' '; print $q->submit(-name=>'action', -value=>"[$BUTTON{'cancel'}]"); print '

', $LANGUAGE{'editfileinfo'}; print $q->endform; print '

' } # ------------------------------------------------------------------------ sub save_text { # Save new text in DIR/text ... my ($list) = new Mail::Ezmlm("$LIST_DIR/$Q::list"); $list->setpart("text/$Q::file", $q->param('content')); } # ------------------------------------------------------------------------ sub webauth { # Check if webusers file exists - if not, then access is granted return 0 if (! -e "$WEBUSERS_FILE"); # Read authentication level from webusers file. Format of this file is # somewhat similar to the unix groups file my($listname) = @_; open (USERS, "<$WEBUSERS_FILE") || die "Unable to read webusers file ($WEBUSERS_FILE): $!"; while() { if (/^($listname|ALL)\:/i) { if (/(\:\s*|,\s+)((?:$ENV{'REMOTE_USER'})|(?:ALL))\s*(,|$)/) { close USERS; return 0; } } } close USERS; return 1; } # --------------------------------------------------------------------------- sub webauth_create_allowed { # Check if webusers file exists - if not, then access is granted return 0 if (! -e "$WEBUSERS_FILE"); # Read create-permission from webusers file. # the special listname "ALLOW_CREATE" controls, who is allowed to do it open (USERS, "<$WEBUSERS_FILE") || die "Unable to read webusers file ($WEBUSERS_FILE): $!"; while() { if (/^ALLOW_CREATE:/i) { if (/(\:\s*|,\s+)((?:$ENV{'REMOTE_USER'})|(?:ALL))\s*(,|$)/) { close USERS; return 0; } } } close USERS; return 1; } # --------------------------------------------------------------------------- sub display_options { my($opts) = shift; my($i, $j); print ""; print ''; $j++; if ($j >= 3) { $j = 0; print ''; } print '
'; foreach $i (grep {/\D/} keys %EZMLM_LABELS) { if ($opts =~ /^\w*$i\w*\s*/) { print $q->checkbox(-name=>$i, -value=>$i, -label=>$EZMLM_LABELS{$i}[0], -on=>'1'); } else { print $q->checkbox(-name=>$i, -value=>$i, -label=>$EZMLM_LABELS{$i}[0]); } print ''; print '
'; } print '
'; print ''; foreach $i (grep {/\d/} keys %EZMLM_LABELS) { print ''; } print '
'; if ($opts =~ /$i (?:'(.+?)')/) { print $q->checkbox(-name=>$i, -value=>$i, -label=>$EZMLM_LABELS{$i}[0], -on=>'1'); } else { print $q->checkbox(-name=>$i, -value=>$i, -label=>$EZMLM_LABELS{$i}[0]); } print ''; print ''; print $q->textfield(-name=>"$i-value", -value=>$1||$EZMLM_LABELS{$i}[2], -size=>30); print '
'; } # --------------------------------------------------------------------------- sub ezmlmcgirc { my($listno); if(open(WWW, "<$EZMLM_CGI_RC")) { while() { last if (($listno) = m{(\d+)(\D)\d+\2$LIST_DIR/$Q::list\2}); } close WWW; return "$EZMLM_CGI_URL/$listno" if(defined($listno)); } return undef; } # --------------------------------------------------------------------------- sub pretty_names { return undef unless($PRETTY_NAMES); my (%pretty, %prettymem); tie %pretty, "DB_File", "$LIST_DIR/$Q::list/webnames"; %prettymem = %pretty; untie %pretty; return \%prettymem; } # ------------------------------------------------------------------------- sub rmtree { # A subroutine to recursively delete a directory (like rm -f). # Based on the one in the perl cookbook :) use File::Find qw(finddepth); File::Find::finddepth sub { # assume that File::Find::name is secure since it only uses data we pass it my($name) = $File::Find::name =~ m{^(.+)$}; if (!-l && -d _) { rmdir($name) or warn "couldn't rmdir $name: $!"; } else { unlink($name) or warn "couldn't unlink $name: $!"; } }, @_; 1; } # ------------------------------------------------------------------------ BEGIN { sub handle_errors { my $msg = shift; print << "EOM";

A fatal error has occoured

Something you did caused this script to bail out. The error message we got was

$msg

Please try what you were doing again, checking everything you entered.
If you still find yourself getting this error, please contact the site administrator quoting the error message above.

EOM } set_message(\&handle_errors); } # ------------------------------------------------------------------------ # End of ezmlm-web.cgi v2.1 # ------------------------------------------------------------------------ __END__ =head1 NAME ezmlm-web - A web configuration interface to ezmlm mailing lists =head1 SYNOPSIS ezmlm-web [B<-c>] [B<-C> EFE] [B<-d> EFE] =head1 DESCRIPTION =over 4 =item B<-C> Specify an alternate configuration file given as F If not specified, ezmlm-web checks first in the users home directory, then in F and then the current directory =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 C<#include stdio.h> C C C C<}> =head1 DOCUMENTATION/CONFIGURATION Please refer to the example ezmlmwebrc which is well commented, and to the README file in this distribution. =head1 FILES F<~/.ezmlmwebrc> F F<./ezmlmwebrc> =head1 AUTHOR Guy Antony Halse =head1 BUGS None known yet. Please report bugs to the author. =head1 S ezmlm(5), ezmlm-cgi(1), Mail::Ezmlm(3) http://rucus.ru.ac.za/~guy/ezmlm/ http://www.ezmlm.org/ http://www.qmail.org/