File Coverage

blib/lib/WWW/Xunlei.pm
Criterion Covered Total %
statement 181 208 87.0
branch 23 42 54.7
condition 9 18 50.0
subroutine 39 43 90.7
pod 4 7 57.1
total 256 318 80.5


line stmt bran cond sub pod time code
1             package WWW::Xunlei;
2              
3 1     1   80508 use strict;
  1         2  
  1         27  
4 1     1   4 use warnings;
  1         0  
  1         28  
5              
6 1     1   3 use LWP::UserAgent;
  1         5  
  1         24  
7 1     1   3 use HTTP::Request;
  1         1  
  1         23  
8 1     1   3 use URI::Escape;
  1         1  
  1         60  
9 1     1   717 use JSON;
  1         9826  
  1         3  
10              
11 1     1   97 use File::Basename;
  1         1  
  1         56  
12 1     1   4 use File::Path qw/mkpath/;
  1         1  
  1         32  
13 1     1   402 use Time::HiRes qw/gettimeofday/;
  1         945  
  1         3  
14 1     1   501 use POSIX qw/strftime/;
  1         4288  
  1         7  
15 1     1   834 use Digest::MD5 qw(md5_hex);
  1         1  
  1         39  
16 1     1   502 use Term::ANSIColor qw/:constants/;
  1         4759  
  1         521  
17 1     1   487 use Data::Dumper;
  1         4213  
  1         47  
18              
19 1     1   323 use WWW::Xunlei::Downloader;
  1         1  
  1         33  
20              
21             our $DEBUG;
22              
23 1     1   4 use constant URL_LOGIN => 'http://login.xunlei.com/';
  1         1  
  1         44  
24 1     1   3 use constant URL_REMOTE => 'http://homecloud.yuancheng.xunlei.com/';
  1         0  
  1         38  
25 1         33 use constant DEFAULT_USER_AGENT =>
26             "Mozilla/5.0 (Macintosh; Intel Mac OS X 10.11; rv:41.0) "
27 1     1   3 . "Gecko/20100101 Firefox/41.0";
  1         0  
28 1     1   3 use constant URL_LOGIN_REFER => 'http://i.xunlei.com/login/2.5/?r_d=1';
  1         1  
  1         30  
29 1     1   2 use constant BUSINESS_TYPE => '113';
  1         1  
  1         34  
30 1     1   3 use constant V => '2';
  1         0  
  1         30  
31 1     1   3 use constant CT => '0';
  1         1  
  1         1100  
32              
33             sub new {
34 1     1 1 475 my $class = shift;
35 1         3 my ( $user, $pass, %options ) = @_;
36 1         3 my $self = {
37             'ua' => undef,
38             'json' => undef,
39             'user' => $user,
40             'pass' => md5pass($pass),
41             };
42              
43 1         2 my $cookie_file = $options{'cookie_file'};
44 1         6 $self->{'ua'} = LWP::UserAgent->new;
45 1         2229 $self->{'ua'}->cookie_jar( { file => $cookie_file } );
46 1         5574 $self->{'ua'}->agent(DEFAULT_USER_AGENT);
47              
48 1         53 $self->{'json'} = JSON->new->allow_nonref;
49              
50 1         2 bless $self, $class;
51 1         3 return $self;
52             }
53              
54             sub get_downloaders {
55 3     3 1 127 my $self = shift;
56              
57 3         7 my $parameters = { 'type' => 0, };
58              
59 3         8 my $res = $self->_yc_request( 'listPeer', $parameters );
60              
61 3 50       6 if ( $res->{'rtn'} != 0 ) {
62 0         0 die "Unable to get the Downloader List: $@";
63             }
64              
65 3         3 my @downloaders;
66 3         3 for my $p ( @{ $res->{'peerList'} } ) {
  3         6  
67 3         13 push @downloaders, WWW::Xunlei::Downloader->new( $self, $p );
68             }
69              
70 3 100       17 return wantarray ? @downloaders : \@downloaders;
71             }
72              
73             sub get_downloader {
74 1     1 1 304 my $self = shift;
75            
76 1         2 my $name = shift;
77              
78 1         2 my @downloaders = grep { $_->{'name'} eq $name } $self->get_downloaders();
  1         6  
79 1 50       3 die "No such Downloader named >>$name<<" unless @downloaders;
80 1         3 return shift @downloaders;
81             }
82              
83             sub bind {
84 0     0 1 0 my $self = shift;
85              
86 0         0 my ( $key, $name ) = @_;
87              
88 0         0 my $parameters = {
89             'boxname' => $name,
90             'key' => $key,
91             };
92              
93 0         0 my $res = $self->_yc_request( 'bind', $parameters );
94             }
95              
96             sub unbind {
97 0     0 0 0 my $self = shift;
98 0         0 my $pid = shift;
99              
100 0         0 my $res = $self->_yc_request( 'unbind', { 'pid' => $pid } );
101             }
102              
103             sub _login {
104 0     0   0 my $self = shift;
105 0         0 my $res = 1;
106 0 0       0 unless ( $self->_is_session_expired ) {
107 0         0 $res = $self->_session_login;
108             }
109             # sometimes the cookie( session_id ) is forced revoked from the
110             # server side. So we have to login with user/pass even it's not expired.
111 0 0       0 $res = $self->_form_login if ( $res != 0 );
112              
113 0 0       0 die "Login Error: $res" if ( $res != 0 );
114 0         0 $self->_set_auto_login();
115 0         0 $self->_save_cookie();
116             }
117              
118             sub _form_login {
119 1     1   2 my $self = shift;
120 1         2 my $verify_code = uc $self->_get_verify_code();
121 1         4 $self->_debug( "Verify Code: " . $verify_code );
122 1         6 my $password = md5_hex( $self->{'pass'} . $verify_code );
123             my $parameters = {
124 1         4 'u' => $self->{'user'},
125             'p' => $password,
126             'verifycode' => $verify_code,
127             };
128              
129             # $self->{'ua'}->post(join( '/', URL_LOGIN, 'sec2login/'), $parameters);
130 1         3 $self->_request( 'POST', URL_LOGIN . 'sec2login/', $parameters );
131              
132 1         3 return $self->_get_cookie('blogresult');
133             }
134              
135             sub _session_login {
136 1     1   2 my $self = shift;
137 1         3 my $parameters = { 'sessionid' => $self->_get_cookie('_x_a_') };
138 1         4 $self->_request( 'GET', URL_LOGIN . 'sessionid/', $parameters );
139 1         2 return $self->_get_cookie('blogresult');
140             }
141              
142             sub _is_logged_in {
143 11     11   10 my $self = shift;
144 11   33     16 return ( $self->_get_cookie('sessionid')
145             && $self->_get_cookie('userid') );
146             }
147              
148             sub _is_session_expired {
149 3     3   267 my $self = shift;
150              
151             my $session_expired_time
152             = $self->{'ua'}
153 3         7 ->{'cookie_jar'}{'COOKIES'}{'.xunlei.com'}{'/'}{'_x_a_'}[5];
154 3 100       14 return 1 unless $session_expired_time;
155 1         7 return (gettimeofday)[0] > $session_expired_time;
156             }
157              
158             sub _get_verify_code {
159 2     2   1570 my $self = shift;
160             my $parameters = {
161 2         20 'u' => $self->{'user'},
162             'business_type' => BUSINESS_TYPE,
163             'cachetime' => int( gettimeofday() * 1000 ),
164             };
165 2         7 $self->_request( 'GET', URL_LOGIN . 'check/', $parameters );
166 2         6 my $check_result = $self->_get_cookie('check_result');
167 2         7 my $verify_code = ( split( ':', $check_result ) )[1];
168 2         11 return $verify_code;
169             }
170              
171             sub _set_auto_login {
172 2     2   3 my $self = shift;
173 2         4 my $sessionid = $self->_get_cookie('sessionid');
174 2         5 $self->_set_cookie( '_x_a_', $sessionid, 604800 );
175             }
176              
177             sub _delete_temp_cookies {
178 0     0   0 my $self = shift;
179             my @login_cookie
180 0         0 = qw/VERIFY_KEY verify_type check_n check_e logindetail result/;
181 0         0 for my $c (@login_cookie) {
182 0         0 $self->_delete_cookie($c);
183             }
184             }
185              
186             sub _get_cookie {
187 33     33   1014 my $self = shift;
188 33         31 my ( $key, $domain, $path ) = @_;
189 33   50     93 $domain ||= ".xunlei.com";
190 33   50     71 $path ||= "/";
191 33         122 $self->{'ua'}->{'cookie_jar'}->{'COOKIES'}{$domain}{'/'}{$key}[1];
192             }
193              
194             sub _set_cookie {
195 5     5   1470 my $self = shift;
196 5         7 my ( $key, $value, $expire, $domain, $path ) = @_;
197 5   50     21 $domain ||= ".xunlei.com";
198 5   50     13 $path ||= "/";
199 5         13 $self->{'ua'}->{'cookie_jar'}
200             ->set_cookie( undef, $key, $value, $path, $domain, undef,
201             undef, undef, $expire );
202 5         91 $self->{'ua'}->{'cookie_jar'}->{'COOKIES'}{$domain}{$path}{$key};
203             }
204              
205             sub _save_cookie {
206 5     5   296 my $self = shift;
207              
208 5         12 $self->_delete_cookie('blogresult');
209 5         41 my $cookie_file = $self->{'ua'}->{'cookie_jar'}->{'file'};
210 5 100       17 return unless $cookie_file;
211 3         125 my $cookie_path = dirname($cookie_file);
212 3 100       54 if ( !-d $cookie_path ) {
213 1         137 mkpath($cookie_path);
214             }
215 3         10 $self->{'ua'}->{'cookie_jar'}->save();
216             }
217              
218             sub _delete_cookie {
219 7     7   179 my $self = shift;
220 7         9 my ( $key, $domain, $path ) = @_;
221 7   50     25 $domain ||= ".xunlei.com";
222 7   50     19 $path ||= "/";
223 7         19 $self->{'ua'}->{'cookie_jar'}->clear($domain, $path, $key);
224             }
225              
226             sub _yc_request {
227 9     9   9 my $self = shift;
228 9         11 my ( $action, $parameters, $data ) = @_;
229              
230 9 50       17 my $method = $data ? 'POST' : 'GET';
231 9         11 my $uri = URL_REMOTE . $action;
232 9         12 $parameters->{'v'} = V;
233 9         11 $parameters->{'ct'} = CT;
234              
235 9 50       13 $self->_login unless $self->_is_logged_in;
236 9         14 my $res = $self->_request( $method, $uri, $parameters, $data );
237 9 50       18 if ( $res->{'rtn'} != 0 ) {
238              
239             # Todo: Handling not login failed here.
240 0         0 die "Request Error: $res->{'rtn'}";
241             }
242              
243 9         45 return $res;
244             }
245              
246             sub _request {
247 13     13   11 my $self = shift;
248 13         16 my ( $method, $uri, $parameters, $postdata ) = @_;
249 13         9 my ( $form_string, $payload );
250 13 50       21 if ($parameters) {
251 13         17 $form_string = urlencode($parameters);
252             }
253              
254 13 100 66     33 if ( $method ne 'GET' && !$postdata ) {
255              
256             # use urlencode parameters as post data when posting login form.
257 1         2 $payload = $form_string;
258             }
259             else {
260 12         18 $uri .= '?' . $form_string;
261 12 50       18 if ( ref $postdata ) {
262 0         0 $payload = $self->{'json'}->encode($postdata);
263 0         0 $payload = urlencode( { 'json' => $payload } );
264             }
265             }
266              
267 13         39 my $request = HTTP::Request->new( $method => $uri, undef, $payload );
268 13         5751 $request->header( 'Content-Type' => 'application/x-www-form-urlencoded' );
269 13         444 $self->_debug($request);
270 13         36 my $response = $self->{'ua'}->request($request);
271 13 50       21543 die $response->code . ":" . $response->message
272             unless $response->is_success;
273 13         92 my $content = $response->content;
274              
275 13         88 $self->_debug($content);
276              
277 13         23 $content =~ s/\s$//g;
278 13 100       28 return "" unless ( length($content) );
279              
280 9 50       138 return $self->{'json'}->decode($content) if ( $content =~ /\s*[\[\{\"]/ );
281             }
282              
283             sub urlencode {
284 13     13 0 11 my $data = shift;
285              
286 13         13 my @parameters;
287 13         31 for my $key ( keys %$data ) {
288             push @parameters,
289 53         353 join( '=', map { uri_escape_utf8($_) } $key, $data->{$key} );
  106         524  
290             }
291 13         118 my $encoded_data = join( '&', @parameters );
292 13         24 return $encoded_data;
293             }
294              
295             sub md5pass {
296 1     1 0 2 my $pass = shift;
297 1 50       3 if ( $pass !~ /^[0-9a-f]{32}$/i ) {
298 1         5 $pass = md5_hex( md5_hex($pass) );
299             }
300 1         4 return $pass;
301             }
302              
303             sub _debug {
304 27     27   29 my $self = shift;
305 27         23 my $message = shift;
306 27 50       47 if ($DEBUG) {
307 0 0         if ( ref $message ) { $message = Dumper($message); }
  0            
308 0           my $date = strftime( "%Y-%m-%d %H:%M:%S", localtime );
309              
310             #$date .= sprintf(".%03f", current_timestamp());
311 0           print BLUE "[ $date ] ", GREEN $message, RESET "\n";
312             }
313             }
314              
315             1;
316              
317             =pod
318              
319             =encoding UTF-8
320              
321             =head1 NAME
322              
323             WWW::Xunlei - Perl API For Official Xunlei Remote API.
324              
325             =head1 VERSION
326              
327             version 0.2
328              
329             =head1 SYNOPSIS
330              
331             use WWW::Xunlei;
332             my $client = WWW::Xunlei->new("username", "password");
333             # use the first downloader;
334             my $downloader = $client->get_downloaders()->[0];
335             # create a remote task;
336             $downloader->create_task("http://www.cpan.org/src/5.0/perl-5.22.0.tar.gz");
337              
338             =head1 DESCRIPTION
339              
340             C is a Perl Wrapper of Xunlei Remote Downloader API.
341             L
342              
343             =head1 METHODS
344              
345             =head2 new( $username, $password, [cookie_file=>'/path/to/cookie'])
346              
347             create a Xunlei client. Load or save Cookies to a plain text file with
348             C option. The default session expire time is 7 days.
349              
350             =head2 bind($key, [$name])
351              
352             Bind a new downloader with a activation code. The new downloader's name can
353             be defined with the optional argument C<$name>.
354              
355             =head2 get_downloaders
356              
357             List all the downloaders binding with your account. Return a list of
358             C object.
359              
360             =head2 get_downloader($name)
361              
362             Get the downloader of which the name is $name.
363             Return a C object.
364              
365             =head1 AUTHOR
366              
367             Zhu Sheng Li
368              
369             =head1 COPYRIGHT AND LICENSE
370              
371             This software is Copyright (c) 2015 by Zhu Sheng Li.
372              
373             This is free software, licensed under:
374              
375             The MIT (X11) License
376              
377             =cut
378              
379             __END__