1package Qpsmtpd::ConfigServer;
2
3use base ('Danga::Client');
4use Qpsmtpd::Constants;
5
6use strict;
7
8use fields qw(
9  _auth
10  _commands
11  _config_cache
12  _connection
13  _transaction
14  _test_mode
15  _extras
16  other_fds
17  );
18
19my $PROMPT = "Enter command: ";
20
21sub new {
22    my Qpsmtpd::ConfigServer $self = shift;
23
24    $self = fields::new($self) unless ref $self;
25    $self->SUPER::new(@_);
26    $self->write($PROMPT);
27    return $self;
28}
29
30sub max_idle_time { 3600 }    # one hour
31
32sub process_line {
33    my $self = shift;
34    my $line = shift || return;
35    if ($::DEBUG > 1) { print "$$:" . ($self + 0) . "C($self->{mode}): $line"; }
36    local $SIG{ALRM} = sub {
37        my ($pkg, $file, $line) = caller();
38        die "ALARM: $pkg, $file, $line";
39    };
40    my $prev = alarm(2);      # must process a command in < 2 seconds
41    my $resp = eval { $self->_process_line($line) };
42    alarm($prev);
43    if ($@) {
44        print STDERR "Error: $@\n";
45    }
46    return $resp || '';
47}
48
49sub respond {
50    my $self = shift;
51    my (@messages) = @_;
52    while (my $msg = shift @messages) {
53        $self->write("$msg\r\n");
54    }
55    return;
56}
57
58sub fault {
59    my $self = shift;
60    my ($msg) = shift || "program fault - command not performed";
61    print STDERR "$0 [$$]: $msg ($!)\n";
62    $self->respond("Error - " . $msg);
63    return $PROMPT;
64}
65
66sub _process_line {
67    my $self = shift;
68    my $line = shift;
69
70    $line =~ s/\r?\n//;
71    my ($cmd, @params) = split(/ +/, $line);
72    my $meth = "cmd_" . lc($cmd);
73    if (my $lookup = $self->can($meth)) {
74        my $resp = eval { $lookup->($self, @params); };
75        if ($@) {
76            my $error = $@;
77            chomp($error);
78            Qpsmtpd->log(LOGERROR, "Command Error: $error");
79            return $self->fault("command '$cmd' failed unexpectedly");
80        }
81        return "$resp\n$PROMPT";
82    }
83    else {
84        # No such method - i.e. unrecognized command
85        return $self->fault("command '$cmd' unrecognised");
86    }
87}
88
89my %helptext = (
90    help   => "HELP [CMD] - Get help on all commands or a specific command",
91    status => "STATUS - Returns status information about current connections",
92    list =>
93"LIST [LIMIT] - List the connections, specify limit or negative limit to shrink list",
94    kill =>
95"KILL (\$IP | \$REF) - Disconnect all connections from \$IP or connection reference \$REF",
96    pause    => "PAUSE - Stop accepting new connections",
97    continue => "CONTINUE - Resume accepting connections",
98    reload   => "RELOAD - Reload all plugins and config",
99    quit     => "QUIT - Exit the config server",
100);
101
102sub cmd_help {
103    my $self = shift;
104    my ($subcmd) = @_;
105
106    $subcmd ||= 'help';
107    $subcmd = lc($subcmd);
108
109    if ($subcmd eq 'help') {
110        my $txt = join("\n",
111                       map { substr($_, 0, index($_, "-")) }
112                       sort values(%helptext));
113        return "Available Commands:\n\n$txt\n";
114    }
115    my $txt = $helptext{$subcmd}
116      || "Unrecognised help option. Try 'help' for a full list.";
117    return "$txt\n";
118}
119
120sub cmd_quit {
121    my $self = shift;
122    $self->close;
123}
124
125sub cmd_shutdown {
126    exit;
127}
128
129sub cmd_pause {
130    my $self = shift;
131
132    my $other_fds = $self->OtherFds;
133
134    $self->{other_fds} = {%$other_fds};
135    %$other_fds = ();
136    return "PAUSED";
137}
138
139sub cmd_continue {
140    my $self = shift;
141
142    my $other_fds = $self->{other_fds};
143
144    $self->OtherFds(%$other_fds);
145    %$other_fds = ();
146    return "UNPAUSED";
147}
148
149sub cmd_status {
150    my $self = shift;
151
152    # Status should show:
153    #  - Total time running
154    #  - Total number of mails received
155    #  - Total number of mails rejected (5xx)
156    #  - Total number of mails tempfailed (5xx)
157    #  - Avg number of mails/minute
158    #  - Number of current connections
159    #  - Number of outstanding DNS queries
160
161    my $output = "Current Status as of " . gmtime() . " GMT\n\n";
162
163    if (defined &Qpsmtpd::Plugin::stats::get_stats) {
164
165        # Stats plugin is loaded
166        $output .= Qpsmtpd::Plugin::stats->get_stats;
167    }
168
169    my $descriptors = Danga::Socket->DescriptorMap;
170
171    my $current_connections = 0;
172    my $current_dns         = 0;
173    foreach my $fd (keys %$descriptors) {
174        my $pob = $descriptors->{$fd};
175        if ($pob->isa("Qpsmtpd::PollServer")) {
176            $current_connections++;
177        }
178        elsif ($pob->isa("ParaDNS::Resolver")) {
179            $current_dns = $pob->pending;
180        }
181    }
182
183    $output .= "Curr Connections: $current_connections / $::MAXconn\n"
184      . "Curr DNS Queries: $current_dns";
185
186    return $output;
187}
188
189sub cmd_list {
190    my $self = shift;
191    my ($count) = @_;
192
193    my $descriptors = Danga::Socket->DescriptorMap;
194
195    my $list =
196        "Current"
197      . ($count ? (($count > 0) ? " Oldest $count" : " Newest " . -$count) : "")
198      . " Connections: \n\n";
199    my @all;
200    foreach my $fd (keys %$descriptors) {
201        my $pob = $descriptors->{$fd};
202        if ($pob->isa("Qpsmtpd::PollServer")) {
203            next unless $pob->connection->remote_ip;  # haven't even started yet
204            push @all,
205              [
206                $pob + 0,                      $pob->connection->remote_ip,
207                $pob->connection->remote_host, $pob->uptime
208              ];
209        }
210    }
211
212    @all = sort { $a->[3] <=> $b->[3] } @all;
213    if ($count) {
214        if ($count > 0) {
215            @all = @all[$#all - ($count - 1) .. $#all];
216        }
217        else {
218            @all = @all[0 .. (abs($count) - 1)];
219        }
220    }
221    foreach my $item (@all) {
222        $list .= sprintf("%x : %s [%s] Connected %0.2fs\n",
223                         map { defined() ? $_ : '' } @$item);
224    }
225
226    return $list;
227}
228
229sub cmd_kill {
230    my $self = shift;
231    my ($match) = @_;
232
233    return "SYNTAX: KILL (\$IP | \$REF)\n" unless $match;
234
235    my $descriptors = Danga::Socket->DescriptorMap;
236
237    my $killed = 0;
238    my $is_ip = (index($match, '.') >= 0);
239    foreach my $fd (keys %$descriptors) {
240        my $pob = $descriptors->{$fd};
241        if ($pob->isa("Qpsmtpd::PollServer")) {
242            if ($is_ip) {
243                next
244                  unless $pob->connection->remote_ip; # haven't even started yet
245                if ($pob->connection->remote_ip eq $match) {
246                    $pob->write(
247"550 Your connection has been killed by an administrator\r\n");
248                    $pob->disconnect;
249                    $killed++;
250                }
251            }
252            else {
253                # match by ID
254                if ($pob + 0 == hex($match)) {
255                    $pob->write(
256"550 Your connection has been killed by an administrator\r\n");
257                    $pob->disconnect;
258                    $killed++;
259                }
260            }
261        }
262    }
263
264    return "Killed $killed connection" . ($killed > 1 ? "s" : "") . "\n";
265}
266
267sub cmd_dump {
268    my $self = shift;
269    my ($ref) = @_;
270
271    return "SYNTAX: DUMP \$REF\n" unless $ref;
272    require Data::Dumper;
273    $Data::Dumper::Indent = 1;
274
275    my $descriptors = Danga::Socket->DescriptorMap;
276    foreach my $fd (keys %$descriptors) {
277        my $pob = $descriptors->{$fd};
278        if ($pob->isa("Qpsmtpd::PollServer")) {
279            if ($pob + 0 == hex($ref)) {
280                return Data::Dumper::Dumper($pob);
281            }
282        }
283    }
284
285    return "Unable to find the connection: $ref. Try the LIST command\n";
286}
287
2881;
289__END__
290
291=head1 NAME
292
293Qpsmtpd::ConfigServer - a configuration server for qpsmtpd
294
295=head1 DESCRIPTION
296
297When qpsmtpd runs in multiplex mode it also provides a config server that you
298can connect to. This allows you to view current connection statistics and other
299gumph that you probably don't care about.
300
301=cut
302