You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
677 lines
18 KiB
677 lines
18 KiB
5 years ago
|
#!/usr/bin/perl
|
||
|
|
||
|
use strict;
|
||
|
use warnings;
|
||
|
use utf8;
|
||
|
use feature 'unicode_strings';
|
||
|
|
||
|
use DBI;
|
||
|
use Encode;
|
||
|
use Net::SIP;
|
||
|
use Net::SIP::Util qw(laddr4dst INETSOCK ip_sockaddr2parts sip_uri2parts);
|
||
|
use Socket;
|
||
|
use Text::Unidecode;
|
||
|
use URI::Escape;
|
||
|
|
||
|
my $dbfile = '/tmp/messages.db'; # TODO
|
||
|
|
||
|
my $dbh = DBI->connect("DBI:SQLite:$dbfile", undef, undef, { PrintError => 0, RaiseError => 1, sqlite_unicode => 1 });
|
||
|
$dbh->do('CREATE TABLE IF NOT EXISTS messages(id INTEGER PRIMARY KEY AUTOINCREMENT, r INT NOT NULL DEFAULT 0, f TEXT NOT NULL, t TEXT NOT NULL, m TEXT NOT NULL)');
|
||
|
$dbh->do('CREATE INDEX IF NOT EXISTS idx ON messages(r, t)');
|
||
|
|
||
|
my $mlsnikfile = '/opt/ksp/mlsnik.db';
|
||
|
my $mlsnik_dbh = DBI->connect("DBI:SQLite:$mlsnikfile", undef, undef, { PrintError => 0, RaiseError => 1, sqlite_unicode => 1 });
|
||
|
$mlsnik_dbh->do('CREATE TABLE IF NOT EXISTS nakup(id INTEGER PRIMARY KEY AUTOINCREMENT, meno TEXT NOT NULL, tovar TEXT NOT NULL, cena INT NOT NULL)');
|
||
|
$mlsnik_dbh->do('CREATE INDEX IF NOT EXISTS idx ON nakup(meno)');
|
||
|
|
||
|
sub escape {
|
||
|
my ($text) = @_;
|
||
|
$text =~ s/&/&/g;
|
||
|
$text =~ s/</</g;
|
||
|
$text =~ s/>/>/g;
|
||
|
$text =~ s/\x00//g;
|
||
|
$text =~ s/['"]/_/g; # XML parser does not accept input which contains """ or "'"
|
||
|
$text =~ s/\x86/_/g; # IP Phone firmware crashes when input contains byte 0x86
|
||
|
return $text;
|
||
|
}
|
||
|
|
||
|
sub string {
|
||
|
return escape(encode('ISO-8859-1', $_[0], sub { unidecode(chr($_[0])) }));
|
||
|
}
|
||
|
|
||
|
my @month_names = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
||
|
my @day_names = qw(Sun Mon Tue Wed Thu Fri Sat Sun);
|
||
|
sub sip_date {
|
||
|
my @time = gmtime(time());
|
||
|
return sprintf('%s, %02u %s %04u %02u:%02u:%02u GMT', $day_names[$time[6]], $time[3], $month_names[$time[4]], $time[5] + 1900, $time[2], $time[1], $time[0]);
|
||
|
}
|
||
|
|
||
|
sub send_sip_message {
|
||
|
my ($from_ip, $to, $message) = @_;
|
||
|
|
||
|
# HACK: fill sender
|
||
|
$from_ip =~ /\.([0-9]+)$/;
|
||
|
my $user = $1 // 'message';
|
||
|
my $domain = '172.16.0.1:5062';
|
||
|
$to .= "\@$domain";
|
||
|
|
||
|
my ($host, $recipient) = sip_uri2parts($to);
|
||
|
($host, $recipient) = sip_uri2parts("$to\@$domain") unless defined $host;
|
||
|
return '400 Bad Request' unless defined $host;
|
||
|
|
||
|
my $port = ($host =~ s/:([0-9]+)$//) ? $1 : undef;
|
||
|
|
||
|
my $ip = inet_aton($host);
|
||
|
return "478 Unresolvable destination" unless defined $ip;
|
||
|
my $addr = inet_ntoa($ip);
|
||
|
|
||
|
my $laddr = laddr4dst($addr);
|
||
|
return '478 Unresolvable destination' unless $laddr;
|
||
|
|
||
|
my $sock = INETSOCK(Proto => 'udp', LocalAddr => $laddr, LocalPort => 0);
|
||
|
return "500 Cannot create socket: $!" unless $sock;
|
||
|
|
||
|
my $lport = (ip_sockaddr2parts(getsockname($sock)))[1];
|
||
|
|
||
|
my $leg = Net::SIP::Leg->new(sock => $sock);
|
||
|
return "500 Cannot create leg: $!" unless $leg;
|
||
|
|
||
|
my $ua = Net::SIP::Simple->new(from => "<sip:$user\@$domain>", leg => $leg);
|
||
|
return "500 Cannot create SIP user agent: $!" unless $ua;
|
||
|
|
||
|
my ($stop, $code, $text);
|
||
|
|
||
|
$ua->{endpoint}->new_request(
|
||
|
'MESSAGE',
|
||
|
{ from => $ua->{from}, to => ('<sip:' . (defined $recipient ? "$recipient\@" : '') . $host . (defined $port ? ":$port" : '') . '>') },
|
||
|
sub {
|
||
|
(undef, undef, undef, $code, my $packet) = @_;
|
||
|
(undef, $text) = $packet ? $packet->as_parts : ();
|
||
|
$stop = 1;
|
||
|
},
|
||
|
encode('UTF-8', $message),
|
||
|
uri => ('sip:' . (defined $recipient ? "$recipient\@" : '') . $addr . (defined $port ? ":$port" : '')),
|
||
|
Contact => "<sip:$user\@$laddr:$lport>",
|
||
|
Date => sip_date(),
|
||
|
'Content-Type' => 'text/plain',
|
||
|
'User-Agent' => 'CMXML HTTP Message Sender',
|
||
|
);
|
||
|
|
||
|
$ua->loop(10, \$stop);
|
||
|
$ua->cleanup();
|
||
|
|
||
|
return '408 Request Timeout' unless $stop;
|
||
|
return '400 Bad Request' unless $code and $text;
|
||
|
return "$code $text" unless $code eq '200';
|
||
|
|
||
|
return ''; # no error
|
||
|
}
|
||
|
|
||
|
sub send_message {
|
||
|
my ($env, $service, $args, $current_url, $raw_args) = @_;
|
||
|
|
||
|
my $recipient = $args->{recipient} // '';
|
||
|
my $message = $args->{message} // '';
|
||
|
my $send = $args->{send};
|
||
|
|
||
|
if (not $send) {
|
||
|
$recipient = string($recipient);
|
||
|
$message = string($message);
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
],
|
||
|
[ <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneInput>
|
||
|
<Title>Send a new text message</Title>
|
||
|
<Prompt>Send a new text message</Prompt>
|
||
|
<URL>$current_url?service=$service&send=1</URL>
|
||
|
<InputItem>
|
||
|
<DisplayName>Recipient</DisplayName>
|
||
|
<QueryStringParam>recipient</QueryStringParam>
|
||
|
<InputFlags>T</InputFlags>
|
||
|
<DefaultValue>$recipient</DefaultValue>
|
||
|
</InputItem>
|
||
|
<InputItem>
|
||
|
<DisplayName>Message</DisplayName>
|
||
|
<QueryStringParam>message</QueryStringParam>
|
||
|
<InputFlags></InputFlags>
|
||
|
<DefaultValue>$message</DefaultValue>
|
||
|
</InputItem>
|
||
|
</CiscoIPPhoneInput>
|
||
|
EOD
|
||
|
]
|
||
|
];
|
||
|
}
|
||
|
|
||
|
my $error = '';
|
||
|
my $timeout = 0;
|
||
|
|
||
|
if (not length $recipient) {
|
||
|
$error = "Recipient was not specified";
|
||
|
$timeout = 3;
|
||
|
} elsif (not length $message) {
|
||
|
$error = "Text of a message was not specified";
|
||
|
$timeout = 3;
|
||
|
} else {
|
||
|
$error = send_sip_message($env->{REMOTE_ADDR}, $recipient, $message);
|
||
|
}
|
||
|
|
||
|
my $redirect_url = "$current_url?service=$service";
|
||
|
|
||
|
if (length $error) {
|
||
|
$redirect_url .= '&recipient=' . $raw_args->{recipient} if length $recipient;
|
||
|
$redirect_url .= '&message=' . $raw_args->{message} if length $message;
|
||
|
}
|
||
|
|
||
|
my $text = length $error ? string("ERROR: $error") : 'Message was successfully sent';
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
Refresh => "$timeout; url=$redirect_url",
|
||
|
],
|
||
|
[ <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneText>
|
||
|
<Title>Send a new text message</Title>
|
||
|
<Text>$text</Text>
|
||
|
</CiscoIPPhoneText>
|
||
|
EOD
|
||
|
]
|
||
|
];
|
||
|
}
|
||
|
|
||
|
sub read_message {
|
||
|
my ($env, $service, $args, $current_url) = @_;
|
||
|
|
||
|
my $next = $args->{next};
|
||
|
$next = 0 unless $next;
|
||
|
$next = 1 if $next !~ /^[0-9]+$/;
|
||
|
|
||
|
# HACK: get phone number
|
||
|
my $recipient = $env->{REMOTE_ADDR};
|
||
|
$recipient =~ s/.*\.//;
|
||
|
|
||
|
$dbh->do('UPDATE messages SET r=1 WHERE id < ? AND r = 0 AND t = ?', undef, $next, $recipient);
|
||
|
|
||
|
my ($id, $from, $message) = $dbh->selectrow_array('SELECT id, f, m FROM messages WHERE r = 0 AND t = ? ORDER BY id LIMIT 1', undef, $recipient);
|
||
|
|
||
|
# HACK: strip SIP domain
|
||
|
(undef, $from) = sip_uri2parts($from);
|
||
|
|
||
|
$next = $id+1 if defined $id;
|
||
|
|
||
|
my $timeout = defined $id ? 0 : 10;
|
||
|
my $title = defined $id ? string("From: " . $from) : "Waiting for a message...";
|
||
|
my $prompt = defined $id ? "Show next message" : "No more unread text messages";
|
||
|
my $text = defined $id ? string($message) : '';
|
||
|
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
Refresh => "$timeout; url=$current_url?service=$service&next=$next",
|
||
|
],
|
||
|
[ <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneText>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>$prompt</Prompt>
|
||
|
<Text>$text</Text>
|
||
|
</CiscoIPPhoneText>
|
||
|
EOD
|
||
|
]
|
||
|
];
|
||
|
}
|
||
|
|
||
|
my %names;
|
||
|
my %orgs;
|
||
|
my %items;
|
||
|
{
|
||
|
open my $fh, '<:utf8', '/opt/ksp/www/osoby.txt' or die "Cannot open file osoby.txt: $!\n";
|
||
|
%names = map { chomp($_); my $tmp = unidecode(lc $_); $tmp =~ s/[^a-z0-9]+/_/g; ($tmp => $_) } <$fh>;
|
||
|
close $fh;
|
||
|
}
|
||
|
{
|
||
|
open my $fh, '<:utf8', '/opt/ksp/www/orgovia.txt' or die "Cannot open file orgovia.txt: $!\n";
|
||
|
%orgs = map { chomp($_); my $tmp = unidecode(lc $_); $tmp =~ s/[^a-z0-9]+/_/g; ($tmp => $_) } <$fh>;
|
||
|
close $fh;
|
||
|
}
|
||
|
{
|
||
|
# FORMAT: ascii_query_param TAB Unicode name TAB price Kc TAB available count
|
||
|
open my $fh, '<:utf8', '/opt/ksp/www/tovar.txt' or die "Cannot open file tovar.txt: $!\n";
|
||
|
%items = map { chomp($_); my ($param, $name, $price, $count) = split /\t+/; ($param => [$name, $price, $count]) } <$fh>;
|
||
|
close $fh;
|
||
|
}
|
||
|
|
||
|
sub mlsnik {
|
||
|
my ($env, $service, $args, $current_url) = @_;
|
||
|
my $title = string('Mlsník');
|
||
|
|
||
|
my $sub = $args->{sub} // '';
|
||
|
my $name = $args->{name} // '';
|
||
|
my $item = $args->{item} // '';
|
||
|
my $confirm = $args->{confirm};
|
||
|
my $org = $args->{org} // '0';
|
||
|
|
||
|
my $string;
|
||
|
my $refresh;
|
||
|
|
||
|
if ($sub eq 'utrata') {
|
||
|
$title .= string(' - Útrata');
|
||
|
if (not length $name) {
|
||
|
my $prompt = 'Vyberte osobu';
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>$prompt</Prompt>
|
||
|
EOD
|
||
|
if (not $org) {
|
||
|
for my $name (sort { $names{$a} cmp $names{$b} } keys %names) {
|
||
|
my $info = string($names{$name});
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata&org=0&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>Orgovia</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata&org=1</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
$string .= '</CiscoIPPhoneMenu>';
|
||
|
} else {
|
||
|
for my $name (sort { $orgs{$a} cmp $orgs{$b} } keys %orgs) {
|
||
|
my $info = string($orgs{$name});
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata&org=1&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
}
|
||
|
$string .= '</CiscoIPPhoneMenu>';
|
||
|
} else {
|
||
|
$title = string('Útrata pre ' . ($org ? $orgs{$name} : $names{$name}));
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
EOD
|
||
|
my @items = $mlsnik_dbh->selectall_array('SELECT tovar,COUNT(tovar),SUM(cena) FROM nakup WHERE meno = ? GROUP BY tovar', undef, $name);
|
||
|
foreach (@items) {
|
||
|
my ($tovar, $count, $cena) = @{$_};
|
||
|
my $item = $items{$tovar}->[0];
|
||
|
my $info = string("${count}x $item ... $cena Kč");
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata&org=$org&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
my $cena = $mlsnik_dbh->selectrow_array('SELECT SUM(cena) FROM nakup WHERE meno = ?', undef, $name);
|
||
|
$cena ||= 0;
|
||
|
my $info = string("Celkom ... $cena Kč");
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata&org=$org&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
$string .= '</CiscoIPPhoneMenu>';
|
||
|
}
|
||
|
} elsif ($sub eq 'kupa') {
|
||
|
$title .= string(' - Kúpa');
|
||
|
my $prompt = 'Vyberte osobu';
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>$prompt</Prompt>
|
||
|
EOD
|
||
|
if (not length $name) {
|
||
|
if (not $org) {
|
||
|
for my $name (sort { $names{$a} cmp $names{$b} } keys %names) {
|
||
|
my $info = string($names{$name});
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa&org=0&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>Orgovia</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa&org=1</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
} else {
|
||
|
for my $name (sort { $orgs{$a} cmp $orgs{$b} } keys %orgs) {
|
||
|
my $info = string($orgs{$name});
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa&org=1&name=$name</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
}
|
||
|
$string .= '</CiscoIPPhoneMenu>';
|
||
|
} elsif (not length $item) {
|
||
|
$title = string("Kúpiť pre " . ($org ? $orgs{$name} : $names{$name}));
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>Vyberte tovar</Prompt>
|
||
|
EOD
|
||
|
for my $item (sort { $items{$a}->[0] cmp $items{$b}->[0] } keys %items) {
|
||
|
next unless $items{$item}->[2];
|
||
|
my $info = string($items{$item}->[0] . " - " . $items{$item}->[1] . " Kč");
|
||
|
$string .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa&org=$org&name=$name&item=$item</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
$string .= '</CiscoIPPhoneMenu>';
|
||
|
} elsif (not $confirm) {
|
||
|
my $prompt = string("Potvrdiť");
|
||
|
my $info = string(($org ? $orgs{$name} : $names{$name}) . " si zakupuje tovar " . $items{$item}->[0] . " za " . $items{$item}->[1] . " Kč");
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>$prompt</Prompt>
|
||
|
<MenuItem>
|
||
|
<Name>$info</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa&org=$org&name=$name&item=$item&confirm=1</URL>
|
||
|
</MenuItem>
|
||
|
</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
} else {
|
||
|
$mlsnik_dbh->do('INSERT INTO nakup(meno, tovar, cena) VALUES(?, ?, ?)', undef, $name, $item, $items{$item}->[1]);
|
||
|
|
||
|
$refresh = "2; url=$current_url";
|
||
|
my $info = string("Potvrdené");
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneText>
|
||
|
<Title>$title</Title>
|
||
|
<Text>$info</Text>
|
||
|
</CiscoIPPhoneText>
|
||
|
EOD
|
||
|
}
|
||
|
} else {
|
||
|
my $prompt = string('Vyberte možnosť');
|
||
|
my $item1 = string('Kúpiť tovar');
|
||
|
my $item2 = string('Zobraziť útratu');
|
||
|
$string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>$prompt</Prompt>
|
||
|
<MenuItem>
|
||
|
<Name>$item1</Name>
|
||
|
<URL>$current_url?service=$service&sub=kupa</URL>
|
||
|
</MenuItem>
|
||
|
<MenuItem>
|
||
|
<Name>$item2</Name>
|
||
|
<URL>$current_url?service=$service&sub=utrata</URL>
|
||
|
</MenuItem>
|
||
|
</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
}
|
||
|
|
||
|
utf8::downgrade($string); # Workaround bug in PSGI
|
||
|
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
($refresh ? (Refresh => $refresh) : ()),
|
||
|
],
|
||
|
[
|
||
|
$string
|
||
|
]
|
||
|
];
|
||
|
}
|
||
|
|
||
|
sub weather {
|
||
|
my ($env, $service, $args, $current_url) = @_;
|
||
|
my $title = string('Weather Forecast');
|
||
|
my @items;
|
||
|
if (open my $fh, '<:utf8', '/tmp/weather.txt') {
|
||
|
chomp(@items = <$fh>);
|
||
|
close $fh;
|
||
|
} else {
|
||
|
push @items, 'ERROR: Cannot open /tmp/weather.txt';
|
||
|
}
|
||
|
push @items, 'ERROR: /tmp/weather.txt is empty' unless @items;
|
||
|
my $items;
|
||
|
foreach (@items) {
|
||
|
my $text = string($_);
|
||
|
$items .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$text</Name>
|
||
|
<URL>$current_url?service=$service</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
|
||
|
my $string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>Update</Prompt>
|
||
|
$items</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
utf8::downgrade($string); # Workaround bug in PSGI
|
||
|
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
Refresh => "30; url=$current_url?service=$service",
|
||
|
],
|
||
|
[
|
||
|
$string
|
||
|
],
|
||
|
];
|
||
|
}
|
||
|
|
||
|
sub status {
|
||
|
my ($env, $service, $args, $current_url) = @_;
|
||
|
my $title = string('Error status log');
|
||
|
my @items;
|
||
|
if (open my $fh, '<:utf8', '/tmp/error.log') {
|
||
|
chomp(@items = <$fh>);
|
||
|
close $fh;
|
||
|
} else {
|
||
|
push @items, 'ERROR: Cannot open error log';
|
||
|
}
|
||
|
push @items, 'No errors' unless @items;
|
||
|
my $items;
|
||
|
foreach (@items) {
|
||
|
my $text = string($_);
|
||
|
$items .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$text</Name>
|
||
|
<URL>$current_url?service=$service</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
|
||
|
my $string = <<"EOD";
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>$title</Title>
|
||
|
<Prompt>Update</Prompt>
|
||
|
$items</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
utf8::downgrade($string); # Workaround bug in PSGI
|
||
|
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
Refresh => "30; url=$current_url?service=$service",
|
||
|
],
|
||
|
[
|
||
|
$string
|
||
|
],
|
||
|
];
|
||
|
}
|
||
|
|
||
|
my %services = (
|
||
|
send_message => [ 'Send a new text message' => \&send_message, 1 ],
|
||
|
read_message => [ 'Show unread text messages' => \&read_message, 2 ],
|
||
|
mlsnik => [ 'Mlsnik' => \&mlsnik, 3 ],
|
||
|
weather => [ 'Weather Forecast - yr.no' => \&weather, 4 ],
|
||
|
status => [ 'Error status log' => \&status, 5 ],
|
||
|
);
|
||
|
|
||
|
sub wc_paper {
|
||
|
my ($env, $service, $args, $current_url, $raw_args, $line) = @_;
|
||
|
my ($sec, $min, $hour) = localtime();
|
||
|
if ($hour >= 23 || $hour < 7) { # Night time
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
],
|
||
|
[
|
||
|
<<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneText>
|
||
|
<Title>WC: I need a toilet paper</Title>
|
||
|
<Text>This feature is disabled during night time.</Text>
|
||
|
</CiscoIPPhoneText>
|
||
|
EOD
|
||
|
],
|
||
|
];
|
||
|
}
|
||
|
if ($args->{confirm}) {
|
||
|
say STDERR "running: '/opt/ksp/toilet_paper.sh $line &'";
|
||
|
system("sh", "-c", "/opt/ksp/toilet_paper.sh $line &");
|
||
|
}
|
||
|
return [
|
||
|
'200',
|
||
|
[
|
||
|
'Content-Type' => 'text/xml; charset="ISO-8859-1"',
|
||
|
Expires => '-1',
|
||
|
],
|
||
|
[
|
||
|
$args->{confirm} ? <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneText>
|
||
|
<Title>WC: I need a toilet paper</Title>
|
||
|
<Text>Request for a new toilet paper was sent.</Text>
|
||
|
</CiscoIPPhoneText>
|
||
|
EOD
|
||
|
: <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>WC: I need a toilet paper</Title>
|
||
|
<Prompt>Confirm</Prompt>
|
||
|
<MenuItem>
|
||
|
<Name>Is a toilet paper really missing? Requeust for a new one.</Name>
|
||
|
<URL>$current_url?service=$service&confirm=1</URL>
|
||
|
</MenuItem>
|
||
|
</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
],
|
||
|
];
|
||
|
}
|
||
|
|
||
|
sub wc_call_help {
|
||
|
my ($env) = @_;
|
||
|
return [
|
||
|
'200',
|
||
|
[ 'Content-Type' => 'text/xml; charset="ISO-8859-1"' ],
|
||
|
[ <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneDirectory>
|
||
|
<Title>WC: Call for HELP</Title>
|
||
|
<DirectoryEntry>
|
||
|
<Name>Call for HELP</Name>
|
||
|
<Telephone>130</Telephone>
|
||
|
</DirectoryEntry>
|
||
|
</CiscoIPPhoneDirectory>
|
||
|
EOD
|
||
|
]
|
||
|
];
|
||
|
}
|
||
|
|
||
|
my %wc_services = (
|
||
|
wc_paper => [ 'WC: I need a toilet paper' => \&wc_paper ],
|
||
|
wc_call_help => [ 'WC: Call for HELP' => \&wc_call_help ],
|
||
|
);
|
||
|
|
||
|
my $app = sub {
|
||
|
my ($env) = @_;
|
||
|
|
||
|
return [ '405' ] if $env->{REQUEST_METHOD} !~ /^(?:HEAD|GET)$/;
|
||
|
|
||
|
my %raw_args = map { (split /=/, $_, 2)[0,1] } split /&/, $env->{QUERY_STRING} // '';
|
||
|
my %args = map { decode('ISO-8859-1', uri_unescape($_ // '')) } %raw_args;
|
||
|
my $service = $args{service} // '';
|
||
|
|
||
|
my $current_url = $env->{'psgi.url_scheme'} . '://' . $env->{HTTP_HOST} . $env->{PATH_INFO};
|
||
|
|
||
|
# HACK: get line
|
||
|
my $line = $env->{REMOTE_ADDR};
|
||
|
$line =~ s/.*\.//;
|
||
|
|
||
|
return $wc_services{$service}->[1]->($env, $service, \%args, $current_url, \%raw_args, $line) if exists $wc_services{$service};
|
||
|
return $services{$service}->[1]->($env, $service, \%args, $current_url, \%raw_args, $line) if exists $services{$service};
|
||
|
|
||
|
return [ '404' ] if length $service;
|
||
|
|
||
|
my $services = '';
|
||
|
my @services_keys = sort { $services{$a}->[2] cmp $services{$b}->[2] } keys %services;
|
||
|
@services_keys = grep !/mlsnik/, @services_keys unless $line =~ /^(?:36|37|2.|33)$/;
|
||
|
unshift @services_keys, sort { $wc_services{$a}->[0] cmp $wc_services{$b}->[0] } keys %wc_services if $line =~ /^(?:32|44|49)$/;
|
||
|
foreach (@services_keys) {
|
||
|
my $name = string(exists $services{$_} ? $services{$_}->[0] : $wc_services{$_}->[0]);
|
||
|
my $url = "$current_url?service=$_";
|
||
|
$services .= <<"EOD";
|
||
|
<MenuItem>
|
||
|
<Name>$name</Name>
|
||
|
<URL>$url</URL>
|
||
|
</MenuItem>
|
||
|
EOD
|
||
|
}
|
||
|
|
||
|
return [
|
||
|
'200',
|
||
|
[ 'Content-Type' => 'text/xml; charset="ISO-8859-1"' ],
|
||
|
[ <<"EOD"
|
||
|
<?xml version="1.0" encoding="ISO-8859-1"?>
|
||
|
<CiscoIPPhoneMenu>
|
||
|
<Title>Services for line $line</Title>
|
||
|
<Prompt>Select option</Prompt>
|
||
|
$services</CiscoIPPhoneMenu>
|
||
|
EOD
|
||
|
]
|
||
|
];
|
||
|
};
|