summaryrefslogtreecommitdiffstats
path: root/Discover.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Discover.pm')
-rw-r--r--Discover.pm234
1 files changed, 234 insertions, 0 deletions
diff --git a/Discover.pm b/Discover.pm
new file mode 100644
index 00000000..7fc3f110
--- /dev/null
+++ b/Discover.pm
@@ -0,0 +1,234 @@
+package Discover; # $Id$
+
+################################################################################
+# Part of Mandriva Online #
+# Online service discovery library: #
+# - autodetects nameservers and domains, #
+# - and checks for DNS-declared Online service, #
+# #
+# Check http://www.dns-sd.org/ #
+# #
+# Copyright (C) 2005 Mandriva #
+# #
+# Romain d'Alverny <rdalverny at mandriva dot com> #
+# #
+# This program is free software; you can redistribute it and/or modify #
+# it under the terms of the GNU General Public License Version 2 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, write to the Free Software #
+# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. #
+################################################################################
+
+use strict;
+use Net::DNS;
+use Data::Dumper;
+use MDK::Common;
+use Config::Auto; # CPAN Module. Seems not to be part of Mandriva packages yet.
+use Switch;
+
+use Log::Agent; # use settings from main file
+
+my $VERSION = '0.01';
+
+#
+sub new
+{
+ my $self = {};
+ bless $self, "Discover";
+ logsay "DNS Service Discovery module $VERSION";
+ return $self;
+}
+
+#
+sub init
+{
+ my $this = shift;
+ $this->{domainname} = '';
+ $this->{zone} = '';
+ $this->{service} = '';
+ $this->{nameserver} = '';
+ $this->{instance} = '';
+};
+
+#
+sub trim {
+ my $s = shift;
+ $s =~ s/^\s+//;
+ $s =~ s/\s+$//;
+ return $s;
+};
+
+#
+sub commify_series {
+ (@_ == 0) ? '' :
+ (@_ == 1) ? $_[0] :
+ (@_ == 2) ? join(" and ", @_) :
+ join(", ", @_[0 .. ($#_-1)], "and $_[-1]");
+};
+
+#
+sub search {
+ my $this = shift;
+
+ logsay "searching for a locally declared Mandriva Online service";
+
+ my $resolv = Config::Auto::parse('/etc/resolv.conf');
+ my $servicetype = '_mdvonline._http._tcp.bonjour.';
+ my @domains = ();
+ my @services = ();
+
+ if( ! defined $resolv ) {
+ logerr "No config found from /etc/resolv.conf .";
+ return 0;
+ }
+
+ if( defined $resolv->{domain} ) {
+ @domains = $resolv->{domain};
+ }
+ if( defined $resolv->{search} ) {
+ push( @domains, @{$resolv->{search}} );
+ }
+
+ @domains = uniq(@domains);
+ for my $domain ( @domains ) {
+ push( @services, $servicetype . $domain );
+ }
+ logsay "found domains: " . commify_series(@domains);
+ logsay "found nameservers: " . commify_series(@{$resolv->{nameserver}});
+
+ # for dev.
+ @{$resolv->{nameserver}} = qw(localhost);
+
+ # will try each nameserver listed
+ for my $ns ( @{$resolv->{nameserver}} ) {
+ # for each possible service/domain
+ for my $serv ( @services ) {
+ logsay "trying ns $ns, service $serv";
+ my $ret = $this->find_service( $ns, $serv );
+ if( $ret ) {
+ logsay "search is over: a service has been found.";
+ return $ret;
+ }
+ }
+ }
+ logwarn "no dns-declared service found";
+ return 0;
+};
+
+# NOTE. here it is suppposed that for a given Service instance (PTR),
+# there is only _one_ SRV record and _one_ TXT record matches.
+# If there are more, no particular behaviour is expected as for now.
+sub find_service {
+ my ($this, $nameserver, $service) = @_;
+ my $return;
+
+ # lower the values to make it faster to give up
+ my $retry = 2; # default is 120
+ my $retrans = 2; # default is 5
+ logsay "retry rate is set to $retry; retrans rate is set to $retrans";
+ my $res = Net::DNS::Resolver->new(
+ retry => $retry,
+ retrans => $retrans,
+ #debug => 1
+ );
+
+ # TODO make sure the nameserver answers, or set a timeout.
+ $res->nameservers( $nameserver );
+
+ # 1. search for any PTR record matching the service name
+ logsay "ns $nameserver: PTR $service ?";
+ my $query = $res->query( $service, 'PTR' );
+ my $instanceName;
+ if( $query ) {
+ # TODO better parsing of the struct
+ my $rr = $query->{answer}[0];
+ if( ! defined $rr ) {
+ logerr "not expected format found in PTR record.";
+ return 0;
+ }
+ $instanceName = $rr->ptrdname;
+ $instanceName =~ s/\\032/ /g;
+ logsay "found '$instanceName'";
+ $this->{serviceInstanceName} = $instanceName;
+ }
+ else {
+ logwarn "no PTR record found.";
+ logwarn $res->errorstring;
+ return 0;
+ }
+
+ # 2. for each service instance found, look up for SRV/TXT records.
+ logsay "ns $nameserver: SRV '$instanceName' ?";
+ $query = $res->query( $instanceName, 'SRV' );
+ if( $query ) {
+ my $rr = $query->{answer}[0];
+ logsay "yes: " . $rr->target . ":" . $rr->port;
+ $this->{server} = { priority => $rr->priority, weight => $rr->weight,
+ port => $rr->port, host => $rr->target };
+ $return->{server} = $this->{server};
+ }
+ else {
+ logwarn "no matching SRV record found.";
+ logwarn $res->errorstring;
+ return 0;
+ }
+
+ logsay "ns $nameserver: TXT '$instanceName' ?";
+ $query = $res->query( $instanceName, 'TXT' );
+ if( $query ) {
+ my $rr = $query->{answer}[0];
+ logsay "yes: " . join(', ', $rr->char_str_list() );
+ $return->{config} = $this->parse_txt_config( $rr->char_str_list() );
+ if( ! defined $return->{config} ) {
+ logwarn "But no config found.";
+ return 0;
+ }
+ }
+ else {
+ logwarn "No matching TXT record found.";
+ logwarn $res->errorstring;
+ return 0;
+ }
+ return $return;
+};
+
+# translate the txt records into a properly formatted hash.
+sub parse_txt_config {
+ my ($this, @config) = @_;
+ my $retconfig;
+
+ for my $line ( @config ) {
+ my @line = split('=', $line);
+ my $key = $line[0];
+ shift(@line);
+ my $value = join('=', @line);
+ #print "key: $key\tvalue: $value\n";
+ switch( $key ) {
+ case 'txtvers' { $retconfig->{txtvers} = $value; }
+ case 'conf' {
+ my @co = split(',', $value);
+ $retconfig->{conf} = { 'name' => $co[0], 'time' => $co[1] };
+ }
+ case 'update' {
+ my @up = split(',', $value);
+ $retconfig->{update} = { 'type' => $up[0], 'path' => $up[1] };
+ }
+ case 'service' { $retconfig->{service} = $value; }
+ case 'user' { $retconfig->{user} = $value; }
+ case 'pass' { $retconfig->{pass} = $value; }
+ case 'auto' { $retconfig->{auto} = 1; }
+ else {}
+ }
+ }
+ $this->{config} = $retconfig;
+ return $retconfig;
+};
+
+1; \ No newline at end of file