ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Socket.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Socket.pm (file contents):
Revision 1.34 by root, Wed May 28 21:07:07 2008 UTC vs.
Revision 1.39 by root, Thu May 29 00:27:06 2008 UTC

… …
262 262
263# check for broken platforms with extra field in sockaddr structure 263# check for broken platforms with extra field in sockaddr structure
264# kind of a rfc vs. bsd issue, as usual (ok, normally it's a 264# kind of a rfc vs. bsd issue, as usual (ok, normally it's a
265# unix vs. bsd issue, a iso C vs. bsd issue or simply a 265# unix vs. bsd issue, a iso C vs. bsd issue or simply a
266# correctness vs. bsd issue. 266# correctness vs. bsd issue.
267my $pack_family = 0x55 == Socket::sockaddr_family "\x55\x55" 267my $pack_family = (0x55 == Socket::sockaddr_family "\x55\x55")
268 ? "xC" : "S"; 268 ? "xC" : "S";
269 269
270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host 270=item $sa = AnyEvent::Socket::pack_sockaddr $service, $host
271 271
272Pack the given port/host combination into a binary sockaddr 272Pack the given port/host combination into a binary sockaddr
… …
315 if ($af == AF_INET) { 315 if ($af == AF_INET) {
316 Socket::unpack_sockaddr_in $_[0] 316 Socket::unpack_sockaddr_in $_[0]
317 } elsif ($af == AF_INET6) { 317 } elsif ($af == AF_INET6) {
318 unpack "x2 n x4 a16", $_[0] 318 unpack "x2 n x4 a16", $_[0]
319 } elsif ($af == AF_UNIX) { 319 } elsif ($af == AF_UNIX) {
320 ((Socket::unpack_sockaddr_un $_[0]), "unix/") 320 ((Socket::unpack_sockaddr_un $_[0]), pack "S", AF_UNIX)
321 } else { 321 } else {
322 Carp::croak "unpack_sockaddr: unsupported protocol family $af"; 322 Carp::croak "unpack_sockaddr: unsupported protocol family $af";
323 } 323 }
324}
325
326sub _tcp_port($) {
327 $_[0] =~ /^(\d*)$/ and return $1*1;
328
329 (getservbyname $_[0], "tcp")[2]
330 or Carp::croak "$_[0]: service unknown"
331} 324}
332 325
333=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) 326=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
334 327
335Tries to resolve the given nodename and service name into protocol families 328Tries to resolve the given nodename and service name into protocol families
… …
407 ($service, $port) = ($1, $2); 400 ($service, $port) = ($1, $2);
408 } elsif ($service =~ /^\d+$/) { 401 } elsif ($service =~ /^\d+$/) {
409 ($service, $port) = (undef, $service); 402 ($service, $port) = (undef, $service);
410 } else { 403 } else {
411 $port = (getservbyname $service, $proto)[2] 404 $port = (getservbyname $service, $proto)[2]
412 or Carp::croak "$service/$proto: service unknown"; 405 or Carp::croak "$service/$proto: service unknown";
413 } 406 }
414 407
415 my @target = [$node, $port]; 408 my @target = [$node, $port];
416 409
417 # resolve a records / provide sockaddr structures 410 # resolve a records / provide sockaddr structures
… …
444 } 437 }
445 } else { 438 } else {
446 # ipv4 439 # ipv4
447 if ($family != 6) { 440 if ($family != 6) {
448 $cv->begin; 441 $cv->begin;
449 a $node, sub { 442 AnyEvent::DNS::a $node, sub {
450 push @res, [$idx, "ipv4", [AF_INET, $type, $proton, 443 push @res, [$idx, "ipv4", [AF_INET, $type, $proton,
451 pack_sockaddr $port, parse_ipv4 $_]] 444 pack_sockaddr $port, parse_ipv4 $_]]
452 for @_; 445 for @_;
453 $cv->end; 446 $cv->end;
454 }; 447 };
455 } 448 }
456 449
457 # ipv6 450 # ipv6
458 if ($family != 4) { 451 if ($family != 4) {
459 $cv->begin; 452 $cv->begin;
460 aaaa $node, sub { 453 AnyEvent::DNS::aaaa $node, sub {
461 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton, 454 push @res, [$idx, "ipv6", [AF_INET6, $type, $proton,
462 pack_sockaddr $port, parse_ipv6 $_]] 455 pack_sockaddr $port, parse_ipv6 $_]]
463 for @_; 456 for @_;
464 $cv->end; 457 $cv->end;
465 }; 458 };
… …
472 # try srv records, if applicable 465 # try srv records, if applicable
473 if ($node eq "localhost") { 466 if ($node eq "localhost") {
474 @target = (["127.0.0.1", $port], ["::1", $port]); 467 @target = (["127.0.0.1", $port], ["::1", $port]);
475 &$resolve; 468 &$resolve;
476 } elsif (defined $service && !parse_address $node) { 469 } elsif (defined $service && !parse_address $node) {
477 srv $service, $proto, $node, sub { 470 AnyEvent::DNS::srv $service, $proto, $node, sub {
478 my (@srv) = @_; 471 my (@srv) = @_;
479 472
480 # no srv records, continue traditionally 473 # no srv records, continue traditionally
481 @srv 474 @srv
482 or return &$resolve; 475 or return &$resolve;
… …
691 }; 684 };
692 685
693 defined wantarray && guard { %state = () } 686 defined wantarray && guard { %state = () }
694} 687}
695 688
696=item $guard = tcp_server $host, $port, $accept_cb[, $prepare_cb] 689=item $guard = tcp_server $host, $service, $accept_cb[, $prepare_cb]
697 690
698Create and bind a TCP socket to the given host, and port, set the 691Create and bind a stream socket to the given host, and port, set the
699SO_REUSEADDR flag and call C<listen>. 692SO_REUSEADDR flag (if applicable) and call C<listen>. Unlike the name
693implies, this function can also bind on UNIX domain sockets.
700 694
701C<$host> must be an IPv4 or IPv6 address (or C<undef>, in which case it 695For internet sockets, C<$host> must be an IPv4 or IPv6 address (or
702binds either to C<0> or to C<::>, depending on whether IPv4 or IPv6 is the 696C<undef>, in which case it binds either to C<0> or to C<::>, depending
703preferred protocol). 697on whether IPv4 or IPv6 is the preferred protocol, and maybe to both in
698future versions, as applicable).
704 699
705To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6 700To bind to the IPv4 wildcard address, use C<0>, to bind to the IPv6
706wildcard address, use C<::>. 701wildcard address, use C<::>.
707 702
708The port is specified by C<$port>, which must be either a service name or 703The port is specified by C<$service>, which must be either a service name or
709a numeric port number (or C<0> or C<undef>, in which case an ephemeral 704a numeric port number (or C<0> or C<undef>, in which case an ephemeral
710port will be used). 705port will be used).
706
707For UNIX domain sockets, C<$host> must be C<unix/> and C<$service> must be
708the absolute pathname of the socket. This function will try to C<unlink>
709the socket before it tries to bind to it. See SECURITY CONSIDERATIONS,
710below.
711 711
712For each new connection that could be C<accept>ed, call the C<< 712For each new connection that could be C<accept>ed, call the C<<
713$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking 713$accept_cb->($fh, $host, $port) >> with the file handle (in non-blocking
714mode) as first and the peer host and port as second and third arguments 714mode) as first and the peer host and port as second and third arguments
715(see C<tcp_connect> for details). 715(see C<tcp_connect> for details).
… …
727address and port number of the local socket endpoint as second and third 727address and port number of the local socket endpoint as second and third
728arguments. 728arguments.
729 729
730It should return the length of the listen queue (or C<0> for the default). 730It should return the length of the listen queue (or C<0> for the default).
731 731
732Note to IPv6 users: RFC-compliant behaviour for IPv6 sockets listening on
733C<::> is to bind to both IPv6 and IPv4 addresses by default on dual-stack
734hosts. Unfortunately, only GNU/Linux seems to implement this properly, so
735if you want both IPv4 and IPv6 listening sockets you should create the
736IPv6 socket first and then attempt to bind on the IPv4 socket, but ignore
737any C<EADDRINUSE> errors.
738
732Example: bind on some TCP port on the local machine and tell each client 739Example: bind on some TCP port on the local machine and tell each client
733to go away. 740to go away.
734 741
735 tcp_server undef, undef, sub { 742 tcp_server undef, undef, sub {
736 my ($fh, $host, $port) = @_; 743 my ($fh, $host, $port) = @_;
… …
742 }; 749 };
743 750
744=cut 751=cut
745 752
746sub tcp_server($$$;$) { 753sub tcp_server($$$;$) {
747 my ($host, $port, $accept, $prepare) = @_; 754 my ($host, $service, $accept, $prepare) = @_;
748 755
749 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 756 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
750 ? "::" : "0" 757 ? "::" : "0"
751 unless defined $host; 758 unless defined $host;
752 759
753 my $ipn = parse_address $host 760 my $ipn = parse_address $host
754 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; 761 or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address";
755 762
756 my $domain = 4 == length $ipn ? AF_INET : AF_INET6; 763 my $af = address_family $ipn;
757 764
758 my %state; 765 my %state;
759 766
767 # win32 perl is too stupid to get this right :/
768 Carp::croak "tcp_server/socket: address family not supported"
769 if AnyEvent::WIN32 && $af == AF_UNIX;
770
760 socket $state{fh}, $domain, SOCK_STREAM, 0 771 socket $state{fh}, $af, SOCK_STREAM, 0
761 or Carp::croak "socket: $!"; 772 or Carp::croak "tcp_server/socket: $!";
762 773
774 if ($af == AF_INET || $af == AF_INET6) {
763 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 775 setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1
764 or Carp::croak "so_reuseaddr: $!"; 776 or Carp::croak "tcp_server/so_reuseaddr: $!"
777 unless AnyEvent::WIN32; # work around windows bug
765 778
779 unless ($service =~ /^\d*$/) {
780 $service = (getservbyname $service, "tcp")[2]
781 or Carp::croak "$service: service unknown"
782 }
783 } elsif ($af == AF_UNIX) {
784 unlink $service;
785 }
786
766 bind $state{fh}, pack_sockaddr _tcp_port $port, $ipn 787 bind $state{fh}, pack_sockaddr $service, $ipn
767 or Carp::croak "bind: $!"; 788 or Carp::croak "bind: $!";
768 789
769 fh_nonblocking $state{fh}, 1; 790 fh_nonblocking $state{fh}, 1;
770 791
771 my $len; 792 my $len;
772 793
773 if ($prepare) { 794 if ($prepare) {
774 my ($port, $host) = unpack_sockaddr getsockname $state{fh}; 795 my ($service, $host) = unpack_sockaddr getsockname $state{fh};
775 $len = $prepare && $prepare->($state{fh}, format_address $host, $port); 796 $len = $prepare && $prepare->($state{fh}, format_address $host, $service);
776 } 797 }
777 798
778 $len ||= 128; 799 $len ||= 128;
779 800
780 listen $state{fh}, $len 801 listen $state{fh}, $len
… …
782 803
783 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub { 804 $state{aw} = AnyEvent->io (fh => $state{fh}, poll => 'r', cb => sub {
784 # this closure keeps $state alive 805 # this closure keeps $state alive
785 while (my $peer = accept my $fh, $state{fh}) { 806 while (my $peer = accept my $fh, $state{fh}) {
786 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 807 fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
808
787 my ($port, $host) = unpack_sockaddr $peer; 809 my ($service, $host) = unpack_sockaddr $peer;
788 $accept->($fh, format_address $host, $port); 810 $accept->($fh, format_address $host, $service);
789 } 811 }
790 }); 812 });
791 813
792 defined wantarray 814 defined wantarray
793 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency 815 ? guard { %state = () } # clear fh and watcher, which breaks the circular dependency
… …
796 818
7971; 8191;
798 820
799=back 821=back
800 822
823=head1 SECURITY CONSIDERATIONS
824
825This module is quite powerful, with with power comes the ability to abuse
826as well: If you accept "hostnames" and ports from untrusted sources,
827then note that this can be abused to delete files (host=C<unix/>). This
828is not really a problem with this module, however, as blindly accepting
829any address and protocol and trying to bind a server or connect to it is
830harmful in general.
831
801=head1 AUTHOR 832=head1 AUTHOR
802 833
803 Marc Lehmann <schmorp@schmorp.de> 834 Marc Lehmann <schmorp@schmorp.de>
804 http://home.schmorp.de/ 835 http://home.schmorp.de/
805 836

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines