#
# WING - Web-IMAP/NNTP Gateway
#
# Wing.pm
#
# Author: Malcolm Beattie, mbeattie@sable.ox.ac.uk
#
# This program may be distributed under the GNU General Public License (GPL)
#
# 25 Aug 1998 Copied from development system to main cluster.
# 23 Feb 1999 Release version 0.5
#
package Wing;
use Apache::Constants qw(:common);
use IO::Socket;
use DBI;
use HTTP::Date; # for time2str
use Wing::Shared;
use Wing::Util;
use strict;
use vars qw($VERSION $dbh);
$VERSION = "0.11";
sub handler {
my $r = shift;
if (!$r) {
Apache->error("null request passed to Wing::handler");
return OK;
} elsif ($r->header_only) {
$r->warn("header_only request for ", $r->path_info);
return OK;
}
# $r->warn("path_info = ", $r->path_info); # debug
my ($loc, $handler, $username, $url_session, $cmd, @args)
= split(m(/), $r->path_info);
#
# Handle requests to kill current logged-in session
#
if ($handler eq "kill") {
return kill_session($r, $username, $url_session);
}
#
# Otherwise, it's an ordinary /wing/cmd/... command
#
my $ip = $r->connection->remote_ip;
my ($port) = sockaddr_in($r->connection->local_addr);
my $conn = bless { request => $r }, "Wing::Connection";
# $r->warn("Cookie: ", $r->header_in("Cookie")); # debug
my %sessions = split(/[;=]/, $r->header_in("Cookie"));
my $session = $sessions{$username};
# $r->warn("session for username $username is $session"); # debug
my $server_url = server_url($r);
$conn->{url_prefix} = "$server_url/wing/cmd/$username/";
if ($session) {
#
# I used to just leave this blank so that command URLs from
# cookie-supporting browsers were of the form
# .../wing/cmd/username//command
# but one particular version of Microsoft Internet Explorer has
# a bug that blatantly collapses those consecutive slashes to a
# single slash leading to a "Wing Error" "Bad command: " error
# when a user trieds to log in. Later versions of IE are fixed
# but there are still old ones hanging around... As a sop to
# them we add a single "x" to stop it from happening. Blech.
#
$conn->{url_prefix} .= "x";
} else {
#
# Browser doesn't do cookies.
#
if (port_requires_cookies($port)) {
return wing_error($r, "You have attempted to connect to a port "
."that requires the use of cookies, but you "
."are using a browser that does not support "
."cookies or have disabled cookie support in "
."your browser.");
}
#
# Include the session key in the URL.
#
$session = $url_session;
$conn->{url_prefix} .= $session;
}
#
# If we're checking whether cookies work, bounce now to the init
# command which sets a few things up with maild and then redirects
# to list the current folder.
#
if ($cmd eq "check-cookie") {
return redirect($r, "$conn->{url_prefix}/init/$args[0]");
}
#
# Sanity-check username and session identifier
#
if (length($username) > 8 || $username =~ /\W/
|| length($session) != 24 || $session =~ /[^A-Za-z0-9.-]/)
{
return wing_error($r, "Bad session identifier or username.");
}
$conn->{session} = $session;
my $sockname = make_session_socket($username, $session);
my $s = IO::Socket->new(Domain => AF_UNIX,
Type => SOCK_STREAM,
Peer => $sockname);
if (!defined($s)) {
#
# Forcibly expire bad cookie so the browser won't keep sending it
#
my $exp = time2str(time - 1);
$r->header_out("Set-Cookie" =>
make_wing_cookie($username, $session, 0, $exp));
my ($host, $path_info) = login_url($username);
my $login_url = server_url($r, $host) . $path_info;
return wing_error($r, <<"EOT");
Session does not exist (timed out perhaps?).
Please click <a href="$login_url">here</a> to login again.
EOT
}
$conn->{maild} = $s;
#
# Sanity-check command. Note in particular that only methods
# beginning with lower-case a-z are passed on and the actual
# method name called is prefixed with "cmd_".
#
if (length($cmd) > 64 || $cmd !~ /^[a-z]\w*$/) {
return wing_error($r, "Bad command: $cmd");
}
$cmd = "cmd_$cmd";
#
# Check that connection is on a port with the same security
# options as the port of the original login, and perform optional
# security check on client IP address
#
print $s "check_port_security $ip $port\n";
chomp(my $reply = <$s>);
if ($reply ne "OK") {
return wing_error($r, "Security alert: this session did not login "
."from this IP address, or has connected to an "
."invalid port. Please login properly.");
}
#
# Before handling the command, register a cleanup to close the
# maild socket. This is because $r->print and $r->read both
# implicitly set *hard* timeouts rather than soft ones. That means
# that if we lose the connection to the client (e.g. the client
# hits "Stop" on their browser) then we still want to close the
# maild socket before Apache longjmps back to its main handler.
# If this isn't done, the socket to maild remains open and maild
# (which is single-threaded for each httpd connection) just hangs
# rather than responding to new httpd connections.
#
$r->register_cleanup(sub { $s->close }); # closure
#
# Now handle the requested command
#
eval { $conn->$cmd(@args) };
if ($@ =~ /^Can't locate object method/) {
return wing_error($r, qq(Unknown command "$cmd" sent to Wing: $@));
}
elsif ($@) {
return wing_error($r, "Command error: message is\n<pre>\n$@\n</pre>");
}
# $s->close happens in cleanup registered above
return OK;
}
sub kill_session {
my ($r, $username, $session) = @_;
my $pid = 0;
#
# Sanity-check username and session identifier
#
if (length($username) > 8 || $username =~ /\W/
|| length($session) != 24 || $session =~ /[^A-Za-z0-9.-]/)
{
return wing_error($r, "Bad session identifier or username.");
}
# $r->warn("PID $$ kill_session connecting to database for $username");#debug
my $dbh = DBI->connect(@WING_DBI_CONNECT_ARGS);
#XXX# $dbh->{AutoCommit} = 0;
my $server = $r->server->server_hostname;
my $sth = $dbh->prepare(
"select pid from sessions where username = '$username' "
." and id = '$session' and server = '$server'"
);
my $found_session = 0;
if ($sth) {
#XXX# $dbh->do("lock table sessions");
if ($sth->execute) {
my $row = $sth->fetchrow_arrayref;
if ($row) {
$found_session = 1;
$pid = $row->[0];
}
}
$sth->finish;
}
if ($found_session) {
#
# OK, zap the session
#
$dbh->do("delete from sessions where username = '$username'");
#XXX# $dbh->commit;
$dbh->disconnect;
# $r->warn("PID $$ kill_session disconnected from database after session zap");#debug
unlink(make_session_socket($username, $session));
if ($pid > 0) {
kill("TERM", $pid);
}
my ($host, $path_info) = login_url($username);
my $login_url = server_url($r, $host) . $path_info;
return redirect($r, $login_url);
} else {
#XXX# $dbh->commit;
$dbh->disconnect;
# $r->warn("PID $$ kill_session disconnected from database after failed auth");#debug
$r->content_type("text/html");
$r->send_http_header;
$r->print(<<"EOT");
<html><head><title>WING error</title></head>
<body>
The server failed to authenticate you or find your orphaned session.
</body></html>
EOT
}
return OK;
}
package Wing::Connection;
use Apache::Constants qw(:common);
use Wing::Shared;
use Wing::Util;
use Fcntl;
use DBI;
use IO::File;
use Socket;
use CrackLib; # for FascistCheck of proposed passwords
use MIME::Base64; # for decode_base64 in decode_body_in_place
use HTTP::Date; # for time2str in cmd_logout
use SQL;
use IO::Handle;
use Mail::Header;
sub _CHUNK_SIZE () { 16384 } # the chunk size in which we read upload data
sub _receive_upload {
my ($r, $filename) = @_;
my $fh = IO::File->new(">$filename") or return "$filename: $!";
my $field = Mail::Field->new("Content-Type");
$field->parse($r->header_in("Content-Type"));
my $boundary = $field->param("boundary");
my $size = $r->header_in("Content-Length");
my $count = $size;
my $buffer;
my ($client_filename, $type);
if ($count > $UPLOAD_SIZE_LIMIT) {
return "upload of $count bytes exceeds limit ($UPLOAD_SIZE_LIMIT bytes)";
}
# $r->warn("_receive_upload: client is sending us $count bytes");#debug
do {
my $toread = _CHUNK_SIZE;
if ($toread > $count) {
$toread = $count;
}
# $r->warn("_receive_upload: trying to read $toread bytes"); # debug
$buffer = ""; # must reset $buffer or Apache::read appends to it
my $didread = $r->read($buffer, $toread);
# $r->warn("_receive_upload: read $didread bytes"); # debug
if ($didread == 0) {
$fh->close;
return "unexpected end of data";
}
if ($count == $size) {
#
# first buffer of all: remove the MIME boundary after checking it
# and then parse and remove the headers.
#
if (substr($buffer, 0, length($boundary)+4) ne "--$boundary\r\n") {
$fh->close;
return "broken MIME boundary marker at start";
}
substr($buffer, 0, length($boundary) + 4) = "";
if ($buffer !~ s/^(.*?\r\n\r\n)//s) {
$fh->close;
return "missing headers";
}
my $headers = $1;
my $deb_headers = $headers;
$deb_headers =~ s/\r/\\r/gs;
$deb_headers =~ s/\n/\\n/gs;
# $r->warn("_receive_upload: MIME headers: $deb_headers");
my $head = Mail::Header->new([split(/\r\n/, $headers)]);
my $disp = $head->get("Content-Disposition");
$client_filename = Mail::Field->new("Content-Disposition",
$disp)->filename;
$type = $head->get("Content-Type");
# $r->warn("_receive_upload: disp=$disp, client_filename=$client_filename, type=$type, size=$size");#debug
}
# $r->warn("_receive_upload: writing ", length($buffer), " bytes");#debug
print $fh $buffer;
$count -= $didread;
} while ($count > 0);
#
# check the trailing MIME boundary is OK
#
my $endlen = length($boundary) + 8;
if (substr($buffer, -$endlen) ne "\r\n--$boundary--\r\n") {
return "broken MIME boundary marker at end";
}
$fh->flush;
my $filesize = (stat($fh))[7];
# $r->warn("_receive_upload: filesize $filesize, truncating $endlen bytes to make ", $filesize - $endlen, " bytes");#debug
truncate($fh, $filesize - $endlen);
$fh->close;
$type =~ tr/\r\n//d;
return ("", $type, $client_filename);
}
sub _replace_body ($$$) {
my $r = shift;
my $s = shift;
print $s "tmpdir\n";
chomp(my $body_file = <$s>);
$body_file .= "/body";
local(*BODY);
if (!sysopen(BODY, $body_file, O_RDWR|O_CREAT|O_TRUNC, 0600)) {
my $err = $!;
$r->content_type("text/plain");
$r->send_http_header;
$r->print("failed to open body file: $err");
$r->warn("failed to open body file: $err");
return 0;
}
print BODY $_[0];
close(BODY);
return 1;
}
sub cmd_init {
my ($conn, $sess_type) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "username\n";
chomp(my $username = <$s>);
# $r->warn("PID $$ cmd_init connecting to database for $username");#debug
sql_connect(@WING_DBI_CONNECT_ARGS);
sql_select(["groups.name" => \my $group], [sender => \my $sender],
[quota => \my $quota],
from => "users, groups",
username => $username, "and users.gid = groups.gid");
sql_fetch
or return wing_error($r, "Can't find group or sender: $DBI::errstr");
maild_set($s, "group", $group);
maild_set($s, "sender", $sender);
maild_set($s, "quota", $quota);
sql_select([signature => \my $signature],
[abooklist => \my $abook_list],
[composeheaders => \my $compose_headers],
[listsize => \my $list_size],
[copyoutgoing => \my $copy_outgoing],
from => "options",
username => $username);
sql_fetch;
maild_set($s, "signature", $signature) if defined $signature;
maild_set($s, "abook_list", $abook_list) if defined $abook_list;
maild_set($s, "compose_headers", $compose_headers)
if defined $compose_headers;
maild_set($s, "list_size", $list_size) if defined $list_size;
maild_set($s, "copy_outgoing", 1) if $copy_outgoing;
init_abook_ids($s, $username, $group); # Needs database access
sql_disconnect;
# $r->warn("PID $$ cmd_init disconnecting from database");#debug
# maild_set($s, "message", "Welcome $username");
if ($sess_type eq "portal") {
return cmd_portal($conn);
}
return redirect($r, "$conn->{url_prefix}/list/last");
}
sub cmd_list {
my ($conn, $start, $rand) = @_;
my $r = $conn->{request};
dont_cache($r, "text/html");
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $session = $conn->{session};
my $info_msg = info_message_html($s);
maild_set($s, "abook_return", "list");
my $portal = maild_get($s, "portal");
print $s "list $start\n";
chomp(my $folder = <$s>);
chomp(my $position = <$s>);
chomp(my $flags = <$s>);
my ($from, $to, $nmsgs) = split(' ', $position);
my $can_save = $flags =~ /S/;
my $can_delete = $flags =~ /D/;
$r->print("<html><head><title>$folder</title></head>\n<body>\n");
my ($prev_frag, $next_frag, $top_frag, $bottom_frag);
if ($from == 1) {
$prev_frag = qq(<img src="$icon_prefix/arrow-up-inactive.gif" alt=" ">);
$top_frag = qq(<img src="$icon_prefix/top-inactive.gif" alt=" ">);
} else {
$prev_frag = <<"EOT";
<a href="$url_prefix/list/prev">
<img src="$icon_prefix/arrow-up.gif" border=0 alt="Prev"></a>
EOT
$top_frag = <<"EOT";
<a href="$url_prefix/list/first">
<img src="$icon_prefix/top.gif" border=0 alt="Top"></a>
EOT
}
if ($to == $nmsgs) {
$next_frag = qq(<img src="$icon_prefix/arrow-down-inactive.gif" alt=" ">);
$bottom_frag=qq(<img src="$icon_prefix/bottom-inactive.gif" alt=" ">);
} else {
$next_frag = <<"EOT";
<a href="$url_prefix/list/next">
<img src="$icon_prefix/arrow-down.gif" border=0 alt="Next"></a>
EOT
$bottom_frag = <<"EOT";
<a href="$url_prefix/list/last">
<img src="$icon_prefix/bottom.gif" border=0 alt="Bottom"></a>
EOT
}
my $links_html = $portal ? "" : <<"EOT";
<td><a href="$url_prefix/links">
<img src="$icon_prefix/links.gif" border=0 alt="Links"></a></td>
EOT
my $header = <<"EOT";
<form method="GET" action="$url_prefix/bulk">
<table width="100%" border=0 cellspacing=0 cellpadding=0>
<tr>
<td><a href="$url_prefix/help/list">
<img src="$icon_prefix/help.gif" border=0 alt="Help"></a></td>
<td>$prev_frag</td>
<td>$next_frag</td>
<td>$top_frag</td>
<td>$bottom_frag</td>
<td><a href="$url_prefix/compose">
<img src="$icon_prefix/compose.gif" border=0 alt="Compose"></a></td>
<td><a href="$url_prefix/mailboxes">
<img src="$icon_prefix/mailboxes.gif" border=0 alt="Mailboxes"></a></td>
<td><a href="$url_prefix/manage">
<img src="$icon_prefix/manage.gif" border=0 alt="Manage"></a></td>
<td><a href="$url_prefix/options">
<img src="$icon_prefix/options.gif" border=0 alt="Options"></a></td>
<td><a href="$url_prefix/expunge">
<img src="$icon_prefix/purge.gif" border=0 alt="Purge"></a></td>
<td><a href="$url_prefix/abook_list/list">
<img src="$icon_prefix/address-books.gif" border=0 alt="Address Books"></a></td>
$links_html
<td><a href="$url_prefix/logout//list">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr></table>
<table width="100%" border=0 cellpadding=0 cellspacing=0>
<tr>
<td><a href="$url_prefix/search">
<img src="$icon_prefix/search.gif" border=0 alt="Search"></a></td>
<td><a href="$url_prefix/calendar">
<img src="$icon_prefix/calendar.gif" border=0 alt="Calendar"></a></td>
<td align="right">
<font size="-1">
<select name="type">
<option selected value="search">Search mailbox
<option value="delete">Delete range
<option value="undelete">Undelete range
<option value="move">Save range
<option value="copy">Copy range
<option value="flag">Flag range
</select>
<input name="range" size="8">
<input type="submit" value="Go">
</font>
</td>
</tr>
</table>
</form>
EOT
my $message_s = $nmsgs == 1 ? "message" : "messages";
$r->print($header, $info_msg, <<"EOT");
<h1 align="center">Mailbox `$folder' with $nmsgs $message_s</h1>
<table width="100%">
EOT
while (1) {
chomp(my $msgno = <$s>);
if (!$msgno) {
$r->log_error("list: maild daemon vanished unexpectedly");
last;
}
# $r->warn("list: headers for msgno $msgno");#debug
last if $msgno eq "."; # the proper way to terminate the list
chomp(my $uid = <$s>);
chomp(my $date = <$s>);
chomp(my $display_address = <$s>);
chomp(my $size = <$s>);
chomp(my $flags = <$s>);
chomp(my $subject = <$s>);
$subject ||= "(No subject)"; # (Subjects of "0" deserve to lose :-)
#
# Calculate status:
# N (new) if \Recent set but \Seen not set
# O (old) if neither \Recent nor \Seen set
# " " otherwise
# Append "D" if \Deleted, "A" if \Answered, "F" if \Flagged
#
my %flags = map { $_ => 1 } split(' ', $flags);
#
# Right Hand Side has Save/Reply/Forward buttons (where
# appropriate to the protocol) and a Delete or Undelete
# button, depending on whether the message is undeleted or
# deleted (resp).
#
my ($status, $is_deleted, $rhs);
$is_deleted = $flags{"\\Deleted"};
$status = $is_deleted ? "D" : " ";
if ($can_save) {
$rhs = qq(<a href="$url_prefix/save/move/list/$msgno">S</a>\n);
} else {
$rhs = "";
}
$rhs .= <<"EOT";
<a href="$url_prefix/reply/$uid/$msgno">R</a>
<a href="$url_prefix/forward/$uid/$msgno">F</a>
EOT
if ($can_delete) {
if ($is_deleted) {
$rhs .= qq(<a href="$url_prefix/undelete/$uid/$msgno/list">U</a>\n);
} else {
$rhs .= qq(<a href="$url_prefix/delete/$uid/$msgno">D</a>\n);
}
}
if ($flags{"\\Seen"}) {
$status .= " ";
} elsif ($flags{"\\Recent"}) {
$status .= "N";
} else {
$status .= "O";
}
$status .= $flags{"\\Answered"} ? "A" : " ";
$status .= $flags{"\\Flagged"} ? "F" : " ";
$r->print(<<"EOT");
<tr>
<td>$status</td>
<td align="right"><strong>$msgno.</strong></td>
<td nowrap>$date</td>
<td nowrap>$display_address</td>
<td align="right">$size</td>
<td nowrap><a href="$url_prefix/display/$uid/$msgno">$subject</a></td>
<td nowrap>$rhs</td>
</tr>
EOT
}
# $r->print("</table>\n", $header, "</body></html>\n");
# Maybe better without the header across the bottom too
$r->print("</table>\n", "</body></html>\n");
}
sub _input_structure {
my ($r, $s) = @_;
chomp(my $id = <$s>);
if ($id eq ".") {
# $r->warn("_input_structure returning undef");#debug
return undef;
}
elsif ($id eq "+") {
# $r->warn("_input_structure read +");#debug
my @parts = ();
my $part;
do {
$part = _input_structure($r, $s);
push(@parts, $part) if defined($part);
# $r->warn("_input_structure pushed $part");#debug
} while defined($part);
return bless \@parts, "Wing::Multipart";
}
else {
chomp(my $type = <$s>);
chomp(my $description = <$s>);
chomp(my $size = <$s>);
chomp(my $encoding = <$s>);
chomp(my $params = <$s>);
# $r->warn("_input_structure read info for id $id: ",
# "type: $type, descr: $description, size: $size, ",
# "encoding: $encoding, params: $params");#debug
return [$id, $type, $description, $size, $encoding, $params];
}
}
sub _show_structure {
my ($r, $uid, $msgno, $part, $url_prefix) = @_;
if (ref($part->[0])) {
# $r->warn("_show_structure: part is a ref");#debug
$r->print("<ol>\n");
foreach my $p (@$part) {
$r->print("<li>");
# $r->warn("_show_structure: recursing for part $part");#debug
_show_structure($r, $uid, $msgno, $p, $url_prefix);
}
$r->print("</ol>");
} else {
my ($id, $type, $description, $size, $encoding, $params) = @$part;
# $r->warn("_show_structure writing info for id $id");#debug
my $name = "noname";
#
# The way we extract the recommended name from params is a bit
# yucky--we really ought to get maild to send it us separately.
#
if ($params =~ /\bname="(.*?)"/i) {
$name = $1;
$name =~ s(.*/)();
}
my $url;
if ($type eq "text/plain") {
$url = sprintf("%s/display/%d/%d/%s/%s/%s/%s/%s",
$url_prefix, $uid, $msgno, $id,
canon_encode($type,$encoding,$params,$description));
} else {
$url = sprintf("%s/rawdisplay/%d/%s/%s/%s/%s/%s",
$url_prefix, $msgno, $id,
canon_encode($type, $encoding, $params), $name);
}
#
# Not sure if we want the target here (which makes these URLs appear
# in a newly created window on browsers which support "target")
# 21 Oct 1998. Let's try without for a while.
#$r->print(qq[<a href="$url" target="display">$description ($type), $size</a>\n]);
$r->print(qq[<a href="$url">$description ($type), $size</a>\n]);
}
}
#
# Handle encodings of base64 and quoted-printable
# Called as decode_body_in_place($encoding, $body)
# As the name suggests, we modify the second argument in-place
#
sub decode_body_in_place {
my $encoding = shift;
return unless $encoding and defined($_[0]) and length($_[0]);
$encoding = lc($encoding);
for ($_[0]) {
if ($encoding eq "base64") {
$_ = decode_base64($_);
} elsif ($encoding eq "quoted-printable") {
#
# We need to change line endings CRLF -> LF first before doing
# the decode. Instead of doing that first and then calling
# MIME::QuotedPrint decode_qp() we do it all in one for speed.
#
s/[ \t]*\r?$//mg;
s/=\n//sg;
s/=([0-9a-fA-F]{2})/chr(hex($1))/ge;
}
}
}
sub cmd_rawdisplay {
my $conn = shift;
my $r = $conn->{request};
my ($msgno, $mime_sect, $type, $encoding, $params, $name) = @_;
($type, $encoding, $params) = canon_decode($type, $encoding, $params);
my $s = $conn->{maild};
#
# Send a message/delivery-status type (RFC1894) to the browser as
# test/plain since otherwise most don't know what to do with it
#
if ($type eq "message/delivery-status") {
$type = "text/plain";
}
$type .= "; $params" if $params;
$r->content_type($type);
print $s "body $msgno $mime_sect\n";
chomp(my $size = <$s>);
# $r->warn("rawdisplay: type=$type, encoding=$encoding, size=$size");#debug
read($s, my $body, $size);
#
# Sanity check
#
if ($size != length($body)) {
$r->warn("rawdisplay: only got ", length($body),
"bytes instead of $size while reading body");
}
decode_body_in_place($encoding, $body);
# Try to stop extra \r characters from creeping in
$r->header_out("Content-Transfer-Encoding" => "binary");
$r->header_out("Content-Length" => length($body));
$r->send_http_header;
# $r->warn("rawdisplay: sending ", length($body), " bytes to client");#debug
$r->print($body);
}
sub cmd_display {
my ($conn, $uid, $msgno, $mime_sect, @mime_stuff) = @_;
my ($type, $encoding, $params, $description) = canon_decode(@mime_stuff);
my $r = $conn->{request};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $callback = "display/$uid/$msgno/$mime_sect" . join("/", @mime_stuff);
my $logout_callback = canon_encode($callback);
my $s = $conn->{maild};
# $r->warn("display ", join(", ", @_)); # debug
my $body;
my $subject;
my $header_html;
maild_set($s, "abook_return", $callback);
print $s "nmsgs\n";
chomp(my $nmsgs = <$s>);
if ($msgno < 1 || $msgno > $nmsgs) {
$r->content_type("text/plain");
$r->send_http_header;
$r->print("Bad message number: $msgno\n");
return OK;
}
print $s "prev_next $msgno\n";
chomp(my $line = <$s>);
my ($prev_uid, $prev_msgno, $next_uid, $next_msgno) = split(' ', $line);
my ($prev_frag, $next_frag);
if ($prev_msgno) {
$prev_frag = <<"EOT";
<a href="$url_prefix/display/$prev_uid/$prev_msgno">
<img src="$icon_prefix/left.gif" border=0 alt="Prev"></a>
EOT
} else {
$prev_frag = qq(<img src="$icon_prefix/left-inactive.gif" alt=" ">);
}
if ($next_msgno) {
$next_frag = <<"EOT";
<a href="$url_prefix/display/$next_uid/$next_msgno">
<img src="$icon_prefix/right.gif" border=0 alt="Next"></a>
EOT
} else {
$next_frag = qq(<img src="$icon_prefix/right-inactive.gif" alt=" ">);
}
dont_cache($r, "text/html");
print $s "structure $msgno\n";
my $struct = _input_structure($r, $s);
print $s "flags $msgno\n";
chomp(my $flagstring = <$s>);
my %flags = map { $_ => 1 } split(' ', $flagstring);
my $is_multipart = (ref $struct eq "Wing::Multipart");
if (defined($mime_sect)) {
$subject = $description;
} else {
print $s "headers $msgno\n";
chomp(my $size = <$s>);
read($s, my $hdrtext, $size);
#
# The headers arrive with CRs already removed and with multiple
# line headers rejoined. We just have to be careful to handle
# both spaces and tabs after the colon (some software uses a
# tab despite RFC822 3.4.2 discouraging it, sigh).
#
my %headers = $hdrtext =~ /^(.*?):[ \t]*(.*)$/mg;
$subject = $headers{Subject} || "(No subject)";
$header_html = "<table>\n";
while (my ($hdr, $val) = each %headers) {
next if $hdr eq "Subject";
$val = escape_html($val);
$header_html .= <<"EOT";
<tr><td align=left><strong>${hdr}:</strong></td><td align=left>$val</td></tr>
EOT
}
$header_html .= "</table>\n";
}
#
# First show the command buttons
#
my $del_or_undel = $flags{"\\Deleted"} ? "undelete" : "delete";
$r->print(<<"EOT");
<html><head><title>$subject</title></head>
<body>
<table width="100%"><tr>
<td>$prev_frag</td>
<td>$next_frag</td>
<td><a href="$url_prefix/list"><img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><a href="$url_prefix/download/$uid/msg$msgno">
<img src="$icon_prefix/download.gif" border=0 alt="Download"></a></td>
<td><a href="$url_prefix/reply/$uid/$msgno">
<img src="$icon_prefix/reply.gif" border=0 alt="Reply"></a></td>
<td><a href="$url_prefix/reply/$uid/$msgno/group">
<img src="$icon_prefix/group-reply.gif" border=0 alt="Group reply"></a></td>
<td><a href="$url_prefix/forward/$uid/$msgno">
<img src="$icon_prefix/forward.gif" border=0 alt="Forward"></a></td>
<td><a href="$url_prefix/save/move/$uid-$msgno/$msgno">
<img src="$icon_prefix/save.gif" border=0 alt="Save"></a></td>
<td><a href="$url_prefix/save/copy/$uid-$msgno/$msgno">
<img src="$icon_prefix/copy.gif" border=0 alt="Copy"></a></td>
<td><a href="$url_prefix/compose/fresh">
<img src="$icon_prefix/compose.gif" border=0 alt="Compose"></a></td>
<td><a href="$url_prefix/$del_or_undel/$uid/$msgno/display">
<img src="$icon_prefix/$del_or_undel.gif" border=0 alt="\u$del_or_undel"></a></td>
<td><a href="$url_prefix/abook_list">
<img src="$icon_prefix/address-books.gif" border=0 alt="Address Books"></a></td>
<td><a href="$url_prefix/logout//$logout_callback">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr></table>
<br>
EOT
#
# Then any information message and the message number/subject as title
#
my $info_msg = info_message_html($s);
$r->print($info_msg, <<"EOT");
<h3>Message $msgno/$nmsgs</h3>
<h1 align="center">$subject</h1>
EOT
#
#
# Then any flag information (Deleted, New, ...)
#
my @info;
push(@info, "Deleted") if $flags{"\\Deleted"};
push(@info, "Answered") if $flags{"\\Answered"};
push(@info, "Flagged") if $flags{"\\Flagged"};
$r->print("<h3>(", join(", ", @info), ")</h3>\n") if @info;
#
# Then show the header information (unless we're showing a MIME subpart)
#
$r->print($header_html) if defined($header_html);
#
# Now show the MIME hierarchy for multipart messages
#
if ($is_multipart) {
$r->print(<<"EOT");
<hr>
<h3>MIME structure of
<a href="$url_prefix/display/$uid/$msgno">this message</a></h3>
EOT
_show_structure($r, $uid, $msgno, $struct, $url_prefix);
$r->print("<hr>\n");
}
#
# Finally show the body (or MIME subpart of the body) if it's
# (a) single part or (b) we're doing an explicit $mime_sect or
# (c) we're doing a multipart whose first part is text/plain
# We need to be careful to get the right encoding
#
my $body_cmd;
my $body_encoding;
if (defined($mime_sect)) {
$body_cmd = "body $msgno $mime_sect";
$body_encoding = $encoding;
}
elsif ($is_multipart) {
if ($struct->[0]->[1] eq "text/plain") {
$body_cmd = "body $msgno 1";
$body_encoding = $struct->[0]->[4];
}
}
else {
$body_cmd = "body $msgno";
$body_encoding = $struct->[4];
}
if (defined($body_cmd)) {
print $s $body_cmd, "\n";
chomp(my $size = <$s>);
read($s, $body, $size);
decode_body_in_place($body_encoding, $body);
$body =~ s/</</g;
#
# The following regexp attempts to match "reasonable" URLs.
# The general description in RFC1738 is too generic and
# gives false positives on a whole load of things (e.g. 12:34).
#
$body =~ s{(?igx)
\b([a-z][a-z0-9+.-]{2,9}:[a-z0-9.%&=?/\\~\@:;,_+|-]+)
}{<a href="$1">$1</a>};
$r->print("<pre>\n", $body, "</pre>\n");
}
$r->print("</body></html>\n");
}
#sub structure {
# my ($conn, $uid, $msgno) = @_;
# my $r = $conn->{request};
# $r->content_type("text/html");
# $r->send_http_header;
# my $s = $conn->{maild};
# print $s "structure $msgno\n";
# my $struct = _input_structure($r, $s);
# $r->print(<<"EOT");
#<html><head><title>Structure of message $msgno</title></head>
#<body><h1 align="center">Structure of message $msgno</h1>
#EOT
# my $url_prefix = $conn->{url_prefix};
# _show_structure($r, $uid, $msgno, $struct, $url_prefix);
# $r->print("</body></html>\n");
#}
sub cmd_download {
my ($conn, $uid, $msgno) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
$msgno =~ s/^\D*//;
print $s "headers $msgno all\n";
chomp(my $size = <$s>);
read($s, my $headers, $size);
$headers =~ tr/\r//d;
print $s "body $msgno\n";
chomp($size = <$s>);
read($s, my $body, $size);
$r->content_type("text/plain");
$r->send_http_header;
$r->print($headers, $body);
}
sub cmd_chdir {
my ($conn, $which) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my %in = $r->args;
if (exists($in{cwd})) {
maild_set($s, "cwd", url_decode($in{cwd}));
}
if (exists($in{filter})) {
maild_set($s, "filter", url_decode($in{filter}));
}
if (!defined($which)) {
$which = "browse";
} elsif ($which ne "browse" && $which !~ /^(save_)?(copy|move)$/) {
return wing_error($r, "subcommand must be browse/copy/move/save_copy/save_move");
}
return redirect($r, "$conn->{url_prefix}/mailboxes/$which");
}
sub cmd_logout {
my ($conn, $confirm, $callback_raw) = @_;
my $callback = canon_decode($callback_raw);
my $r = $conn->{request};
my $icon_prefix = icon_prefix($r);
my $session = $conn->{session};
my $s = $conn->{maild};
if ($confirm ne "confirm") {
my $url_prefix = $conn->{url_prefix};
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Confirm logout</title></head>
<body>
<h1 align="center">Confirm logout</h1>
<table width="100%">
<tr>
<td align="center">
<a href="$url_prefix/$callback">
<img src="$icon_prefix/cancel-logout.gif" border=0 alt="Cancel logout"></a>
</td>
<td align="center">
<a href="$url_prefix/logout/confirm/$callback_raw" target="_parent">
<img src="$icon_prefix/confirm-logout.gif" border=0 alt="Confirm logout"></a>
</td>
</tr>
</table>
</body></html>
EOT
return;
}
print $s "username\n";
chomp(my $username = <$s>);
print $s "logout\n";
chomp(my $result = <$s>);
# $r->warn("PID $$ cmd_logout connecting to database for $username");#debug
my $dbh = DBI->connect(@WING_DBI_CONNECT_ARGS);
if ($dbh) {
my $rows = $dbh->do("delete from sessions where id = '$session'");
$dbh->disconnect;
# $r->warn("PID $$ cmd_logout disconnected from database");#debug
$r->log_error("logout: session deletion failed") unless $rows == 1;
} else {
$r->log_error("logout: DBI->connect failed: $DBI::errstr");
}
#
# Force expiry of session cookie so that next failed login attempt
# doesn't present the stale one (resulting in a "no such session"
# error instead of a "login incorrect" error).
#
my $exp = time2str(time - 1);
$r->header_out("Set-Cookie" =>
make_wing_cookie($username, $session, 0, $exp));
my ($host, $path_info) = login_url();
my $login_url = server_url($r, $host) . $path_info;
return redirect($r, $login_url);
}
sub cmd_compose {
my ($conn, $prepare) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $body_uptodate = 0;
my $body;
local(*BODY);
print $s "tmpdir\n";
chomp(my $body_file = <$s>);
$body_file .= "/body";
my $copy_outgoing = maild_get($s, "copy_outgoing");
my $copy_outgoing_checked = $copy_outgoing ? " checked" : "";
my $signature = maild_get($s, "signature");
maild_set($s, "abook_return", "compose");
my @header_list = split(' ', maild_get($s, "compose_headers"));
my %headers;
foreach my $h (@header_list) {
if ($prepare eq "fresh") {
$headers{$h} = "";
} else {
$headers{$h} = maild_get($s, "hdr_$h");
}
}
if ($r->method eq "POST") {
my %q = $r->content;
$body = $q{body};
if (defined($body)) {
$body =~ tr/\r//d;
_replace_body($r, $s, $body);
$body_uptodate = 1;
}
#
# Process headers and submissions
#
my ($lookup, $submit, $redirect, $clear_headers, @pending_lookup);
while (my ($key, $value) = each %q) {
if ($key =~ /^hdr_([A-Z][\w-]*)$/ && exists($headers{$1})) {
$headers{$1} = $value;
maild_set($s, $key, $value);
}
elsif ($key =~ /^abook_([A-Z][\w-]*)$/) {
push(@pending_lookup, $1);
}
elsif ($key eq "clear_body") {
$prepare = "fresh"; # equivalent to clearing out body
}
elsif ($key eq "clear_headers") {
$clear_headers = 1;
}
elsif ($key eq "copy_outgoing") {
my $newval = $value ? 1 : 0;
if ($newval != $copy_outgoing) {
maild_set($s, "copy_outgoing", $newval);
$copy_outgoing = $newval;
$copy_outgoing_checked = $copy_outgoing ? " checked" : "";
}
}
elsif ($key =~ /^sub_(send|save|include|list|attachments|abook_list|add_header|del_header)/) {
$submit = $1;
}
}
if (defined($submit) && $submit ne "save") {
$redirect = $submit;
}
foreach my $hdr (@pending_lookup) {
#
# lookup value for header in address books and username table
#
my $result = _lookup_alias($conn, maild_get($s, "hdr_$hdr"));
$headers{$hdr} = $result;
maild_set($s, "hdr_$hdr", $result);
}
if (defined($redirect)) {
return redirect($r, "$url_prefix/$redirect");
}
if ($clear_headers) {
foreach my $h (@header_list) {
maild_reset($s, "hdr_$h");
$headers{$h} = "";
}
}
}
#
# We get here either because this is the first time on this
# screen (i.e. it's method GET instead of POST) or else we've
# fallen through the above (currently only possibly by
# clicking on "Save").
#
if ($prepare eq "fresh") {
truncate($body_file, 0);
$body = ($signature =~ /\S/) ? "-- \n$signature" : "";
$body_uptodate = 1;
}
if (!$body_uptodate) {
my $body_existed = -e $body_file;
if (!sysopen(BODY, $body_file, O_RDWR|O_CREAT, 0600)) {
my $err = $!;
$r->content_type("text/plain");
$r->send_http_header;
$r->print("failed to open body file: $err");
$r->warn("failed to open body file: $err");
return;
}
if ($body_existed) {
local($/); # slurp whole file
$body = <BODY>;
} else {
$body = "";
if ($signature =~ /\S/) {
$body = "-- \n$signature";
print BODY $body;
}
}
close(BODY);
$body_uptodate = 1;
}
dont_cache($r, "text/html");
#
# Removed <input type="submit" name="sub_save" value="Save">
# from after Send button
#
$r->print(<<"EOT");
<html><head><title>Draft message</title>
<body>
<form method="POST" action="$url_prefix/compose">
<input type="submit" name="sub_list" value="Cancel">
<input type="submit" name="sub_send" value="Send" tabindex="100">
<input type="submit" name="sub_include" value="Include">
<input type="submit" name="sub_attachments" value="MIME Attachments">
<input type="submit" name="sub_abook_list" value="Address Books">
<a href="$url_prefix/logout//compose">
<img align="absmiddle" src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<br>
EOT
#
# Show any information message and start the table for the headers
#
my $info_msg = info_message_html($s);
$r->print($info_msg, <<"EOT");
<table cellspacing=0 cellpadding=0>
EOT
my $i = 1;
foreach my $h (@header_list) {
my $value = escape_html($headers{$h});
$r->print(<<"EOT");
<tr>
<td>${h}:</td>
<td><input name="hdr_$h" value="$value" size="50" tabindex="$i"></td>
EOT
$i++;
$r->print(<<"EOT") if $header_is_address{$h};
<td><input type="submit" name="abook_$h" value="Lookup" tabindex="$i"></td>
EOT
$r->print("</tr>\n");
$i++;
}
$r->print(<<"EOT");
</table>
<br>
<input type="submit" name="clear_headers" value="Clear Headers">
<input type="submit" name="clear_body" value="Clear Body">
<input type="submit" name="sub_add_header" value="Add new headers">
<input type="submit" name="sub_del_header" value="Remove headers">
Save copy in $SENT_MAIL_MAILBOX
<input type="checkbox" name="copy_outgoing" value="1"$copy_outgoing_checked>
<br>
<textarea name="body" rows="18" cols="80" tabindex="99">
EOT
$r->print($body, "</textarea></form></body></html>\n");
}
sub cmd_clear {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "tmpdir\n";
chomp(my $tmpdir = <$s>);
truncate("$tmpdir/body", 0);
return redirect($r, "$conn->{url_prefix}/compose");
}
sub cmd_add_header {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my @add;
my $args = $r->args;
while ($args =~ /header=([^&]+)/g) {
push(@add, url_decode($1));
}
if (@add) {
my @header_list = split(' ', maild_get($s, "compose_headers"));
my %headers = map { $_ => 1 } @header_list;
#
# Canonify header names (e.g. turn "iN-REPLy-tO" into
# "In-Reply-To") and add them (unless already present or illegal)
#
foreach my $h (@add) {
$h = lc($h);
$h =~ s/\b(\w)/uc($1)/eg;
push(@header_list, $h) unless exists $headers{$h}
|| $h eq "From" || $h eq "Sender";
$headers{$h} = 1;
}
my $header_string = join(' ', @header_list);
maild_set($s, "compose_headers", $header_string);
return redirect($r, "$conn->{url_prefix}/compose");
} else {
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Add new headers</title>
<body>
<a href="$url_prefix/compose">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a>
<img src="$icon_prefix/blank.gif" alt=" | ">
<a href="$url_prefix/logout//add_header">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<h1 align="center">Add new headers</h1>
<form method="GET" action="$url_prefix/add_header">
<h2>Choose from these common headers</h2>
<select align="middle" name="header" multiple>
<option value="Bcc" selected>Bcc
<option value="Reply-To">Reply
<option value="Action">Action
<option value="Priority">Priority
<option value="In-Reply-To">In-Reply-To
<option value="Expires">Expires
<option value="Precedence">Precedence
</select>
<h2>or enter one here</h2>
<input align="middle" name="header">
<br>
<input type="submit" value="Add new headers">
<input type="reset" value="Clear">
</form>
</body></html>
EOT
}
}
sub cmd_del_header {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my @remove;
my $args = $r->args;
while ($args =~ /header=([^&]+)/g) {
push(@remove, url_decode($1));
}
my @header_list = split(' ', maild_get($s, "compose_headers"));
my %mandatory = map { $_ => 1 } split(/ /, $MANDATORY_COMPOSE_HEADERS);
if (@remove) {
#
# Disallow headers in the removal list which are
# either non-existent or mandatory.
#
my %headers = map { $_ => 1 } @header_list;
foreach my $h (@remove) {
if ($headers{$h} && !$mandatory{$h}) {
print $s "unset hdr_$h\n";
@header_list = grep { $_ ne $h } @header_list;
}
}
my $header_string = join(' ', @header_list);
maild_set($s, "compose_headers", $header_string);
return redirect($r, "$conn->{url_prefix}/compose");
} else {
$r->content_type("text/html");
$r->send_http_header;
$r->print(<<"EOT");
<html><head><title>Remove headers</title>
<body>
<a href="$url_prefix/compose">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a>
<img src="$icon_prefix/blank.gif" alt=" | ">
<a href="$url_prefix/logout//del_header">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<h1 align="center">Remove headers</h1>
EOT
@header_list = grep { !$mandatory{$_} } @header_list;
if (@header_list) {
$r->print(<<"EOT");
<form method="GET" action="$url_prefix/del_header">
<h2>Choose which headers to remove</h2>
<select align="middle" name="header" multiple>
EOT
foreach my $h (@header_list) {
$r->print(qq(<option value="$h">$h\n));
}
$r->print(<<"EOT");
</select>
<br>
<input type="submit" value="Remove Headers">
<input type="reset" value="Clear">
</form>
EOT
} else {
$r->print(<<"EOT");
Only mandatory header remain: these cannot be removed.
EOT
}
$r->print("</body></html>\n");
}
}
sub cmd_reply {
my ($conn, $uid, $msgno, $group_reply) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my $signature = maild_get($s, "signature");
$signature = "\n-- \n$signature" if $signature;
print $s "headers $msgno Subject Message-Id Reply-To To From Cc\n";
chomp(my $size = <$s>);
read($s, my $headers, $size);
$headers =~ tr/\r//d;
# $r->warn("reply: headers are: $headers"); # debug
my $replyto = "";
my ($messageid) = $headers =~ /^Message-Id: (.*)$/im;
if ($headers =~ /^Reply-To: (.*)$/im) {
$replyto = $1;
} elsif ($headers =~ /^From: (.*)$/im) {
$replyto = $1;
}
my $subject = "Re: your message";
if ($headers =~ /^Subject: (.*)$/im) {
$subject = $1;
$subject = "Re: $subject" unless $subject =~ /^Re: /i;
}
my $cc = "";
if ($group_reply) {
if ($headers =~ /^Cc: (.*)$/im) {
$cc = $1;
}
if ($headers =~ /^To: (.*)$/im) {
$cc .= ", " if length($cc);
$cc .= $1;
}
}
maild_set($s, "hdr_To", $replyto);
maild_set($s, "hdr_Subject", $subject);
maild_set($s, "hdr_Cc", $cc);
print $s "body $msgno 1\n";
chomp($size = <$s>);
#
# XXX We ought to let the "In message 123 foo@bar writes..." stuff
# be user configurable. This will have to do for now though.
#
my $intro = "In message $messageid $replyto writes:\n";
read($s, my $body, $size);
$body =~ s/^/> /mg;
_replace_body($r, $s, $intro . $body . $signature);
return redirect($r, "$conn->{url_prefix}/compose");
}
sub cmd_forward {
my ($conn, $uid, $msgno) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my $signature = maild_get($s, "signature");
$signature = "\n-- \n$signature" if $signature;
print $s "zap_draft\n";
print $s "headers $msgno all\n";
chomp(my $size = <$s>);
read($s, my $headers, $size);
$headers =~ tr/\r//d;
# $r->warn("forward: headers are: $headers"); # debug
my $forwarded_from = "";
if ($headers =~ /^Subject: (.*)$/im) {
maild_set($s, "hdr_Subject", "$1 (fwd)");
}
if ($headers =~ /^From: (.*)$/im) {
$forwarded_from .= " from $1";
}
print $s "body $msgno 1\n";
chomp($size = <$s>);
read($s, my $body, $size);
$body = <<"EOT";
----- Forwarded message$forwarded_from -----
$headers
$body
-----End of forwarded message$forwarded_from -----
$signature
EOT
_replace_body($r, $s, $body);
return redirect($r, "$conn->{url_prefix}/compose");
}
sub cmd_change {
my ($conn, $mailbox) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
$mailbox = canon_decode($mailbox);
printf $s "change %s\n", maild_encode($mailbox);
chomp(my $result = <$s>);
if ($result eq "OK") {
return redirect($r, "$conn->{url_prefix}/list");
}
$result =~ s/^NO //;
$result = maild_decode($result);
$r->content_type("text/plain");
$r->send_http_header;
$r->print("Failed to change to mailbox $mailbox: $result\n");
return OK;
}
sub cmd_mailboxes {
my ($conn, $which) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
if (!defined($which)) {
$which = "browse";
} elsif ($which ne "browse" && $which !~ /^(save_)?(copy|move)$/) {
return wing_error($r, "subcommand must be browse/copy/move/save_copy/save_move");
}
my $info_msg = info_message_html($s);
my $cwd = maild_get($s, "cwd");
my $filter = maild_get($s, "filter");
my $imap_filter = $filter;
$imap_filter =~ tr/*/%/;
$imap_filter = "%" if $imap_filter eq "";
my $filter_html = ($filter eq "*") ? "" : escape_html($filter);
my $cwd_html = escape_html($cwd);
my $wildcard = length($cwd) ? "$cwd/$imap_filter" : $imap_filter;
# $r->warn("wildcard = $wildcard");#debug
#
# The "filenames" we get out of the following list are full
# pathnames (i.e. include any parent directories traversed).
#
printf $s "ls %s\n", maild_encode($wildcard);
my @list;
while (1) {
chomp(my $line = <$s>);
if (!$line) {
$r->log_error("browse: maild daemon vanished unexpectedly");
last;
}
last if $line eq "."; # the proper way to terminate the list
my @info = canon_decode(split(' ', $line));
# $r->warn("browse: ", join(", ", @info));#debug
push(@list, \@info);
}
my $parent = $cwd;
$parent =~ s((/+|^)[^/]+/?$)(); # strip trailing directory
$parent = url_encode($parent);
#
# Grey out parent link if directory is already toplevel
#
my ($parent_icon, $parent_text);
if ($cwd eq "") {
$parent_icon = <<"EOT";
<img src="$icon_prefix/left-inactive.gif" border=0 alt="[up] ">
EOT
$parent_text = "Parent directory";
} else {
$parent_icon = <<"EOT";
<a href="$url_prefix/chdir/$which?cwd=$parent">
<img src="$icon_prefix/left.gif" border=0 alt="[up] "></a>
EOT
$parent_text = <<"EOT";
<a href="$url_prefix/chdir/$which?cwd=$parent">Parent directory</a>
EOT
}
my $title;
if ($which eq "browse") {
$title = "Mailboxes";
} elsif ($which =~ /^save_(.*)/) {
$title = "\u$1 message(s) to mailbox ...";
} else {
my $copy_move_from = escape_html(maild_get($s, "copy_move_from"));
$title = ($which eq "move") ? "Rename" : "Copy";
$title .= " from $copy_move_from to ...";
}
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>$title</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/list">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><a href="$url_prefix/help/mailboxes">
<img src="$icon_prefix/help.gif" border=0 alt="Help"></a></td>
<td><a href="$url_prefix/logout//mailboxes">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
$info_msg
<h2 align="center">$title</h2>
<form method="GET" action="$url_prefix/chdir/$which">
Directory <input name="cwd" size="32" value="$cwd_html">
Filter <input name="filter" size="12" value="$filter_html">
<input type="submit" value="Open">
</form>
<br>
<table>
<tr>
<td>$parent_icon</td>
<td><img src="$icon_prefix/blank.gif" alt=" "></td>
<td>$parent_text</td>
</tr>
EOT
@list = sort { $a->[0] cmp $b->[0] } @list;
foreach my $i (@list) {
my $name = shift @$i;
# $r->warn("formatting name $name of length ", length($name));#debug
my $noinferiors = 0;
my $noselect = 0;
my $marked = 0;
my $unmarked = 0;
foreach my $f (@$i) {
if ($f eq "noinferiors") {
$noinferiors = 1;
} elsif ($f eq "noselect") {
$noselect = 1;
} elsif ($f eq "marked") {
$marked = 1;
} elsif ($f eq "unmarked") {
$unmarked = 1;
}
}
#
# Choose an image to show marked/unmarked/non-marked folders.
# We used to show a red blob for marked and a grey blob for
# not-marked-or-unmarked but it confused people. Now we just
# put an "N" for "New" next to marked folders since that's
# how we mark new messages when displaying their contents.
#
my $mark_img = "";
if ($marked) {
#$mark_img = '<img src="/icons/ball.red.gif" alt="N">';
$mark_img = "N";
} elsif ($unmarked) {
#$mark_img = '<img src="/icons/ball.gray.gif" alt="O">';
} else {
#$mark_img = '<img src="$icon_prefix/blank.gif" alt=" ">';
}
#
# We don't cope with IMAP servers that allow mailboxes to be both
# selectable and have inferiors.
#
#
# We have three forms of each name entry:
# $name_enc - the full pathname, URL encoded (for ...?name=$name_enc)
# $name_canon - the full pathname, canon encoded (for .../$name_canon)
# $name - the *basename* in HTML-encoded form for display
#
my $name_enc = url_encode($name);
my $name_canon = canon_encode($name);
$name =~ s(^.*/)();
$name = escape_html($name);
# $r->warn("cwd=$cwd, name=$name, name_enc=$name_enc, name_canon=$name_canon");#debug
next if $name eq "";
$r->print("<tr>");
#
# Prepare HTML for anchor: only have a "change to this mailbox"
# anchor is we're in "browse" mode or we're copying/moving
# messages to a mailbox.
#
my $a_change = "";
my $a_end = "";
if ($which eq "browse") {
$a_change = qq{<a href="$url_prefix/change/$name_canon">};
$a_end = "</a>";
}
elsif ($which =~ /^save_/) {
$a_change = qq{<a href="$url_prefix/do_save?save=y&name=$name_enc">};
$a_end = "</a>";
}
if (!$noselect) {
$r->print(<<"EOT");
<td>
$a_change
<img src="$icon_prefix/dir.gif" border=0 alt=" ">$a_end
</td>
<td>
$mark_img
</td>
<td>
$a_change$name$a_end
</td>
EOT
$r->print(<<"EOT") if $which eq "browse" && $name_canon ne "INBOX";
<td>
<a href="$url_prefix/copy_move_from/move/$name_canon">
<img src="$icon_prefix/rename.gif" border=0 alt="Rename"></a>
</td>
<td>
<a href="$url_prefix/rm/mailbox/$name_canon">
<img src="$icon_prefix/delete.gif" border=0 alt="Delete"></a>
</td>
EOT
#
# Add the following when/if we support copying whole mailboxes
#<td>
# <a href="$url_prefix/copy_move_from/copy/$name_canon">Copy</a>
#</td>
#
} elsif (!$noinferiors) {
$r->print(<<"EOT");
<td>
<a href="$url_prefix/chdir/$which?cwd=$name_enc">
<img src="$icon_prefix/right.gif" border=0 alt="[dir]"></a>
</td>
<td>
$mark_img
</td>
<td>
<a href="$url_prefix/chdir/$which?cwd=$name_enc">$name</a>
</td>
EOT
$r->print(<<"EOT") if $which eq "browse";
<td>
<a href="$url_prefix/copy_move_from/move/$name_canon">
<img src="$icon_prefix/rename.gif" border=0 alt="Rename"></a>
</td>
<td>
<a href="$url_prefix/rm/directory/$name_canon">
<img src="$icon_prefix/delete.gif" border=0 alt="Delete"></a>
</td>
EOT
}
$r->print("</tr>\n");
}
$r->print("</table><br>\n");
if ($which eq "browse") {
$r->print(<<"EOT");
<hr>
<form method="GET" action="$url_prefix/create">
Create
<select name="type" size=1>
<option value="mailbox" selected>mailbox</option>
<option value="directory" selected>directory</option>
</select>
with name
<input name="name">
<input type="submit" name="create" value="Create">
</form>
EOT
} elsif ($which eq "copy" || $which eq "move") {
my $button = ($which eq "copy") ? "Copy" : "Rename";
$r->print(<<"EOT");
<form method="GET" action="$url_prefix/copy_move/$which">
New name
<input name="name">
<input type="submit" name="copy_move" value="$button">
<input type="submit" name="cancel" value="Cancel">
</form>
EOT
} else {
#
# save_copy or save_move
#
my $copy_or_save = ($which eq "save_copy") ? "Copy" : "Save";
$r->print(<<"EOT");
<form method="GET" action="$url_prefix/do_save">
$copy_or_save to new mailbox
<input name="name">
<input type="hidden" name="addcwd" value="y">
<input type="submit" name="save" value="$copy_or_save">
<input type="submit" name="cancel" value="Cancel">
</form>
EOT
}
$r->print("</body></html>\n");
}
sub cmd_rm {
my ($conn, $type, $name) = @_;
my $r = $conn->{request};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $display_name = canon_decode($name);
$display_name =~ s(/$)();
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Confirm $type deletion</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/mailboxes">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><a href="$url_prefix/logout//mailboxes">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
<h1 align="center">Really delete $type $display_name?</h1>
<table width="100%">
<tr>
<td align="center">
<a href="$url_prefix/mailboxes">
<img src="$icon_prefix/cancel-delete.gif" border=0 alt="Cancel delete"></a>
</td>
<td align="center">
<a href="$url_prefix/really_rm/$type/$name" target="_parent">
<img src="$icon_prefix/confirm-delete.gif" border=0 alt="Confirm delete"></a>
</td>
</tr>
</table>
</body></html>
EOT
}
sub cmd_really_rm {
my ($conn, $type, $name) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
$name = canon_decode($name);
$name =~ s(/$)();
my $imap_name = $name;
if ($type eq "directory") {
$imap_name .= "/";
} else {
$type = "mailbox";
}
# $r->warn("rm $imap_name"); # debug
printf $s "rm %s\n", maild_encode($imap_name);
chomp(my $result = <$s>);
if ($result eq "OK") {
maild_set($s, "message", "\u$type $name has been deleted");
return redirect($r, "$conn->{url_prefix}/mailboxes");
}
#
# XXX Make error message prettier
# In case of error we get back "NO imap_error_message_maild_encoded\n"
$result =~ s/^NO //;
$result = maild_decode($result);
dont_cache($r, "text/plain");
$r->print("Failed to delete $type $name: $result\n");
return OK;
}
sub cmd_copy_move_from {
my ($conn, $type, $name) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
$name = canon_decode($name);
# $r->warn("set copy_move_from $name"); # debug
maild_set($s, "copy_move_from", $name);
if ($type ne "move") {
$type = "copy";
}
return redirect($r, "$conn->{url_prefix}/mailboxes/$type");
}
sub cmd_copy_move {
my ($conn, $type) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
my %q = $r->args;
if ($type ne "copy") {
$type = "move";
}
if (!exists($q{copy_move})) {
maild_set($s, "message", "Cancelled $type of directory or mailbox");
return redirect($r, "$conn->{url_prefix}/mailboxes");
}
my $oldname = maild_get($s, "copy_move_from");
my $newname = $q{name};
my $cwd = maild_get($s, "cwd");
$newname = "$cwd/$newname" if length($cwd);
if ($type eq "move") {
# $r->warn("move $oldname $newname"); # debug
printf $s "move %s %s\n", maild_encode($oldname, $newname);
} else {
# $r->warn("copy $oldname $newname"); # debug
printf $s "copy %s %s\n", maild_encode($oldname, $newname);
}
chomp(my $result = <$s>);
if ($result eq "OK") {
maild_set($s, "message",
sprintf("%s %s to %s",
($type eq "copy") ? "Copied" : "Renamed",
$oldname, $newname));
return redirect($r, "$conn->{url_prefix}/mailboxes");
}
#
# XXX Make error message prettier
# In case of error we get back "NO imap_error_message_maild_encoded\n"
$result =~ s/^NO //;
$result = maild_decode($result);
dont_cache($r, "text/plain");
$r->print("Failed to $type $oldname to $newname: $result\n");
return OK;
}
sub cmd_create {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my %q = $r->args;
if (!exists($q{create})) {
maild_set($s, "message", "Cancelled creation of mailbox");
return redirect($r, "$conn->{url_prefix}/mailboxes");
}
my $type = $q{type};
$type = url_decode($type);
my $name = $q{name};
$name = url_decode($name);
$name =~ s(/$)();
my $cwd = maild_get($s, "cwd");
my $imap_name = length($cwd) ? "$cwd/$name" : $name;
if ($type eq "directory") {
$imap_name .= "/";
} else {
$type = "mailbox";
}
# $r->warn("create $imap_name"); # debug
printf $s "create %s\n", maild_encode($imap_name);
chomp(my $result = <$s>);
if ($result eq "OK") {
maild_set($s, "message", "\u$type $name has been created");
return redirect($r, "$conn->{url_prefix}/mailboxes");
}
#
# XXX Make error message prettier
# In case of error we get back "NO imap_error_message_maild_encoded\n"
$result =~ s/^NO //;
$result = maild_decode($result);
dont_cache($r, "text/plain");
$r->print("Failed to create $type $name: $result\n");
return OK;
}
sub cmd_delete {
my ($conn, $uid, $msgno) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "setflag $msgno \\Deleted\n";
maild_set($s, "message", "Deleted message $msgno");
return redirect($r, "$conn->{url_prefix}/list");
}
sub cmd_undelete {
my ($conn, $uid, $msgno, $callback) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "clearflag $msgno \\Deleted\n";
if ($callback eq "display") {
$callback .= "/$uid/$msgno";
}
return redirect($r, "$conn->{url_prefix}/$callback");
}
sub cmd_expunge {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "expunge\n";
maild_set($s, "message", "Messages tagged as deleted have been purged");
return redirect($r, "$conn->{url_prefix}/list");
}
sub cmd_send {
my $conn = shift;
my $r = $conn->{request};
my $url_prefix = $conn->{url_prefix};
my $s = $conn->{maild};
print $s "sendmail\n";
chomp(my $reply = <$s>);
if ($reply !~ s/^OK\s*//) {
$r->content_type("text/plain");
$r->send_http_header;
$r->print("Failed to send message");
return;
}
maild_set($s, "message", $reply);
return redirect($r, "$conn->{url_prefix}/list");
}
sub do_bulk {
my ($s, $type, $range, $return_to) = @_;
#
# Searching is done via the "bulk" field too so we check
# for that first. As a special case, a blank (i.e. zero length)
# search field means to *reset* all marked messages.
#
if ($type eq "search") {
if ($range eq "") {
print $s "clearflag 1:* \\Flagged\n";
return ("message", "Unmarked all messages.");
}
my $sane_length = 40;
$range =~ tr/\x20-\x7e\xa0-\xfe//cd;
if (length($range) < 1 || length($range) > $sane_length) {
return ("message",
"Search target must be between 1 and $sane_length printable characters.");
}
printf $s "search new %s\n", maild_encode($range);
chomp(my $result = <$s>);
return ("message", $result);
}
#
# Convert from our range format (1-4,6-50,60-end) to IMAP format
# (1:4,6:50,60:*). We also allow "*", "$" and "last" as synonyms
# for "end". We allow "f" or "flagged" or "found" to cause bulk
# operation on all flagged messages, and we deal with this first
# as a special case. Oh, and we do case-insensitive comparisons.
#
if ($range =~ /^f(lagged|ound)?$/i) {
if ($type eq "delete") {
print $s "delete_flagged\n";
return ("message", "Marked all flagged messages as deleted");
}
if ($type eq "copy" || $type eq "move") {
maild_set($s, "pending_save", "$type $return_to flagged");
return ("redirect", "mailboxes/save_$type");
}
return ("error", "bad bulk operation ($type) for flagged messages");
}
$range =~ tr/a-zA-Z0-9,*-//cd;
if (length($range) > 100) {
# sanity check
return ("message",
"Range specification too long. Bulk operation not done.");
}
my @subranges = split(/,/, $range);
foreach (@subranges) {
s/-(end|last|\*|\$)$/-*/i;
if (!/^\d{1,6}(-(\d{1,6}|\*))?$/) {
return ("message",
"Bad range $range. Must look like '1-4,6-10,20-end' or be 'f'");
}
tr/-/:/;
}
my $imap_range = join(",", @subranges);
if ($type eq "delete") {
print $s "setflag $imap_range \\Deleted\n";
return ("message", "Marked message range $range as deleted");
}
if ($type eq "undelete") {
print $s "clearflag $imap_range \\Deleted\n";
return ("message", "Undeleted message range $range");
}
if ($type eq "flag") {
print $s "setflag $imap_range \\Flagged\n";
return ("message", "Flagged message range $range");
}
if ($type eq "copy" || $type eq "move") {
maild_set($s, "pending_save", "$type $return_to $imap_range");
return ("redirect", "mailboxes/save_$type");
}
return ("error", "no such bulk operation: $type");
}
sub cmd_bulk {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my %q = $r->args;
my $return_to = "list"; # the only place we're called from at the moment
my ($action, $data) = do_bulk($s, $q{type}, $q{range}, $return_to);
if ($action eq "error") {
return wing_error($r, $data);
} elsif ($action eq "message") {
maild_set($s, "message", $data);
return redirect($r, "$conn->{url_prefix}/$return_to");
} elsif ($action eq "redirect") {
return redirect($r, "$conn->{url_prefix}/$data");
} else {
return wing_error($r, "do_bulk returned unknown action");
}
}
sub cmd_save {
my ($conn, $type, $called_from, $seq) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
if ($type ne "copy" && $type ne "move") {
return wing_error($r, "save subcommand must be copy or move");
}
maild_set($s, "pending_save", "$type $called_from $seq");
return redirect($r, "$conn->{url_prefix}/mailboxes/save_$type");
}
sub cmd_do_save {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my %q = $r->args;
my ($type, $called_from, $seq) = split(' ', maild_get($s, "pending_save"));
my $return_to;
if ($called_from eq "list") {
$return_to = "list";
} else {
my ($uid, $msgno) = split(/-/, $called_from);
$return_to = "display/$uid/$msgno";
}
#
# Convert IMAP sequence (1:4,6:*) to pretty format (1-4,6-end).
# Note that $seq can also be the word "flagged" when a copy/save
# with range "flagged" has been done as a do_bulk operation.
#
my $pretty_seq = $seq;
$pretty_seq =~ tr/:/-/;
$pretty_seq =~ s/\*/end/g;
if (!exists($q{save})) {
maild_set($s, "message", "Cancelled \l$type of message(s) $pretty_seq");
return redirect($r, "$conn->{url_prefix}/$return_to");
}
my $name = $q{name};
$name = url_decode($name);
if ($q{addcwd}) {
#
# Someone has typed in a new mailbox name for this directory.
# Get the cwd and prepend that to get the full pathname.
#
my $cwd = maild_get($s, "cwd");
if (length($cwd)) {
$name = "$cwd/$name";
}
}
printf $s "save %s %s %s\n", $type, $seq, maild_encode($name);
chomp(my $result = <$s>);
if ($result eq "OK") {
my $msg = sprintf("%s message(s) %s to mailbox %s",
($type eq "copy") ? "Copied" : "Moved",
$pretty_seq, $name);
maild_set($s, "message", $msg);
return redirect($r, "$conn->{url_prefix}/$return_to");
} else {
$result =~ s/^NO //;
$result = maild_decode($result);
$r->content_type("text/plain");
$r->send_http_header;
$r->print("Failed to save message(s) to mailbox $name: $result\n");
return OK;
}
}
sub cmd_attachments {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my @attachments;
print $s "lsattach\n";
while (1) {
chomp(my $comment = <$s>);
if (!$comment) {
$r->log_error("attachments: maild daemon vanished unexpectedly");
last;
}
last if $comment eq "."; # the proper way to terminate the list
$comment = maild_decode($comment);
#
# Netscape for Macintosh seems to URL-encode filenames with
# spaces and Netscape Messenger URL-decodes names when it
# displays them. We do the same, although I don't see why a
# Content-Disposition header has anything to do with URL encoding.
#
push(@attachments, url_decode($comment));
}
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>MIME Attachments</title></head>
<body>
<a href="$url_prefix/compose">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a>
<img src="$icon_prefix/blank.gif" alt=" | ">
<a href="$url_prefix/logout//attachments">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<h1>MIME Attachments</h1>
EOT
if (@attachments) {
$r->print("<table>\n");
my $relnum = 1;
foreach my $a (@attachments) {
$r->print(<<"EOT");
<tr>
<td align="right">$relnum.</td>
<td>$a</td>
<td><a href="$url_prefix/detach/$relnum">
<img src="$icon_prefix/detach.gif" border=0 alt="Detach"></a></td>
</tr>
EOT
$relnum++;
}
$r->print("</table>\n<hr>\n");
}
else {
$r->print("(No files yet attached to this message)");
}
$r->print(<<"EOT");
<h1>Attach file</h1>
<form action="$url_prefix/attach" method="POST" enctype="multipart/form-data">
File <input align="middle" type="file" name="file">
<br>
<input type="submit" value="Attach">
</form>
</body>
</html>
EOT
}
sub cmd_detach {
my ($conn, $relnum) = @_;
my $r = $conn->{request};
my $s = $conn->{maild};
if ($relnum !~ /\D/ && $relnum >= 0) {
print $s "detach $relnum\n";
}
dont_cache($r);
return redirect($r, "$conn->{url_prefix}/attachments");
}
sub cmd_attach {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
print $s "attach\n";
chomp(my $data = <$s>);
if ($data eq ".") {
return wing_error($r, "Attach failed: couldn't create attach file");
}
my ($relnum, $filename) = split(' ', $data);
my ($error, $type, $client_filename) = _receive_upload($r, $filename);
return wing_error($r, $error) if $error;
#
# Update the comment to be the client-local filename if possible
#
if (defined($client_filename)) {
printf $s "attach %d comment %s\n",
$relnum, maild_encode($client_filename);
printf $s "attach %d filename %s\n",
$relnum, maild_encode($client_filename);
}
#
# Update with the MIME type if we have it, otherwise force octet-stream
#
$type ||= "application/octet-stream";
printf $s "attach %d type %s\n", $relnum, maild_encode($type);
#
# Redirect client back to main MIME attachments screen
#
return redirect($r, "$conn->{url_prefix}/attachments");
}
sub cmd_include {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
if ($r->method ne "POST") {
$r->content_type("text/html");
$r->send_http_header;
$r->print(<<"EOT");
<html><head><title>Include local file in message body</title></head>
<body>
<a href="$url_prefix/compose">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a>
<img src="$icon_prefix/blank.gif" alt=" | ">
<a href="$url_prefix/logout//include">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<h1 align="center">Include local file in message body</h1>
<form method="POST" action="$url_prefix/include" enctype="multipart/form-data">
File <input align="middle" type="file" name="file">
<br>
<input type="submit" value="Include">
</form>
</body>
</html>
EOT
return;
}
print $s "tmpdir\n";
chomp(my $tmpdir = <$s>);
my $inc_file = "$tmpdir/include";
my ($error, $type, $client_filename) = _receive_upload($r, $inc_file);
if ($error) {
$r->content_type("text/plain");
$r->send_http_header;
$r->print("Include failed: $error");
return;
}
#
# copy contents to body (just before sig indicator line if there is one)
#
my $bodyfh = IO::File->new("$tmpdir/body")
or return wing_error($r, "Include failed appending to body file: $!");
my $newbodyfh = IO::File->new(">$tmpdir/newbody")
or return wing_error($r, "Include failed creating new body file: $!");
my $incfh = IO::File->new("$tmpdir/include")
or return wing_error($r, "Include failed re-opening include file: $!");
my $done_include = 0;
while (defined(my $line = <$bodyfh>)) {
if (!$done_include && $line =~ /^-- $/) {
while (read($incfh, my $buffer, _CHUNK_SIZE)) {
print $newbodyfh $buffer;
}
$done_include = 1;
}
print $newbodyfh $line;
}
if (!$done_include) {
while (read($incfh, my $buffer, _CHUNK_SIZE)) {
print $newbodyfh $buffer;
}
}
$incfh->close;
$bodyfh->close;
$newbodyfh->close;
rename("$tmpdir/newbody", "$tmpdir/body")
or return wing_error($r, "Include failed renaming new body file: $!");
unlink("$tmpdir/include");
return redirect($r, "$url_prefix/compose");
}
sub cmd_export {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
$r->content_type("text/plain");
$r->send_http_header;
#
# Fake up a harmless envelope from line
#
print $s "username\n";
chomp(my $username = <$s>);
my $now = localtime;
my $from_line = "From $username\@$SENDMAIL_FROM_HOSTNAME $now\n";
print $s "nmsgs\n";
chomp(my $nmsgs = <$s>);
for (my $i = 1; $i <= $nmsgs; $i++) {
print $s "headers $i all\n";
chomp(my $size = <$s>);
read($s, my $headers, $size);
$headers =~ tr/\r//d;
print $s "body $i\n";
chomp($size = <$s>);
read($s, my $body, $size);
if (substr($body, -1) ne "\n") {
$body .= "\n"; # must ensure newline termination of message
}
$r->print($from_line, $headers, $body);
}
}
sub cmd_manage {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $info_msg = info_message_html($s);
my $wingdir = wing_directory($s);
my $quota = maild_get($s, "quota");
$quota = $DISK_QUOTA if $quota eq "";
my $forward = "";
my $vacation_message = "";
my $vacation_active = -e "$wingdir/$VACATION_ACTIVE_FILE";
if (-e "$wingdir/$VACATION_MESSAGE_FILE") {
local($/) = undef; # slurp
local(*MESS);
open(MESS, "$wingdir/$VACATION_MESSAGE_FILE");
$vacation_message = <MESS>;
close(MESS);
}
{
local($/) = undef; # slurp
local(*FORWARD);
open(FORWARD, "$wingdir/$FORWARD_FILE");
$forward = <FORWARD>;
close(FORWARD);
}
my $forward_html = escape_html($forward);
my $vacation_message_html = escape_html($vacation_message);
if ($r->method eq "POST") {
my %q = $r->content;
my @info;
if (defined($q{set_forward})) {
$forward = $q{forward};
$forward_html = escape_html($forward);
#
# Sanity check forwarding address
#
s/\s*$//sg;
$forward .= "\n" if length($forward);
if (length($forward) > 256) {
push(@info, "Forwarding address is too long");
} else {
push(@info, do_write_file("$wingdir/$FORWARD_FILE", $forward)
? "Forwarding address has been updated"
: "Failed to update forwarding address");
}
}
if (defined($q{set_vac_text})) {
$vacation_message = $q{vacation_message};
$vacation_message =~ tr/\r//d;
$vacation_message_html = escape_html($vacation_message);
#
# Remove trailing white space from message, check its length
# and update the vacation message file.
#
$vacation_message =~ s/\s*$//sg;
$vacation_message .= "\n" if length($vacation_message);
if (length($vacation_message) > 1024) {
push(@info, "Vacation message is too long");
} else {
push(@info, do_write_file("$wingdir/$VACATION_MESSAGE_FILE",
$vacation_message)
? "Vacation message has been updated"
: "Failed to update vacation message");
}
}
if (defined($q{vac_on})) {
local(*ACTIVE);
sysopen(ACTIVE, "$wingdir/$VACATION_ACTIVE_FILE",
O_CREAT|O_RDWR, 0664);
close(ACTIVE);
$vacation_active = -e "$wingdir/$VACATION_ACTIVE_FILE";
push(@info, $vacation_active
? "Vacation autoreply is now active"
: "Failed to activate vacation autoreply");
} elsif (defined($q{vac_off})) {
unlink map {
"$wingdir/$_";
} ($VACATION_ACTIVE_FILE, @VACATION_DB_FILES);
$vacation_active = -e "$wingdir/$VACATION_ACTIVE_FILE";
push(@info, $vacation_active
? "Failed to deactivate vacation autoreply"
: "Vacation autoreply is now inactive");
}
if (@info) {
$info_msg = "<br><strong>"
. join("\n<br>\n", @info)
. "</strong><br>";
}
}
my $vacation_blurb;
if ($vacation_active) {
$vacation_blurb = <<"EOT";
Your vacation autoreply is active: all mail sent to you will generate
an autoreply containing your vacation message. To deactivate your
vacation autoreply, use this button:
<br>
<input type="submit" name="vac_off" value="Deactivate vacation autoreply">
EOT
} else {
$vacation_blurb = <<"EOT";
Your vacation autoreply is not active. If you want every message sent
to you to generate an autoreply containing your vacation message,
use this button:
<br>
<input type="submit" name="vac_on" value="Activate vacation autoreply">
EOT
}
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Manage account</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/list">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//manage">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
$info_msg
<h2 align="center">Manage account</h2>
<br>
Your disk quota is $quota KB. For current disk usage, use this button:
<a href="$url_prefix/diskusage">
<img src="$icon_prefix/disk-usage.gif" border=0 align="absmiddle" alt="Disk Usage"></a>
<hr>
To change your password, use this button:
<a href="$url_prefix/chpass">
<img src="$icon_prefix/change-password.gif" border=0 align="absmiddle" alt="Change password"></a>
<hr>
To export the entire current mailbox to your browser in raw
format ("Berkeley" format, also known as "Unix" format), use this button:
<a href="$url_prefix/export">
<img src="$icon_prefix/export.gif" border=0 align="absmiddle" alt="Export"></a>
<hr>
<form method="POST" action="$url_prefix/manage">
Forwarding address(es) (blank for no forwarding)
<br>
<input name="forward" size="50" value="$forward_html">
<input type="submit" name="set_forward" value="Update forwarding address">
<hr>
Vacation message body to send when autoreply is active
<br>
<textarea name="vacation_message" cols="70" rows="8">
$vacation_message_html</textarea>
<input type="submit" name="set_vac_text" value="Update text">
<br>
$vacation_blurb
</form>
</body></html>
EOT
}
#
# Change a user's password. Returns undef on success, otherwise returns
# a message to be displayed on the password changing screen.
#
sub do_chpass {
my ($username, $oldpassword, $newpassword) = @_;
my $info_msg = FascistCheck($newpassword);
if ($info_msg) {
return "Proposed password is not acceptable because $info_msg";
}
#
# Solaris /usr/bin/passwd does a few checks of its own which
# aren't caught by cracklib. We check for them here so that
# the IMAP server doesn't just give a general "refused to change
# password" error.
#
if (($newpassword =~ tr/[a-zA-Z]//) < 2
|| ($newpassword =~ tr/[a-zA-Z]//c) < 1)
{
return "Password must contain at least two alphabetic characters"
." and at least one non-alphabetic character";
}
my $lcpass = lc($newpassword);
for (my $i = 0; $i < length($username); $i++) {
my $rotate = substr($username, $i) . substr($username, 0, $i);
if ($lcpass eq $rotate || $lcpass eq reverse($rotate))
{
return "Password must not be a reverse or circular shift"
." of your username";
}
}
my $diffcount = 0;
for (my $i = 0; $i < length($lcpass); $i++) {
if (substr($lcpass, $i, 1) ne substr($oldpassword, $i, 1)) {
$diffcount++;
}
}
if ($diffcount < 3) {
return "New password must differ from old by at least 3 characters";
}
#
# If we get this far we can send the request to the IMAP server
#
local(*CHPASS);
my $rport = getservbyname("chpassd", "tcp") || 502;
my $raddr = gethostbyname("$username.$WING_DOMAIN")
or return "Change failed: can't find IMAP server from username";
my $rsin = sockaddr_in($rport, $raddr);
socket(CHPASS, AF_INET, SOCK_STREAM, 0)
or return "Change failed: can't create socket to contact IMAP server";
connect(CHPASS, $rsin)
or return "Change failed: can't contact IMAP server. Please try later.";
select(CHPASS); $| = 1; select(STDOUT);
print CHPASS "$username\r\n$oldpassword\r\n$newpassword\r\n";
my $result;
{
local($/) = "\r\n";
chomp($result = <CHPASS>);
}
close(CHPASS);
if ($result eq "OK") {
return undef;
} else {
return "IMAP server refused to change password "
. "(probably because old password was incorrect)";
}
}
sub cmd_chpass {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $info_msg = "";
print $s "username\n";
chomp(my $username = <$s>);
if ($r->method eq "POST") {
my %q = $r->content;
if (!defined($q{change_password})) {
maild_set($s, "message", "Cancelled password change");
return redirect($r, "$url_prefix/manage");
}
my $oldpassword = $q{oldpassword};
my $newpassword = $q{newpassword};
my $newpasswordagain = $q{newpasswordagain};
if ($newpassword ne $newpasswordagain) {
$info_msg = "New password fields do not match: try again";
} else {
$info_msg = do_chpass($username, $oldpassword, $newpassword);
if (!defined($info_msg)) {
maild_set($s, "message",
"Password change successful: don't forget it");
return redirect($r, "$url_prefix/manage");
}
}
}
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Change password</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/manage">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//chpass">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
<h2 align="center">Change password for $username</h2>
<br><strong>$info_msg</strong><br>
<form method="POST" action="$url_prefix/chpass">
<table>
<tr>
<td>Old password</td>
<td><input type="password" name="oldpassword" size="16"></td>
</tr>
<td>New password</td>
<td><input type="password" name="newpassword" size="16"></td>
</tr>
<tr>
<td>Re-enter new password</td>
<td><input type="password" name="newpasswordagain" size="16"></td>
</tr>
</table>
<input type="submit" name="change_password" value="Change password">
<input type="submit" name="cancel" value="Cancel">
</form>
$PASSWORD_INFO
</body></html>
EOT
}
sub cmd_diskusage {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
print $s "username\n";
chomp(my $username = <$s>);
my $group = maild_get($s, "group");
# $r->warn("PID $$ cmd_diskusage connected to database for $username");#debug
my $dbh = DBI->connect(@WING_DBI_CONNECT_ARGS);
my ($uid, $gid, $quota) = $dbh->selectrow_array(
"select uid, gid, quota from users where username = '$username'"
);
$dbh->disconnect;
# $r->warn("PID $$ cmd_diskusage disconnected from database");#debug
if (!defined($gid)) {
return wing_error($r, "Can't find user/group id: $DBI::errstr");
}
my @usage;
{
local($/) = "\0"; # null terminated records
chomp(@usage = `$IMAPDU_COMMAND $group $gid $username $uid`);
}
if ($? >> 8) {
return wing_error($r, "Failed to get disk usage information");
}
@usage = sort { $b->[0] <=> $a->[0] } map {
my ($size, $name) = split(' ', $_, 2);
$name =~ s(^./)();
$size = int($size / 1024 + 0.5);
[$size, $name];
} @usage;
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Disk Usage</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/manage">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//options">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
<h2 align="center">Current Disk Usage</h2>
<table>
<tr><th align="right">Size/KB</th><th align="left">Mailbox</th></tr>
EOT
my $total = 0;
while (defined(my $u = shift @usage)) {
$total += $u->[0];
my $name_canon = canon_encode($u->[1]);
my $name_html = escape_html($u->[1]);
$r->print(<<"EOT");
<tr>
<td align="right">$u->[0]</td>
<td><a href="$url_prefix/change/$name_canon">$name_html</a></td>
</tr>
EOT
}
my $remaining = $quota - $total;
$r->print(<<"EOT");
</table>
Total usage $total KB out of $quota KB with $remaining KB remaining.
</body></html>
EOT
}
sub cmd_options {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $info_msg = "";
print $s "username\n";
chomp(my $username = <$s>);
my $list_size = maild_get($s, "list_size");
my $signature = maild_get($s, "signature");
my $compose_headers = maild_get($s, "compose_headers");
my $copy_outgoing = maild_get($s, "copy_outgoing");
$copy_outgoing = $copy_outgoing ? 1 : 0;
my $copy_outgoing_checked = $copy_outgoing ? " checked" : "";
my $portal = maild_get($s, "portal");
my $portal_html = $portal ? "" : <<"EOT";
To switch to a portal view of your mail (your browser must support
frames), use this button:
<a href="$url_prefix/portal">
<img src="$icon_prefix/portal.gif" border=0 align="absmiddle" alt="Portal"></a>
<hr>
EOT
my %q = $r->content;
$r->content_type("text/html");
$r->send_http_header;
#
# Set options according to %q
#
my $do_settings = defined($q{set}) ? 1 : 0;
my $save_settings = defined($q{save}) ? 1 : 0;
if ($do_settings || $save_settings) {
my @errors;
while (my ($key, $value) = each %q) {
$value =~ tr/\r//d;
if ($key eq "list_size" && $value ne $list_size) {
if ($value =~ /^\d{1,4}$/) {
$list_size = $value;
maild_set($s, "list_size", $list_size);
} else {
push(@errors, "Illegal message list number: $value.");
}
} elsif ($key eq "signature" && $value ne $signature) {
my @lines = split(/\n/, $value);
if (@lines <= 4
&& length($lines[0]) < 80 && length($lines[1]) < 80
&& length($lines[2]) < 80 && length($lines[3]) < 80)
{
$signature = join("\n", @lines);
maild_set($s, "signature", $signature);
}
else {
push(@errors,
"Signature does not comply with constraints.");
}
}
}
my $new_copy_outgoing = $q{copy_outgoing} ? 1 : 0;
if ($new_copy_outgoing != $copy_outgoing) {
$copy_outgoing = $new_copy_outgoing;
$copy_outgoing_checked = $copy_outgoing ? " checked" : "";
maild_set($s, "copy_outgoing", $copy_outgoing);
}
if (@errors) {
my $error = join("\n<br>\n", @errors);
$r->print(<<"EOT");
<html><head><title>Bad options</title></head>
<body>
<h1>Bad options</h1>
Some of the options you chose cannot be set:
<br>
$error
<br>
Please return to the <a href="$url_prefix/options">Options</a>
screen and try again.
</body>
</html>
EOT
return;
}
}
if ($save_settings) {
# $r->warn("PID $$ cmd_options connected to database for $username");#debug
my $dbh = DBI->connect(@WING_DBI_CONNECT_ARGS);
$dbh->{AutoCommit} = 1;
my $done = 0;
my $sql = "update options ";
$sql .= "set listsize = $list_size";
$sql .= sprintf(", signature = %s", $dbh->quote($signature));
$sql .= sprintf(", composeheaders = %s",
$dbh->quote($compose_headers));
$sql .= sprintf(", copyoutgoing = '%s'", $copy_outgoing ? "t" : "f");
$sql .= " where username = '$username'";
$done = $dbh->do($sql);
# $r->warn("return value $done from: $sql"); # debug
if ($done eq "0E0") {
#
# If the user has never saved options before then we insert
# a row for the username (with all other fields null) and
# then redo the update. That saves messing about with the
# different SQL syntax for inserts and updates.
#
$dbh->do("insert into options (username) values ('$username')")
and $done = $dbh->do($sql);
}
$info_msg = $done ? "Options have been set and saved"
: "Options could not be saved";
$dbh->disconnect;
# $r->warn("PID $$ cmd_options disconnected from database");#debug
} elsif ($do_settings) {
$info_msg = "Options have been set for this session only";
}
$r->print(<<"EOT");
<html><head><title>Options for username $username</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/list">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//options">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
<br><strong>$info_msg</strong><br>
<h2 align="center">Options</h2>
<form method="POST" action="$url_prefix/options">
$portal_html
Number of messages listed in one screenful.
Enter 0 to list all messages on one screen.
<br>
<input size=4 name="list_size" value="$list_size">
<hr>
<input type="checkbox" name="copy_outgoing" value="1"$copy_outgoing_checked>
Save copy of outgoing messages in mailbox $SENT_MAIL_MAILBOX
<hr>
Signature to append to outgoing messages (maximum four lines
and 79 characters per line).
<br>
<textarea name="signature" rows=4 cols="80">
$signature
</textarea>
<hr>
<input type="submit" name="set" value="Set for this session">
<input type="submit" name="save" value="Set and save for future sessions">
<input type="reset" value="Reset">
</form>
</body>
</html>
EOT
}
sub do_search {
my ($r, $s, $type, $subject, $text, $from, $to) = @_;
if ($type ne "and" && $type ne "or") {
$type = "new";
}
#
# Delete non-printables and quotes from search strings and then
# truncate search strings to the first 40 characters. In fact,
# maild does a similar (in fact, the same) sanity check but for
# safety's sake (i.e. in case someone tweaks one or the other)
# we do it in both places since there's no documentation on
# exactly what's legal/safe/secure to pass to search.
#
foreach ($subject, $text, $from, $to) {
tr/\x20-\x7e\xa0-\xfe//cd;
tr/"//d;
$_ = substr($_, 0, 40);
}
#
# We pass the search target to maild as double quote separated
# fields in the order text, subject, from, to.
#
my $target = join('"', maild_encode($text, $subject, $from, $to));
print $s "search $type $target\n";
chomp(my $result = <$s>);
maild_set($s, "message", $result);
}
sub cmd_search {
my $conn = shift;
my $r = $conn->{request};
my $s = $conn->{maild};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my $info_msg = info_message_html($s);
my %q = $r->method eq "POST" ? $r->content : $r->args;
if ($q{search}) {
do_search($r, $s, @q{qw(type subject text from to)});
return redirect($r, "$url_prefix/list");
}
$r->content_type("text/html");
$r->send_http_header;
$r->print(<<"EOT");
<html><head><title>Search mailbox</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/list">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/help/search">
<img src="$icon_prefix/help.gif" border=0 alt="Help"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//search">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
<br><strong>$info_msg</strong><br>
<h2 align="center">Search mailbox</h2>
<form method="POST" action="$url_prefix/search">
Search current mailbox for messages which match all
the following conditions:
<table>
<tr><td>Subject</td><td><input name="subject" size="40"></td></tr>
<tr><td>Message text</td><td><input name="text" size="40"></td></tr>
<tr><td>From</td><td><input name="from" size="40"></td></tr>
<tr><td>To</td><td><input name="to" size="40"></td></tr>
</table>
<select name="type">
<option value="new" selected>Only mark matching messages</option>
<option value="and">Restrict search to currently marked messages</option>
<option value="or">Mark matching messages in addition to those currently marked</option>
</select>
<br>
<input type="submit" name="search" value="Search">
</form>
</body>
</html>
EOT
}
sub get_cal_html {
my ($month, $year, $today_day, $today_month, $today_year) = @_;
chomp(my ($month_and_year, $days, @dates) = `$CAL_PATH $month $year`);
# Apache->warn("get_cal_html(@_): got $month_and_year, ret $?\n");#debug
for ($days, @dates) {
s{(..).?}{<td align="right">$1</td>}g;
}
my $cal_html = <<"EOT";
<table>
<tr><th colspan=7 align="center">$month_and_year</th></tr>
EOT
$cal_html .= "<tr>" . join("</tr>\n<tr>", $days, @dates) . "</tr>\n";
$cal_html .= "</table>\n";
if ($today_year == $year && $today_month == $month) {
$cal_html =~ s{\b$today_day\b}{<strong>$today_day</strong>};
}
return $cal_html;
}
sub cmd_calendar {
my $conn = shift;
my $r = $conn->{request};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
my %q = $r->args;
# get current date in form 1-31, 0-11, y-1900
my ($this_mday, $this_month, $this_year) = (localtime)[3, 4, 5];
$this_month++; # we use month 1-12
$this_year += 1900; # we use absolute year number
my $year = $q{year} || $this_year;
my $month = $q{month} || $this_month;
#
# Sanity check month and year. cal itself gets upset if you pass
# in a year that's not between 1 and 9999. We restrict by one
# extra year either side so that we don't have to worry about
# next/previous month hitting bad years and getting involved in
# complicated error checks.
#
$year += 0;
$month += 0;
if ($year < 2 || $year > 9998 || $month < 1 || $month > 12) {
$year = $this_year;
$month = $this_month;
}
my $next_month = $month + 1;
my $next_month_year = $year;
if ($next_month == 13) {
$next_month = 1;
$next_month_year++;
}
my $last_month = $month - 1;
my $last_month_year = $year;
if ($last_month == 0) {
$last_month = 12;
$last_month_year--;
}
my $cal = get_cal_html($month, $year, $this_mday, $this_month, $this_year);
my $last_cal = get_cal_html($last_month, $last_month_year,
$this_mday, $this_month, $this_year);
my $next_cal = get_cal_html($next_month, $next_month_year,
$this_mday, $this_month, $this_year);
my @months = qw(January February March April May June July August
September October November December);
my $month_options;
for (my $m = 1; $m <= 12; $m++) {
my $sel = ($month == $m) ? " selected" : "";
$month_options .= qq(<option value="$m"$sel>$MONTH_NAME[$m-1]</option>\n);
}
dont_cache($r, "text/html");
$r->print(<<"EOT");
<html><head><title>Calendar</title></head>
<body>
<a href="$url_prefix/list">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a>
<img src="$icon_prefix/blank.gif" alt=" | ">
<a href="$url_prefix/logout//calendar">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a>
<h1 align="center">Calendar</h1>
<h2 align="center">
Today is
<a href="$url_prefix/calendar">
$this_mday $MONTH_NAME[$this_month-1] $this_year</a>
</h2>
<form action="$url_prefix/calendar" method="GET">
<table border cellpadding=5>
<tr align="center">
<td><a href="$url_prefix/calendar?month=$last_month&year=$last_month_year">
Previous month</a></td>
<td>
<select name="month">
$month_options
</select>
<input size=5 name="year" value="$year">
<input type="submit" value="Go">
</td>
<td><a href="$url_prefix/calendar?month=$next_month&year=$next_month_year">
Next month</a></td>
</tr>
<tr valign="top" align="center">
<td>$last_cal</td>
<td>$cal</td>
<td>$next_cal</td>
</tr>
</table>
</form>
EOT
}
sub cmd_help {
my ($conn, $cmd) = @_;
my $r = $conn->{request};
my $url_prefix = $conn->{url_prefix};
my $icon_prefix = icon_prefix($r);
#
# Sanity check command since we'll be using it to map to a filename
#
if (length($cmd) > 64 || $cmd !~ /^[a-z]\w*$/) {
return wing_error($r, "Bad command: $cmd");
}
#
# XXX Should abstract out filename mapping a bit more perhaps
#
local(*HELP);
my $subr = $r->lookup_uri("/wing-help/$cmd.html");
if (!defined($subr) || !open(HELP, $subr->filename)) {
return wing_error($r, "No help available on $cmd");
}
$r->print(<<"EOT");
<html><head><title>Help</title></head>
<body>
<table>
<tr>
<td><a href="$url_prefix/$cmd">
<img src="$icon_prefix/back.gif" border=0 alt="Back"></a></td>
<td><img src="$icon_prefix/blank.gif" alt=" | "></td>
<td><a href="$url_prefix/logout//$cmd">
<img src="$icon_prefix/logout.gif" border=0 alt="Logout"></a></td>
</tr>
</table>
EOT
$r->send_fd(\*HELP);
close(HELP);
}
use Wing::Abook; # Wing::Connection handlers for address books
use Wing::Portal; # Wing::Connection handlers for portal stuff
1;