#!/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
		]
	];
};