File Coverage

blib/lib/AnyEvent/SOCKS/Client.pm
Criterion Covered Total %
statement 26 173 15.0
branch 0 58 0.0
condition 0 17 0.0
subroutine 9 31 29.0
pod 1 8 12.5
total 36 287 12.5


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             AnyEvent::SOCKS::Client - AnyEvent-based SOCKS client!
4              
5             =head1 VERSION
6              
7             Version 0.051
8              
9             =cut
10              
11             =head1 SYNOPSIS
12              
13             Constructs function which behave like AnyEvent::Socket::tcp_connect
14              
15             use AnyEvent::SOCKS::Client qw/tcp_connect_via/;
16              
17             $AnyEvent::SOCKS::Client::TIMEOUT = 30;
18             # used only if prepare_cb NOT passed to proxied function
19             # e.g. AE::HTTP on_prepare callback is not present
20              
21             my @chain = qw/socks5://user:pass@192.0.2.100:1080 socks5://198.51.100.200:9080/;
22             tcp_connect_via( @chain )->( 'example.com', 80, sub{
23             my ($fh) = @_ or die "Connect failed $!";
24             ...
25             });
26              
27             SOCKS client for AnyEvent::HTTP
28              
29             http_get "http://example.com/foo",
30             tcp_connect => tcp_connect_via('socks5://198.51.100.200:9080'),
31             sub{
32             my( $data, $header) = @_ ;
33             ...
34             };
35              
36             =head1 SECURITY
37              
38             By default resolves names on SOCKS server. No DNS leaks.
39              
40             =head1 SUBROUTINES/METHODS
41              
42             =head2 $sub = tcp_connect_via( @proxy_uris )
43              
44             Function accepts proxy list and return proxied tcp_connect function. See AnyEvent::Socket docs for more information about its semantics.
45              
46             =cut
47              
48             =head1 Errors and logging
49              
50             Module uses AE::log for error reporting. You can use "error" or "debug" levels to get more information about errors.
51              
52             =cut
53              
54             package AnyEvent::SOCKS::Client;
55              
56 1     1   74771 use 5.006;
  1         4  
57 1     1   7 use strict ;
  1         2  
  1         26  
58              
59 1     1   1148 use AnyEvent;
  1         5909  
  1         60  
60 1     1   757 use AnyEvent::Util qw/guard/;
  1         13404  
  1         118  
61 1     1   814 use AnyEvent::Socket qw/tcp_connect parse_ipv4 format_ipv4 parse_ipv6 format_ipv6/;
  1         16476  
  1         145  
62 1     1   989 use AnyEvent::Handle ;
  1         8646  
  1         61  
63 1     1   895 use AnyEvent::Log ;
  1         13167  
  1         59  
64              
65 1     1   13 use Scalar::Util qw/weaken/;
  1         4  
  1         137  
66              
67             require Exporter;
68             our $VERSION = '0.051';
69             our @ISA = qw/Exporter/;
70             our @EXPORT_OK = qw/tcp_connect_via/;
71              
72             our $TIMEOUT = 300;
73              
74             use constant {
75 1         2587 TYPE_IP4 => 1,
76             TYPE_IP6 => 4,
77             TYPE_FQDN => 3,
78            
79             AUTH_ANON => 0,
80             AUTH_GSSAPI => 1,
81             AUTH_LOGIN => 2,
82             AUTH_GTFO => 255,
83            
84             CMD_CONNECT => 1 ,
85             CMD_BIND => 2,
86             CMD_UDP_ASSOC => 3,
87 1     1   7 };
  1         3  
88              
89             sub _parse_uri{
90 0     0     my $re = qr!socks(4|4a|5)://(?:([^\s:]+):([^\s@]*)@)?(\[[0-9a-f:.]+\]|[^\s:]+):(\d+)!i ;
91 0 0         if( $_[0] =~ m/$re/gi ){
92 0           my $p = {v => $1, login => $2, password => $3, host => $4, port => $5};
93 0           $p->{host} =~ s/^\[|\]$//g;
94 0           return $p;
95             }
96 0           undef ;
97             }
98             # returns tcp_connect compatible function
99             sub tcp_connect_via{
100 0     0 1   my(@chain) = @_ ;
101              
102 0 0         unless( @chain ){
103 0           AE::log "error" => "No socks were given, abort";
104 0     0     return sub{ $_[2]->() };
  0            
105             }
106 0           my @parsed;
107 0           for(@chain){
108 0 0         if( my $p = _parse_uri($_) ){
109 0           push @parsed, $p; next;
  0            
110             }
111 0           AE::log "error" => "Invalid socks uri: $_";
112 0     0     return sub{ $_[2]->() };
  0            
113             }
114              
115             return sub{
116 0     0     my( $dst_host, $dst_port, $c_cb, $pre_cb ) = @_ ;
117 0           my $con = bless {
118             chain => \@parsed,
119             dst_host => $dst_host,
120             dst_port => $dst_port,
121             c_cb => $c_cb,
122             pre_cb => $pre_cb,
123             }, __PACKAGE__ ;
124 0           $con->connect;
125              
126 0 0         if( defined wantarray ){ # not void
127 0           weaken( $con );
128             return guard{
129 0           AE::log "debug" => "Guard triggered" ;
130 0 0         if( ref $con eq __PACKAGE__ ){
131 0           undef $con->{c_cb};
132 0           $con->DESTROY;
133             }
134 0           };
135             }
136 0           undef;
137 0           };
138             }
139              
140             sub connect{
141 0     0 0   my( $self ) = @_ ;
142             # tcp connect to first socks
143 0           my $that = $self->{chain}->[0] ;
144             $self->{_guard} = tcp_connect $that->{host}, $that->{port}, sub{
145 0     0     my $fh = shift ;
146 0 0         unless($fh){
147 0           AE::log "error" => "$that->{host}:$that->{port} connect failed: $!";
148 0           return;
149             }
150              
151             $self->{hd} = new AnyEvent::Handle(
152             fh => $fh,
153             on_error => sub{
154 0           my ($hd, $fatal, $msg) = @_;
155 0 0         AE::log "error" => ( $fatal ? "Fatal " : "" ) . $msg ;
156 0 0         $hd->destroy unless( $hd->destroyed );
157 0           return;
158             }
159 0           );
160 0 0         if($that->{v} =~ /4a?/){
161 0           $self->connect_socks4;
162 0           return;
163             }
164 0           $self->handshake;
165 0   0 0     }, $self->{pre_cb} || sub{ $TIMEOUT };
  0            
166             }
167              
168             sub connect_socks4{
169 0     0 0   my( $self ) = @_;
170 0           my( $that, $next ) = @{ $self->{chain} } ;
  0            
171             my( $host, $port ) = $next
172             ? ( $next->{host}, $next->{port} )
173 0 0         : ( $self->{dst_host}, $self->{dst_port} ) ;
174              
175 0           my $ip4 = parse_ipv4($host);
176 0 0 0       if( $that->{v} eq '4' and not $ip4 ){
177 0           AE::log "error" => "SOCKS4 is only support IPv4 addresses: $host given";
178 0           return;
179             }
180              
181 0 0         if( $host =~ /:/ ){
182 0           AE::log "error" => "SOCKS4/4a doesn't support IPv6 addresses: $host given";
183 0           return;
184             }
185 0           AE::log "debug" => "SOCKS4 connect to $host:$port";
186 0 0         $self->{hd}->push_write( $ip4
187             ? pack('CCnA4A2', 4, CMD_CONNECT, $port, $ip4, "X\0" )
188             : pack('CCnCCCCA*', 4, CMD_CONNECT, $port, 0,0,0,7 , "X\0$host\0" )
189             );
190             $self->{hd}->push_read( chunk => 8, sub{
191 0     0     my($code, $dst_port, $dst_ip) = unpack('xCna4', $_[1]);
192 0 0         unless( $code == 90 ){
193 0           AE::log "error" => "SOCKS4/4a request rejected: code is $code";
194 0           return;
195             }
196 0           $self->socks_connect_done( format_ipv4( $dst_ip ), $dst_port );
197 0           });
198             }
199              
200             sub handshake{
201 0     0 0   my( $self ) = @_;
202 0           my $that = $self->{chain}->[0] ;
203 0           my @auth_methods = 0 ;
204 0 0 0       if($that->{login} and $that->{password}){
205 0           push @auth_methods, AUTH_LOGIN ;
206             }
207             $self->{hd}->push_write(
208 0           pack('CC', 5, scalar @auth_methods ) . join( "", map( pack( 'C', $_ ), @auth_methods ))
209             );
210             $self->{hd}->push_read( chunk => 2 , sub{
211 0     0     my $method = unpack( 'xC', $_[1] );
212 0           AE::log "debug" => "Server want auth method $method" ;
213 0 0         if($method == AUTH_GTFO ){
214 0           AE::log "error" => "Server: no suitable auth method";
215 0           return ;
216             }
217              
218 0 0         if( $method ) {
219 0           $self->auth($method);
220             }
221             else {
222 0           $self->connect_cmd ;
223             }
224 0           });
225             }
226              
227             sub auth{
228 0     0 0   my( $self, $method ) = @_;
229 0           my $that = $self->{chain}->[0] ;
230 0 0 0       if( $method == AUTH_LOGIN and $that->{login} and $that->{password}){
      0        
231             $self->{hd}->push_write(
232             pack('CC', 5, length $that->{login} ) . $that->{login}
233             . pack('C', length $that->{password}) . $that->{password}
234 0           );
235             $self->{hd}->push_read( chunk => 2, sub{
236 0     0     my $status = unpack('xC', $_[1]) ;
237 0 0         if( $status == 0 ){
238 0           $self->connect_cmd ;
239 0           return ;
240             }
241 0           AE::log "error" => "Bad login or password";
242 0           });
243 0           return ;
244             }
245 0           AE::log "error" => "Auth method $method not implemented!";
246             }
247              
248             sub connect_cmd{
249 0     0 0   my( $self ) = @_ ;
250 0           my $next = $self->{chain}->[1] ;
251             my( $host, $port ) = $next
252             ? ( $next->{host}, $next->{port} )
253 0 0         : ( $self->{dst_host}, $self->{dst_port} ) ;
254              
255 0           my ($cmd, $ip );
256 0 0         if( $ip = parse_ipv4($host) ){
    0          
257 0           AE::log "debug" => "Connect IPv4: $host";
258 0           $cmd = pack('CCCCA4n', 5, CMD_CONNECT, 0, TYPE_IP4, $ip, $port);
259             }
260             elsif( $ip = parse_ipv6($host) ){
261 0           AE::log "debug" => "Connect IPv6: $host";
262 0           $cmd = pack('CCCCA16n', 5, CMD_CONNECT, 0, TYPE_IP6, $ip, $port);
263             }
264             else{
265 0           AE::log "debug" => "Connect hostname: $host";
266 0           $cmd = pack('CCCCCA*n', 5, CMD_CONNECT, 0, TYPE_FQDN , length $host, $host, $port);
267             }
268              
269 0           $self->{hd}->push_write( $cmd );
270             $self->{hd}->push_read( chunk => 4, sub{
271 0     0     my( $status, $type ) = unpack( 'xCxC', $_[1] );
272 0 0         unless( $status == 0 ){
273 0           AE::log "error" => "Connect cmd rejected: status is $status" ;
274 0           return ;
275             }
276 0           $self->connect_cmd_finalize( $type );
277 0           });
278             }
279              
280             sub connect_cmd_finalize{
281 0     0 0   my( $self, $type ) = @_ ;
282              
283 0           AE::log "debug" => "Connect cmd done, bind atype is $type";
284              
285 0 0         if($type == TYPE_IP4){
    0          
    0          
286             $self->{hd}->push_read( chunk => 6, sub{
287 0     0     my( $host, $port) = unpack( "a4n", $_[1] );
288 0           $self->socks_connect_done( format_ipv4( $host ), $port );
289 0           });
290             }
291             elsif($type == TYPE_IP6){
292             $self->{hd}->push_read( chunk => 18, sub{
293 0     0     my( $host, $port) = unpack( "a16n", $_[1] );
294 0           $self->socks_connect_done( format_ipv6( $host ) , $port );
295 0           });
296             }
297             elsif($type == TYPE_FQDN){
298             # read 1 byte (fqdn len)
299             # then read fqdn and port
300             $self->{hd}->push_read( chunk => 1, sub{
301 0     0     my $fqdn_len = unpack( 'C', $_[1] ) ;
302             $self->{hd}->push_read( chunk => $fqdn_len + 2 , sub{
303 0           my $host = substr( $_[1], 0, $fqdn_len ) ;
304 0           my $port = unpack('n', substr( $_[1], -2) );
305 0           $self->socks_connect_done( $host, $port );
306 0           });
307 0           });
308             }
309             else{
310 0           AE::log "error" => "Unknown atype $type";
311             }
312             }
313              
314             sub socks_connect_done{
315 0     0 0   my( $self, $bind_host, $bind_port ) = @_;
316              
317 0           my $that = shift @{ $self->{chain} }; # shift = move forward in chain
  0            
318 0           AE::log "debug" => "Done with server socks$that->{v}://$that->{host}:$that->{port} , bound to $bind_host:$bind_port";
319              
320 0 0         if( @{ $self->{chain} } ){
  0            
321 0           $self->handshake ;
322 0           return ;
323             }
324              
325 0           AE::log "debug" => "Giving up fh and returning to void...";
326 0           my( $fh, $c_cb ) = ( $self->{hd}->fh, delete $self->{c_cb} );
327 0           $self->DESTROY;
328 0           $c_cb->( $fh );
329             }
330              
331             sub DESTROY {
332 0     0     my $self = shift ;
333 0           AE::log "debug" => "Kitten saver called";
334 0           undef $self->{_guard};
335 0 0 0       $self->{hd}->destroy if( $self->{hd} and not $self->{hd}->destroyed );
336 0 0         $self->{c_cb}->() if( $self->{c_cb} );
337 0           undef %$self;
338 0           bless $self, __PACKAGE__ . '::destroyed';
339             }
340              
341              
342             =head1 AUTHOR
343              
344             Zlobus, C<< >>
345              
346             =head1 BUGS
347              
348             Please report any bugs or feature requests to C, or through
349             the web interface at L. I will be notified, and then you'll
350             automatically be notified of progress on your bug as I make changes.
351              
352              
353              
354              
355             =head1 SUPPORT
356              
357             You can find documentation for this module with the perldoc command.
358              
359             perldoc AnyEvent::SOCKS::Client
360              
361              
362             You can also look for information at:
363              
364             =over 4
365              
366             =item * RT: CPAN's request tracker (report bugs here)
367              
368             L
369              
370             =item * AnnoCPAN: Annotated CPAN documentation
371              
372             L
373              
374             =item * CPAN Ratings
375              
376             L
377              
378             =item * Search CPAN
379              
380             L
381              
382             =back
383              
384              
385             =head1 ACKNOWLEDGEMENTS
386              
387             URI parser copied from AnyEvent::HTTP::Socks
388              
389              
390             =head1 LICENSE AND COPYRIGHT
391              
392             Copyright 2018 Zlobus.
393              
394             This program is free software; you can redistribute it and/or modify it
395             under the terms of the the Artistic License (2.0). You may obtain a
396             copy of the full license at:
397              
398             L
399              
400             Any use, modification, and distribution of the Standard or Modified
401             Versions is governed by this Artistic License. By using, modifying or
402             distributing the Package, you accept this license. Do not use, modify,
403             or distribute the Package, if you do not accept this license.
404              
405             If your Modified Version has been derived from a Modified Version made
406             by someone other than you, you are nevertheless required to ensure that
407             your Modified Version complies with the requirements of this license.
408              
409             This license does not grant you the right to use any trademark, service
410             mark, tradename, or logo of the Copyright Holder.
411              
412             This license includes the non-exclusive, worldwide, free-of-charge
413             patent license to make, have made, use, offer to sell, sell, import and
414             otherwise transfer the Package with respect to any patent claims
415             licensable by the Copyright Holder that are necessarily infringed by the
416             Package. If you institute patent litigation (including a cross-claim or
417             counterclaim) against any party alleging that the Package constitutes
418             direct or contributory patent infringement, then this Artistic License
419             to you shall terminate on the date that such litigation is filed.
420              
421             Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER
422             AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
423             THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
424             PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY
425             YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR
426             CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR
427             CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE,
428             EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
429              
430              
431             =cut
432              
433             1; # End of AnyEvent::SOCKS::Client