1 |
package Discover; # $Id$ |
2 |
|
3 |
################################################################################ |
4 |
# Part of Mageia Online # |
5 |
# Online service discovery library: # |
6 |
# - autodetects nameservers and domains, # |
7 |
# - and checks for DNS-declared Online service, # |
8 |
# # |
9 |
# Check http://www.dns-sd.org/ # |
10 |
# # |
11 |
# Copyright (C) 2005 Mandriva # |
12 |
# # |
13 |
# Romain d'Alverny <rdalverny at mandriva dot com> # |
14 |
# # |
15 |
# This program is free software; you can redistribute it and/or modify # |
16 |
# it under the terms of the GNU General Public License Version 2 as # |
17 |
# published by the Free Software Foundation. # |
18 |
# # |
19 |
# This program is distributed in the hope that it will be useful, # |
20 |
# but WITHOUT ANY WARRANTY; without even the implied warranty of # |
21 |
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # |
22 |
# GNU General Public License for more details. # |
23 |
# # |
24 |
# You should have received a copy of the GNU General Public License # |
25 |
# along with this program; if not, write to the Free Software # |
26 |
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. # |
27 |
################################################################################ |
28 |
|
29 |
use strict; |
30 |
use Net::DNS; |
31 |
use Data::Dumper; |
32 |
use MDK::Common; |
33 |
use Config::Auto; # CPAN Module. Seems not to be part of Mageia packages yet. |
34 |
use Switch; |
35 |
|
36 |
use Log::Agent; # use settings from main file |
37 |
|
38 |
my $VERSION = '0.01'; |
39 |
|
40 |
# |
41 |
sub new { |
42 |
my $self = {}; |
43 |
bless $self, "Discover"; |
44 |
logsay "DNS Service Discovery module $VERSION"; |
45 |
return $self; |
46 |
} |
47 |
|
48 |
# |
49 |
sub init { |
50 |
my $this = shift; |
51 |
$this->{domainname} = ''; |
52 |
$this->{zone} = ''; |
53 |
$this->{service} = ''; |
54 |
$this->{nameserver} = ''; |
55 |
$this->{instance} = ''; |
56 |
} |
57 |
|
58 |
# |
59 |
sub commify_series { |
60 |
(@_ == 0) ? '' : |
61 |
(@_ == 1) ? $_[0] : |
62 |
(@_ == 2) ? join(" and ", @_) : |
63 |
join(", ", @_[0 .. ($#_-1)], "and $_[-1]"); |
64 |
} |
65 |
|
66 |
# |
67 |
sub search { |
68 |
my $this = shift; |
69 |
|
70 |
logsay "searching for a locally declared Mageia Online service"; |
71 |
|
72 |
my $resolv = Config::Auto::parse('/etc/resolv.conf'); |
73 |
my $servicetype = '_mdvonline._http._tcp.bonjour.'; |
74 |
my (@domains, @services); |
75 |
|
76 |
! defined $resolv and logerr "No config found from /etc/resolv.conf.", return 0; |
77 |
|
78 |
defined $resolv->{domain} and @domains = $resolv->{domain}; |
79 |
defined $resolv->{search} and push @domains, @{$resolv->{search}}; |
80 |
|
81 |
@domains = uniq(@domains); |
82 |
for my $domain ( @domains ) { |
83 |
push( @services, $servicetype . $domain ); |
84 |
} |
85 |
logsay "found domains: " . commify_series(@domains); |
86 |
logsay "found nameservers: " . commify_series(@{$resolv->{nameserver}}); |
87 |
|
88 |
# for dev. |
89 |
@{$resolv->{nameserver}} = qw(localhost); |
90 |
|
91 |
# will try each nameserver listed |
92 |
foreach my $ns ( @{$resolv->{nameserver}} ) { |
93 |
# for each possible service/domain |
94 |
foreach my $serv ( @services ) { |
95 |
logsay "trying ns $ns, service $serv"; |
96 |
my $ret = $this->find_service( $ns, $serv ); |
97 |
|
98 |
$ret and logsay "service found", return $ret; |
99 |
} |
100 |
} |
101 |
logwarn "no dns-declared service found"; |
102 |
return 0; |
103 |
}; |
104 |
|
105 |
# NOTE. here it is suppposed that for a given Service instance (PTR), |
106 |
# there is only _one_ SRV record and _one_ TXT record matches. |
107 |
# If there are more, no particular behaviour is expected as for now. |
108 |
# NOTE. replace this code with a wrapper around dig? |
109 |
sub find_service { |
110 |
my ($this, $nameserver, $service) = @_; |
111 |
my $return; |
112 |
|
113 |
# lower the values to make it faster to give up |
114 |
my $retry = 2; # default is 120 |
115 |
my $retrans = 2; # default is 5 |
116 |
logsay "retry rate is set to $retry; retrans rate is set to $retrans"; |
117 |
my $res = Net::DNS::Resolver->new( |
118 |
retry => $retry, |
119 |
retrans => $retrans, |
120 |
#debug => 1 |
121 |
); |
122 |
|
123 |
# TODO make sure the nameserver answers, or set a timeout. |
124 |
$res->nameservers( $nameserver ); |
125 |
|
126 |
# 1. search for any PTR record matching the service name |
127 |
logsay "ns $nameserver: PTR $service ?"; |
128 |
my $query = $res->query( $service, 'PTR' ); |
129 |
my $instanceName; |
130 |
if( $query ) { |
131 |
# TODO better parsing of the struct |
132 |
my $rr = $query->{answer}[0]; |
133 |
|
134 |
! defined $rr and logerr "not expected format found in PTR record.", return 0; |
135 |
|
136 |
$instanceName = $rr->ptrdname; |
137 |
$instanceName =~ s/\\032/ /g; |
138 |
logsay "found '$instanceName'"; |
139 |
$this->{serviceInstanceName} = $instanceName; |
140 |
} |
141 |
else { |
142 |
logwarn "no PTR record found."; |
143 |
logwarn $res->errorstring; |
144 |
return 0; |
145 |
} |
146 |
|
147 |
# 2. for each service instance found, look up for SRV/TXT records. |
148 |
logsay "ns $nameserver: SRV '$instanceName' ?"; |
149 |
$query = $res->query( $instanceName, 'SRV' ); |
150 |
if( $query ) { |
151 |
my $rr = $query->{answer}[0]; |
152 |
logsay "yes: " . $rr->target . ":" . $rr->port; |
153 |
$this->{server} = { priority => $rr->priority, weight => $rr->weight, |
154 |
port => $rr->port, host => $rr->target }; |
155 |
$return->{server} = $this->{server}; |
156 |
} |
157 |
else { |
158 |
logwarn "no matching SRV record found."; |
159 |
logwarn $res->errorstring; |
160 |
return 0; |
161 |
} |
162 |
|
163 |
logsay "ns $nameserver: TXT '$instanceName' ?"; |
164 |
$query = $res->query( $instanceName, 'TXT' ); |
165 |
if( $query ) { |
166 |
my $rr = $query->{answer}[0]; |
167 |
logsay "yes: " . join(', ', $rr->char_str_list() ); |
168 |
$return->{config} = $this->parse_txt_config( $rr->char_str_list() ); |
169 |
|
170 |
! defined $return->{config} and logwarn "But no config found.", return 0; |
171 |
} |
172 |
else { |
173 |
logwarn "No matching TXT record found."; |
174 |
logwarn $res->errorstring; |
175 |
return 0; |
176 |
} |
177 |
return $return; |
178 |
}; |
179 |
|
180 |
# translate the txt record* into a properly formatted hash. |
181 |
# |
182 |
# * consists of a list of 'key=value' strings; handled strings are: |
183 |
# txtvers=n (integer) |
184 |
# conf=a,b (string: name of the config,integer: set time) |
185 |
# update=p (string: path to update server) |
186 |
# service=s (string: path to service resource) |
187 |
# user=s (string: default user name to use) |
188 |
# pass=s (string: default password to use) |
189 |
# auto=b (TRUE|FALSE: whether to act automatically or not) |
190 |
# mobile=b (TRUE|FALSE: whether to act as a mobile agent or not) |
191 |
# |
192 |
sub parse_txt_config { |
193 |
my ($this, @config) = @_; |
194 |
my $retconfig; |
195 |
|
196 |
foreach my $line (@config) { |
197 |
# TODO match these with a regexp |
198 |
my @line = split('=', $line); |
199 |
my $key = shift(@line); |
200 |
my $value = join('=', @line); |
201 |
switch ($key) { |
202 |
case 'txtvers' { $retconfig->{txtvers} = $value; } |
203 |
case 'conf' { |
204 |
my @co = split(',', $value); |
205 |
$retconfig->{conf} = { 'name' => $co[0], 'time' => $co[1] }; |
206 |
} |
207 |
case 'update' { $retconfig->{update} = $value; } |
208 |
case 'service' { $retconfig->{service} = $value; } |
209 |
case 'user' { $retconfig->{user} = $value; } |
210 |
case 'pass' { $retconfig->{pass} = $value; } |
211 |
case 'auto' { $retconfig->{auto} = 1; } |
212 |
case 'mobile' { $retconfig->{mobile} = 1; } |
213 |
else {} |
214 |
} |
215 |
} |
216 |
$this->{config} = $retconfig; |
217 |
return $retconfig; |
218 |
}; |
219 |
|
220 |
1; |