Telefonní systém kosmické lodi Hipporion ze SKSP2019
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

4 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/</&lt;/g;
$text =~ s/>/&gt;/g;
$text =~ s/\x00//g;
$text =~ s/['"]/_/g; # XML parser does not accept input which contains "&quot;" or "&apos;"
$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&amp;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&amp;sub=utrata&amp;org=0&amp;name=$name</URL>
</MenuItem>
EOD
}
$string .= <<"EOD";
<MenuItem>
<Name>Orgovia</Name>
<URL>$current_url?service=$service&amp;sub=utrata&amp;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&amp;sub=utrata&amp;org=1&amp;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&amp;sub=utrata&amp;org=$org&amp;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&amp;sub=utrata&amp;org=$org&amp;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&amp;sub=kupa&amp;org=0&amp;name=$name</URL>
</MenuItem>
EOD
}
$string .= <<"EOD";
<MenuItem>
<Name>Orgovia</Name>
<URL>$current_url?service=$service&amp;sub=kupa&amp;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&amp;sub=kupa&amp;org=1&amp;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&amp;sub=kupa&amp;org=$org&amp;name=$name&amp;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&amp;sub=kupa&amp;org=$org&amp;name=$name&amp;item=$item&amp;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&amp;sub=kupa</URL>
</MenuItem>
<MenuItem>
<Name>$item2</Name>
<URL>$current_url?service=$service&amp;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&amp;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
]
];
};