#!/usr/bin/perl
# :vim filetype=perl
use strict;
use warnings;
$|++;
# sub POE::Kernel::TRACE_EVENTS () { 1 }
use Carp;
$SIG{__DIE__} = sub { Carp::confess( @_ ) };
use POE;
use POE::Wheel::Multicast;
use POE::Filter::MDNS;
use Net::DAAP::Server;
use Net::DNS::Packet;
use Net::IP;
use Data::Dumper;
sub SHARENAME () { "yuumi's music" }
sub HOSTNAME () { "yuumi" }
sub IPADDR () { "10.8.0.101" }
sub PORT () { "3692" }
sub CPU () { "Dell Inspiron 8200" }
sub OS () { "Debian 3.1 Linux 2.6.13" }
my $path = shift;
POE::Session->create(
package_states => [
main => [qw(
_start
receive
receive_question
sendshit
do_announcements
rendezvous_publish
rendezvous_unpublish
sigint
shutdown
go
)],
],
heap => {
publish => Net::DNS::RRPool->new(),
cache => Net::DNS::RRPool->new(),
announce => Net::DNS::RRPool->new(),
},
args => [
$path,
],
options => {
# trace => 1,
debug => 1,
},
);
sub _start {
my ($kernel, $path) = @_[KERNEL, ARG0];
$kernel->alias_set( 'mdns' );
$kernel->yield( 'go' );
}
sub go {
my ($kernel, $heap) = @_[KERNEL, HEAP];
my $wheel = POE::Wheel::Multicast->new(
LocalAddr => '0.0.0.0',
LocalPort => 5353,
DefaultAddr => '224.0.0.251',
DefaultPort => 5353,
InputEvent => 'receive',
Filter => POE::Filter::MDNS->new(),
);
$wheel->mcast_loopback(1);
$wheel->mcast_ttl(255);
$wheel->mcast_add( '224.0.0.251' );
$heap->{wheel} = $wheel;
$heap->{server} = Net::DAAP::Server->new(
path => $path,
port => PORT,
name => SHARENAME,
debug => 1,
);
$kernel->sig( 'INT', 'sigint' );
$kernel->yield( 'sendshit' );
}
sub sigint {
my ($kernel, $heap) = @_[KERNEL, HEAP];
my $service = $heap->{server}->service;
$service->stop();
delete( $heap->{server} );
print "SIGINT Service: $service\n";
$kernel->sig_handled();
$kernel->delay( 'shutdown', 5 );
}
sub shutdown {
$_[KERNEL]->sig( 'INT' );
$SIG{ALRM} = sub { die "Emergency cleanup" };
alarm 10;
}
sub sendshit {
my ($kernel, $heap) = @_[KERNEL, HEAP];
my @rrs = (
rr(
name => HOSTNAME . '.local',
ttl => 7200,
class => 'IN',
type => 'A',
address => IPADDR,
unique => 1,
),
rr(
name => HOSTNAME . '.local',
ttl => 7200,
class => 'IN',
type => 'HINFO',
cpu => CPU,
os => OS,
unique => 1,
),
rr(
name => Net::IP->new(IPADDR)->reverse_ip,
ttl => 7200,
class => 'IN',
type => 'PTR',
ptrdname => HOSTNAME . '.local',
unique => 1,
),
);
$heap->{publish}->add( @rrs );
$heap->{announce}->add( @rrs );
$kernel->delay_add( 'do_announcements', .5 );
}
sub rendezvous_unpublish {
my ($kernel, $heap, $rrs) = @_[KERNEL, HEAP, ARG0];
my $publish = $heap->{publish};
my $announce = $heap->{announce};
print "Unpublishing " . @$rrs . " records.\n";
foreach my $rr (@$rrs) {
printf "\t%s\n", $rr->string;
$publish->remove( $rr );
$rr->{ttl} = 0;
$announce->add( $rr );
}
$kernel->delay_add( 'do_announcements', .5 );
}
sub rendezvous_publish {
my ($kernel, $heap, %args) = @_[KERNEL, HEAP, ARG0..$#_];
# my %args = @_;
my $type = $args{type} or die;
my $name = $args{name} or die;
my $txt = $args{txt} or die;
my $port = $args{port} or die;
my @rrs = (
rr(
name => "${name}.${type}.local",
ttl => 7200,
class => 'IN',
type => 'SRV',
priority => 0,
weight => 0,
port => $port,
target => HOSTNAME . '.local',
unique => 1,
),
rr(
name => "${name}.${type}.local",
ttl => 7200,
class => 'IN',
type => 'TXT',
char_str_list => [split( /\x{1}/, $txt )],
unique => 1,
),
rr(
name => "${type}.local",
ttl => 7200,
class => 'IN',
type => 'PTR',
ptrdname => "${name}.${type}.local",
),
rr(
name => '_services._dns-sd._udp.local',
ttl => 7200,
class => 'IN',
type => 'PTR',
ptrdname => "${type}.local",
),
);
my $publish = $heap->{publish};
my $announce = $heap->{announce};
foreach my $rr (@rrs) {
$publish->add( $rr );
$announce->add( $rr );
}
$kernel->delay_add( 'do_announcements', .5 );
return [@rrs];
}
sub do_announcements {
my ($kernel, $heap) = @_[KERNEL, HEAP];
$kernel->delay( 'do_announcements' ); # remove all pending runs, emptying the queue.
my @records = $heap->{announce}->get_all;
print "Announcing " . @records . " records.\n";
return unless (@records);
printf "\t%s\n", $_->string
foreach @records;
my $packet = Net::DNS::Packet->new();
$packet->pop( 'question' );
my $header = $packet->header;
$header->rd(0);
$header->aa(1);
$header->id(0);
$header->qr(1);
$header->rd(0);
$header->ra(0);
foreach my $rr (@records) {
$packet->push( answer => $rr );
}
my $bytes = $heap->{wheel}->put( { payload => [ $packet ] } );
$heap->{announce} = Net::DNS::RRPool->new();
}
sub receive {
my ($kernel, $heap, $input, $wheelid) = @_[KERNEL, HEAP, ARG0, ARG1];
my $packets = $input->{payload};
my $peer_addr = $input->{addr};
my $peer_port = $input->{port};
my $bytes = $input->{bytes};
foreach my $packet (@$packets) {
if ($packet->header->qr == 0) {
$kernel->yield( 'receive_question', $packet );
}
}
}
sub receive_question {
my ($kernel, $heap, $packet) = @_[KERNEL, HEAP, ARG0];
my $publish = $heap->{publish};
my $announce = $heap->{announce};
my $pre = Net::DNS::RRPool->new( $packet->pre );
#my $authority = Net::DNS::RRPool->new( $packet->authority );
#my $additional = Net::DNS::RRPool->new( $packet->additional );
my $go = 0;
foreach my $question ($packet->question) {
printf "Question: %s\n", $question->string;
my @matches = $publish->question( $question );
unless (@matches) {
print "\tNo answers found\n";
next;
}
foreach my $match (@matches) {
if ($pre->lookup( $match )) {
printf "\tFound pre: %s, not sending.\n", $match->string;
}
elsif ($announce->lookup( $match )) {
printf "\tFound answer: %s, not sending.\n", $match->string;
}
else {
printf "\tSending: %s\n", $match->string;
$announce->add( $match );
$go = 1;
}
}
}
$kernel->delay_add( 'do_announcements', .1 ) if $go;
}
POE::Kernel->run();
sub rr {
my %args = @_;
my $name = $args{'name'};
my $unique = delete $args{'unique'};
my $class = Net::DNS::classesbyname( delete $args{'class'} );
$class |= ($unique ? 0x8000 : 0x0000);
my $rr = Net::DNS::RR->new(
%args,
class => Net::DNS::classesbyval( $class ),
);
return $rr;
}
package Net::MDNS::RR;
sub new {
my $objclass = shift;
my %args = @_;
my $name = $args{'name'};
my $unique = delete $args{'unique'};
my $class = delete $args{'class'};
my $rrclass = Net::DNS::classesbyname( $class );
$rrclass &= 0x7FFF;
$rrclass |= ($unique ? 0x8000 : 0x0000);
my $rr = Net::DNS::RR->new(
%args,
class => Net::DNS::classesbyval( $rrclass ),
);
my $self = bless {
rr => $rr,
class => $class,
unique => $unique,
}, (ref $objclass || $objclass);
return $self;
}
sub unique {
my $self = shift;
if (my $unique = shift) {
$self->{unique} = $unique;
my $rrclass = Net::DNS::classesbyname( $self->{class} );
$rrclass &= 0x7FFF;
$rrclass |= ($unique ? 0x8000 : 0x0000);
$self->{rr}->class => Net::DNS::classesbyval( $rrclass );
}
return $self->{unique};
}
sub class {
my $self = shift;
if (my $class = shift) {
$self->{class} = $class;
my $rrclass = Net::DNS::classesbyname( $self->{class} );
my $unique = $self->{unique};
$rrclass &= 0x7FFF;
$rrclass |= ($unique ? 0x8000 : 0x0000);
$self->{rr}->class => Net::DNS::classesbyval( $rrclass );
}
return $self->{class};
}
sub string {
my $self = shift;
my $rr = $self->{rr};
return join("\t",
"$rr->{'name'}.",
$rr->{'ttl'},
$self->{'class'},
$rr->{'type'},
(defined $rr->rdatastr and length $rr->rdatastr) ? $rr->rdatastr : '; no data',
$self->{unique} ? '; unique' : '; multiple',
);
}
sub isa {
my $self = shift;
die( "ISA not implemented yet" );
}
our $AUTOLOAD;
sub AUTOLOAD {
my $method = $AUTOLOAD;
$method =~ s/^.+:://;
my $self = shift;
my $rr = $self->{rr};
if (my $sub = $rr->can( $method )) {
$sub->( $rr, @_ );
}
else {
die "AUGH!";
}
}
package Net::Rendezvous::Publish::Backend::POE;
use POE;
use strict;
use warnings;
use Data::Dumper;
BEGIN {
$INC{'Net/Rendezvous/Publish/Backend/POE.pm'} = 1;
}
sub new {
my $class = shift;
my $self = bless {}, ( ref $class || $class );
return $self;
}
sub publish {
my $self = shift;
my %args = @_;
return $poe_kernel->call( 'mdns', 'rendezvous_publish', %args );
}
sub publish_stop {
my $self = shift;
my $rrs = shift;
$poe_kernel->call( 'mdns', 'rendezvous_unpublish', $rrs );
# die( "Not implemented yet: @_\n" );
}
sub step {
die( "POE doesn't need stepping, all operations are cooperative\n" );
}
1;
package Net::DNS::RRPool;
use strict;
use warnings;
use Net::DNS::Packet;
sub new {
my $class = shift;
my $self = bless [@_], (ref $class or $class);
return $self;
}
sub add {
my $self = shift;
push @$self, @_;
}
sub remove {
my $self = shift;
my $rr = shift;
@$self = map { $rr != $self } @$self;
return $rr;
}
sub question {
my $self = shift;
my $query = shift;
my $qname = $query->qname;
my $qtype = $query->qtype;
my $qclass = Net::DNS::classesbyname( $query->qclass ) & 0x7F;
my @nameanswers = grep {
$qname eq $_->name and
$qclass == (Net::DNS::classesbyname( $_->class ) & 0x7F)
} @$self;
if ($qtype eq 'ANY') {
return @nameanswers;
}
else {
return grep { $qtype eq $_->type } @nameanswers;
}
}
sub lookup {
my $self = shift;
my $query = shift;
return grep {
$query->name eq $_->name and
$query->type eq $_->type and
(Net::DNS::classesbyname( $query->class ) & 0x7F) ==
(Net::DNS::classesbyname( $_->class ) & 0x7F)
} @$self;
}
sub get_all {
my $self = shift;
return @$self;
}
