#!/usr/bin/perl -w
#
# srv.cgi
# John Simpson <jms1@jms1.net> 2007-08-31
#
# Generates tinydns SRV records for jabber servers
#
# Meant to be called from an AJAX page... http://www.jms1.net/jabberd2/
#
###############################################################################
#
# Copyright (C) 2007 John Simpson.
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License, version 3, as
# published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.
#
###############################################################################

require 5.003 ;
use strict ;

use CGI qw ( :standard ) ;

###############################################################################

sub mkbytes($)
{
	my $n = ( shift || 0 ) ;
	return sprintf "\\%03o\\%03o" , int ( $n / 256 ) , $n % 256 ;
}

sub mklabel($)
{
	my @w = split ( /\./ , ( $_[0] || "" ) ) ;
	my $rv = "" ;

	for my $k ( @w )
	{
		$rv .= sprintf ( "\\%03o%s" , length ( $k ) , $k ) ;
	}

	return "$rv\\000" ;
}

sub bad($)
{
	print "Content-type: text/plain\n\n$_[0]\n" ;
	exit 0 ;
}

###############################################################################
###############################################################################
###############################################################################

my $domain   = ( param ( "domain"   ) || bad "Empty \"Domain\"." ) ;
my $priority = ( param ( "priority" ) || 0 ) ;
my $weight   = ( param ( "weight"   ) || 0 ) ;
my $c2sport  = ( param ( "c2sport"  ) || 0 ) ;
my $s2sport  = ( param ( "s2sport"  ) || 0 ) ;
my $hostname = ( param ( "hostname" ) || bad "Empty \"Hostname\"." ) ;
my $fancy    = ( param ( "fancy"    ) || 0 ) ;

bad "Invalid \"Priority\" value."
	unless ( ( $priority =~ /^\d+$/ ) && ( $priority < 65536 ) ) ;
bad "Invalid \"Weight\" value."
	unless ( ( $weight =~ /^\d+$/ ) && ( $weight < 65536 ) ) ;
bad "Invalid \"C2S Port\" value."
	unless ( ( $c2sport =~ /^\d+$/ ) && ( $c2sport < 65536 ) ) ;
bad "Invalid \"S2S Port\" value."
	unless ( ( $s2sport =~ /^\d+$/ ) && ( $s2sport < 65536 ) ) ;

my $qpriority = mkbytes ( $priority ) ;
my $qweight   = mkbytes ( $weight   ) ;
my $qs2sport  = mkbytes ( $s2sport  ) ;
my $qc2sport  = mkbytes ( $c2sport  ) ;
my $qhostname = mklabel ( $hostname ) ;

my $rv = <<EOF ;
Content-type: text/plain

:_jabber._tcp.$domain:33:$qpriority$qweight$qs2sport$qhostname
:_xmpp-server._tcp.$domain:33:$qpriority$qweight$qs2sport$qhostname
:_xmpp-client._tcp.$domain:33:$qpriority$qweight$qc2sport$qhostname
EOF

if ( $fancy )
{
	$rv = <<EOF ;
Content-type: text/html

:_jabber._tcp.$domain:33:<span class="rb">$qpriority</span><span class="gb">$qweight</span><span class="bb">$qs2sport</span>$qhostname<br>
:_xmpp-server._tcp.$domain:33:<span class="rb">$qpriority</span><span class="gb">$qweight</span><span class="bb">$qs2sport</span>$qhostname<br>
:_xmpp-client._tcp.$domain:33:<span class="rb">$qpriority</span><span class="gb">$qweight</span><span class="bb">$qc2sport</span>$qhostname<br>
EOF
}

print $rv ;
exit 0 ;