~grubng-dev/grubng/clients-perl

« back to all changes in this revision

Viewing changes to Client/Engine.pm

  • Committer: yagnesh
  • Date: 2011-06-26 06:20:58 UTC
  • Revision ID: s_yagnesh@yahoo.com-20110626062058-gz2d86sl8x3j4amn
Added POD to all modules; added Makefile.PL; moved modules under /lib/ dir

Show diffs side-by-side

added added

removed removed

Lines of Context:
1
 
# This program is free software: you can redistribute it and/or modify
2
 
# it under the terms of the GNU General Public License as published by
3
 
# the Free Software Foundation, either version 3 of the License, or
4
 
# (at your option) any later version.
5
 
#
6
 
# This program is distributed in the hope that it will be useful,
7
 
# but WITHOUT ANY WARRANTY; without even the implied warranty of
8
 
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
9
 
# GNU General Public License for more details.
10
 
#
11
 
# You should have received a copy of the GNU General Public License
12
 
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
13
 
 
14
 
#####################################################################################
15
 
# Grub::Client::Engine
16
 
# Downloads a workunit, crawls URLs in the workunit and uploads results to server
17
 
# 5/9/2011
18
 
#####################################################################################
19
 
package Client::Engine;
20
 
 
21
 
# standard modules
22
 
use Cwd;
23
 
use HTTP::Request::Common qw(GET);
24
 
use HTTP::Status;
25
 
use IO::Compress::Gzip qw(gzip $GzipError);
26
 
use LWP::UserAgent;
27
 
use File::Copy;
28
 
use Socket;
29
 
use Sys::Hostname;
30
 
 
31
 
# user defined modules
32
 
use Client::Configmanager qw(get_workunithandler_cfg);
33
 
use Client::Logmanager qw(write);
34
 
use Client::Utility qw(add_http_headers get_workunit);
35
 
 
36
 
BEGIN{
37
 
  Client::Logmanager::Initialize();
38
 
}
39
 
 
40
 
# reference to hash
41
 
my $workunitcfg = {};
42
 
 
43
 
###################################################
44
 
# Grub::Client::Engine
45
 
# Creates a new instance of Engine class
46
 
# Takes no parameters
47
 
# 4/26/2011
48
 
###################################################
49
 
sub new
50
 
{
51
 
  my $class = shift;
52
 
  my $self = {};
53
 
  bless $self,$class;
54
 
  return $self;
55
 
}
56
 
 
57
 
###################################################
58
 
# Grub::Client::Engine
59
 
# Initialized workunithandler
60
 
# 4/26/2011
61
 
###################################################
62
 
sub initialize{
63
 
  my ($uploadeddir, $faileddir);
64
 
  
65
 
  my $config =  get_workunithandler_cfg();
66
 
  write("Reading workunit configuration parameters.",3);  
67
 
  return if(!ref $config);
68
 
  
69
 
  $$workunitcfg{dispatchurl} = $$config{'dispatchurl'};
70
 
  $$workunitcfg{usr} = $$config{'usr'};
71
 
  $$workunitcfg{pwd} = $$config{'pwd'};
72
 
  $$workunitcfg{tmpdir} = $$config{'tmpdir'};
73
 
  $$workunitcfg{useproxy} = $$config{'useproxy'};
74
 
  $$workunitcfg{proxyurl} = $$config{'proxyurl'};
75
 
  $$workunitcfg{retries} = $$config{'retries'};
76
 
  $$workunitcfg{retrysecs} = $$config{'retrysecs'};
77
 
  $$workunitcfg{responsesizelimit} = $$config{'responsesizelimit'};
78
 
  $$workunitcfg{sitemapurl} = $$config{'sitemapurl'};
79
 
  $$workunitcfg{sitemapusr} = $$config{'sitemapusr'};
80
 
  $$workunitcfg{sitemappwd} = $$config{'sitemappwd'};
81
 
  $$workunitcfg{testmode} = $$config{'testmode'};
82
 
   
83
 
  if($$workunitcfg{'dispatchurl'} eq ''){
84
 
   write("Dispatch url is undefined. Unable to proceed further.", 3);
85
 
   $$workunitcfg{invalid} = 1; 
86
 
   return;
87
 
  }
88
 
 
89
 
  if($$workunitcfg{'tmpdir'} eq ''){
90
 
   $$workunitcfg{'tmpdir'} = getcwd;
91
 
   
92
 
   $uploadeddir = $$workunitcfg{tmpdir} . "/uploaded";
93
 
   $faileddir = $$workunitcfg{tmpdir} . "/failed";
94
 
   
95
 
   # create /uploaded/ directory
96
 
   if(! -d $uploadeddir && ! mkdir($uploadeddir)){
97
 
      write("Unable to create uploaded directory at $uploadeddir.Check user permission",1);
98
 
      $$workunitcfg{invalid} = 1;
99
 
   }
100
 
   
101
 
   # create /failed/ directory
102
 
   if(! -d $faileddir && ! mkdir($faileddir)){
103
 
      write("unable to create failed directory at $faileddir. Check user permission",1);
104
 
      $$workunitcfg{invalid} = 1; 
105
 
   }
106
 
  }
107
 
  else{
108
 
    if(! -d $$workunitcfg{tmpdir}){
109
 
      write("Temp directory $$workunitcfg{tmpdir} does not exist. Provide a valid temp directory path.",3);
110
 
      $$workunitcfg{invalid} = 1;
111
 
    }
112
 
    
113
 
    $uploadeddir = $$workunitcfg{tmpdir} . "/uploaded";
114
 
    $faileddir = $$workunitcfg{tmpdir} . "/failed";
115
 
   
116
 
    # create /uploaded/ directory
117
 
    if(! -d $uploadeddir && ! mkdir($uploadeddir)){
118
 
      write("Unable to create uploaded directory at $uploadeddir.Check user permission",1);
119
 
      $$workunitcfg{invalid} = 1;
120
 
    }
121
 
   
122
 
    # create /failed/ directory
123
 
    if(! -d $faileddir && ! mkdir($faileddir)){
124
 
      write("unable to create failed directory at $faileddir. Check user permission",1);
125
 
      $$workunitcfg{invalid} = 1; 
126
 
    }
127
 
  }
128
 
  
129
 
  $$workunitcfg{uploadeddir} = $uploadeddir;
130
 
  $$workunitcfg{faileddir} = $faileddir;
131
 
   
132
 
  if($$workunitcfg{'retries'} eq ''){
133
 
   $$workunitcfg{'retries'} = 1;
134
 
   write("Number of retries is undefined. Using default value of 1.", 3);
135
 
  }
136
 
   
137
 
  if($$workunitcfg{'retrysecs'} eq ''){
138
 
   $$workunitcfg{'retrysecs'} = 5;
139
 
   write("Retry duration is undefined. Using default value of 5 seconds.", 3);
140
 
  }
141
 
  
142
 
  if($$workunitcfg{sitemapurl} eq ''){
143
 
    write("Sitemap upload url is undefined. Sitemap files will not be created.", 3);
144
 
    $$workunitcfg{invalid} = 1; 
145
 
    return;
146
 
  }
147
 
  
148
 
  if($$workunitcfg{useproxy} && ($$workunitcfg{proxyurl} eq '')){
149
 
    write("Proxy flag is set but proxyurl is missing. Unable to proceed.", 1);
150
 
    $$workunitcfg{invalid} = 1; 
151
 
    return;
152
 
  }
153
 
}
154
 
 
155
 
#######################################################
156
 
# Grub::Client::Engine
157
 
# Entry into workunit handler
158
 
# 4/29/2011
159
 
#######################################################
160
 
sub start(){
161
 
 initialize();
162
 
 getworkunit() if(! $$workunitcfg{invalid});
163
 
 crawl() if(! $$workunitcfg{invalid});
164
 
}
165
 
 
166
 
#######################################################
167
 
# Grub::Client::Engine
168
 
# Gets a new workunit file from dispatch server
169
 
# 4/29/2011
170
 
#######################################################
171
 
sub getworkunit{
172
 
  # my $workunitcfg = shift;
173
 
  my ($req, $res, $ua, $retryctr);
174
 
  write("Entering work unit download handler method.",3);
175
 
  $retryctr = 1;
176
 
  $ua = LWP::UserAgent->new;
177
 
  
178
 
  #if using proxy, set cache-control and Pragma headers
179
 
  if ($$workunitcfg{useproxy}){
180
 
    write("Setting proxy",3);
181
 
    my $proxyurl = $$workunitcfg{proxyurl};
182
 
    my $headers_r = {
183
 
                      'Cache-Control' => "no-cache",
184
 
                      'Pragma' => "no-cache"
185
 
                      };
186
 
    add_http_headers($ua,$headers_r);
187
 
    
188
 
    # adding proxyurl 
189
 
    write("Adding proxy url to request.",3);
190
 
    $ua->proxy(['http'], $proxyurl);
191
 
  }
192
 
  
193
 
  $ua->timeout(60);
194
 
  $req = HTTP::Request->new(GET => $$workunitcfg{'dispatchurl'});
195
 
  $req->authorization_basic($$workunitcfg{'usr'}, $$workunitcfg{'pwd'});
196
 
  
197
 
  while($retryctr <= $$workunitcfg{'retries'}){
198
 
   write("Workunit download started at:". localtime, 3);
199
 
    $res = $ua->request($req);
200
 
    if($res->is_success){
201
 
      $$workunitcfg{workunit} = $res->content;
202
 
      write("Workunit download finished at:". localtime, 3);
203
 
      $retrycnt = 0;
204
 
      last;
205
 
    }
206
 
    elsif($res->is_error){
207
 
     $retryctr++;
208
 
     write("Workunit download operation failed. Next retry in $$workunitcfg{retrysecs} seconds.", 3);
209
 
     sleep($$workunitcfg{retrysecs});
210
 
   }
211
 
  }
212
 
  
213
 
  # workunit download failed after all the retries. Cannot continue any further
214
 
  if ($retryctr > 1){
215
 
    my $error = $res->error_as_HTML;
216
 
    write("Unable to download workunit from $$workunitcfg{'dispatchurl'}. Error is: $error. Some common causes are: \n1. Incorrect proxy URL, username or password.\n2. Incorrect dispatch server URL.\n3. Dispathch server may be unavailable or unable to process request at this time.\n4. Authentication failed at dispatch server.", 3);
217
 
    $$workunitcfg{invalid} = 1;
218
 
  }
219
 
  
220
 
  write($$workunitcfg{workunit},4);
221
 
}
222
 
 
223
 
######################################################################################################
224
 
# Grub::Client::Engine
225
 
# Crawls the sites in the workunit file, creates .arc.gz file and uploads the file to upload server
226
 
# 4/29/2011
227
 
######################################################################################################
228
 
sub crawl{
229
 
  my $self = $workunitcfg;
230
 
  my ($page, $host, $useragent, $accept, $filename, $arc, $unit_r, $ua, $req, $res, $url, $headers_r, $line1, $line2, $size, $responsesize, $buffer);
231
 
  my ($sitemap, $empty_content_size, $smfile, $arcfile, $full, @urls,%unitblk, $validfile, $arcgz, $smfilegz);
232
 
  my ($retryctr, $retrycnt);
233
 
  $empty_content_size = 0;
234
 
  $retryctr = 1;
235
 
  
236
 
  # calculate gmtime
237
 
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime();
238
 
  $mon +=  1;
239
 
  $year += 1900;
240
 
  my $gmtime = $mon.$mday.$year.$hour.$min.$sec;
241
 
  
242
 
  undef $sitemap;undef $arc;
243
 
  $validfile = 0;
244
 
  
245
 
  # get max response size in bytes; currently, response size limit is 25 MB
246
 
  $reponsesize = $$self{'responsesizelimit'} * 1024 * 1024;
247
 
  write("Setting response size limit to $responsesize.",4);
248
 
  # get ipaddress of host
249
 
  my $ipaddress = inet_ntoa((gethostbyname(hostname))[4]);
250
 
  
251
 
  # get arc and sitemap file name from workunit
252
 
  $filename = $1 if($$self{workunit} =~ /PUT\s*\/(.*)\.arc\.gz.*/);
253
 
  
254
 
  # construct arc file name
255
 
  $arcfile = $$self{'tmpdir'}.$filename.'.arc';
256
 
  $arcgz = $arcfile.'.gz';
257
 
  write("Arc file name is $arcfile.",3);
258
 
  open ARC, ">:utf8", $arcfile or write ("Error opening arc file for writing. Error is: $!", 1);
259
 
  
260
 
  # construct sitemap file name
261
 
  $smfile = $$self{'tmpdir'}.$filename.'.sitemap';
262
 
  write("Sitemap file name is $smfile.",3);
263
 
  open SITEMAP, ">:utf8", $smfile or write("Error opening sitemap file for writing. Error is: $!", 1);
264
 
  $ua = LWP::UserAgent->new;
265
 
  
266
 
  # construct .arc file header
267
 
  $line1 = "filedesc://$arcgz $ipaddress" . $gmtime ." text/plain ";
268
 
  $line2 = "1 0 grub.org\r\nURL IP-address Archive-date Content-type Archive-length\n";
269
 
  $size = length($line1) + length($line2);
270
 
  $arc .= $line1.$size."\n".$line2;
271
 
  print ARC $arc;
272
 
 
273
 
  #construct sitemap file header
274
 
  print SITEMAP "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\r\n<urlset xmlns=\"http://www.sitemaps.org/schemas/sitemap/0.9\">\r\n";
275
 
 
276
 
  # iterate each url in workunit; ech url section is delimited by \r\n\r\n
277
 
  foreach my $unit (split (/\r\n\r\n/, $$self{workunit})){
278
 
    undef $arc;undef $sitemap;undef $line1;undef $line2; undef @urls;
279
 
    
280
 
    # iterate each workunit section and get required details; each line in the workunit section is delimited by \r\n
281
 
    foreach my $unitline (split (/\r\n/, $unit)){
282
 
      if ($unitline =~ /^(GET)\s*(.*)\s*HTTP\/(1\.[01])$/i){
283
 
        $unitblk{'method'} = $1; # get the HTTP method; usually, GET
284
 
        $unitblk{'page'} = $2; # get the page url
285
 
        $unitblk{'protocolversion'} = $3; # get the HTTP protocol version to use in the request
286
 
      }
287
 
      
288
 
      $unitblk{'method'} = $1 if ($unitline =~ /^(PUT)/); # this is for uploading the .arc.gz file
289
 
      $unitblk{'host'} = $1 if ($unitline =~ /^Host:\s*(.*)$/i); # upload server host name
290
 
      $unitblk{'usragnt'} = $1 if ($unitline =~ /^User\-Agent\:\s*(.*)\s*.*$/i); # user-agent value to use
291
 
      $unitblk{'accept'} = $1 if ($unitline =~ /^Accept\:\s*(.*)$/i); # acceptable MIME types
292
 
    }
293
 
    
294
 
    # handle an incorrect entry in workunit file
295
 
    # if host == '' or page == '' or method == '' we can't send a request to the page
296
 
    # mark the page as invalid in arc file and move to next entry from workunit file
297
 
    if( $unitblk{'method'} eq '' || 
298
 
        $unitblk{'host'} eq '' || 
299
 
        $unitblk{'page'} eq '' ){
300
 
        $arc = "Invalid workunit file entry\r\n";
301
 
        $validfile = 0;
302
 
        print ARC $arc; 
303
 
        
304
 
        # move to next entry in workunit file
305
 
        next;
306
 
    }
307
 
      
308
 
    # if protocol version, user agent or accept are not set in workunit file, default them
309
 
    $unitblk{'protocolversion'} = '1.1' if ($unitblk{'protocolversion'} eq '');
310
 
    $unitblk{'usragnt'} = '' if ($unitblk{'usragnt'} eq '');
311
 
    $unitblk{'accept'} = '' if ($unitblk{'accept'} eq '');
312
 
        
313
 
    # if unit is GET, send a HTTP $protocolversion request to the host for the page using the user-agent and accetable MIME types
314
 
    if ($unitblk{'method'} =~ /GET/i){
315
 
      $url = 'http://'. $unitblk{'host'} . $unitblk{'page'};
316
 
      $headers_r = {
317
 
                     'User-Agent' => $unitblk{'usragnt'},
318
 
                     'Accept' => $unitblk{'accept'}
319
 
                   };
320
 
 
321
 
      # If client use proxy, must send additional HTTP headers:
322
 
      # For HTTP/1.0
323
 
        # Pragma: no-cache\r\n
324
 
      # For HTTP/1.1
325
 
        # Cache-control: no-cache\r\n
326
 
        # Pragma: no-cache\r\n
327
 
      if($$self{'useproxy'}){
328
 
       $$headers_r{'Pragma'} = 'no-cache\r\n';
329
 
       $$headers_r{'Cache-Control'} = 'no-cache\r\n' if ($unitblk{'protocolversion'} eq '1.1');
330
 
      }
331
 
       
332
 
      # For HTTP/1.1 there must be one more header:
333
 
        # Connection: close\r\n
334
 
      $$headers_r{'Connection'} = 'close\r\n' if ($unitblk{'protocolversion'} eq '1.1');
335
 
      add_http_headers($ua, $headers_r);
336
 
      $ua->max_size($reponsesize);
337
 
      $ua->max_redirect(0);
338
 
      write("Processing url $url.", 3);
339
 
      $req = HTTP::Request->new(GET => $url);
340
 
      
341
 
      # debug values
342
 
      write("URL is $url",4);
343
 
      write("Method = $unitblk{'method'}",4);
344
 
      write("Page = $unitblk{'page'}",4);
345
 
      write("Protocol Version = $unitblk{'protocolversion'}",4);
346
 
      write("Host = $unitblk{'host'}",4);
347
 
      write("User Agent = $unitblk{'usragnt'}",4);
348
 
      write("Accept = $unitblk{'accept'}",4);
349
 
      my $maxredirect = $ua->max_redirect;
350
 
      write("Max redirect = $maxredirect",4);
351
 
      my $maxsize = $ua->max_size;
352
 
      write("Max size = $maxsize",4);
353
 
       
354
 
      $res = $ua->request($req);
355
 
      my $rescode = $res->code;
356
 
      write("Response code for url $url is $rescode.", 3);
357
 
       # process response
358
 
       if ($res->code eq RC_OK){ #response code == 200
359
 
          # 204 - server not sent page content (when server answer is HTTP 200 and server sent only HTTP headers)
360
 
         if(length($res->content) == empty_content_size){
361
 
           write("$url: HTTP 204.", 3);
362
 
           $line1 = "$url $ipaddress ". $gmtime ." application/x-grub-error ";
363
 
           $line2 = "HTTP/1.0 204 Server not sent page content\r\n\r\nServer not sent page content\n";
364
 
           $size = length($line1) + length($line2);
365
 
           $line1 .= $size ."\n";
366
 
           $arc .= $line1.$line2 ."\r\n";
367
 
           $validfile = 1;
368
 
           print ARC $arc;
369
 
         }
370
 
         # 403 - page cannot be indexed due to META ROBOTS tag
371
 
         elsif($res->content =~ /<META NAME="ROBOTS" CONTENT="NOINDEX, NOFOLLOW">/i || $res->content =~ /<META NAME="ROBOTS" CONTENT="NOINDEX">/i || $res->content =~ /<META NAME="ROBOTS" CONTENT="NOFOLLOW">/i ){
372
 
           write("$url: HTTP 403.", 3);
373
 
           $line1 = "$url $ipaddress ". $gmtime ." application/x-grub-error ";
374
 
           $line2 = "HTTP/1.0 403 Page cannot be indexed due to META ROBOTS tag\r\n\r\nPage cannot be indexed due to META ROBOTS tag\n";
375
 
           $size = length($line1) + length($line2);
376
 
           $line1 .= $size ."\n";
377
 
           $arc .= $line1.$line2 ."\r\n";
378
 
           $validfile = 1;
379
 
           print ARC $arc;
380
 
         }
381
 
         else{ # not 204 and 403. Process page for URLs and write to sitemap file
382
 
           write("$url: HTTP 200.", 3);
383
 
           $line1 = "$url $ipaddress " . $gmtime . " text/html ";
384
 
           foreach ($res->header_field_names){
385
 
                $line2 .= $_ . ':' . $res->header("$_"). "\n";
386
 
           }
387
 
           
388
 
           $line2 .= $res->content($reponsesize)."\n";
389
 
           $size = length($line1) + length($line2);
390
 
           $line1 .= $size ."\n";
391
 
           $arc .= $line1.$line2 ."\r\n";
392
 
           $validfile = 1;
393
 
           print ARC $arc;
394
 
           @urls = $arc =~ /\shref="?([^\s>"]+)/gi;
395
 
           print "Count of Urls is " . scalar @urls ."\n";
396
 
           foreach $url(@urls){
397
 
            $full = canonicalise($url,$unitblk{'host'});
398
 
            # print "Full URL = $full\n";
399
 
            next unless($full);
400
 
            
401
 
            # http://www.sitemaps.org/protocol.php
402
 
            # <?xml version="1.0" encoding="UTF-8"?>
403
 
            # <urlset xmlns="http://www.sitemaps.org/schemas/sitemap/0.9">
404
 
            #   <url>
405
 
            #     <loc>http://www.example.com/</loc>
406
 
            #     <lastmod>2005-01-01</lastmod> # optional
407
 
            #     <changefreq>monthly</changefreq> # optional
408
 
            #     <priority>0.8</priority> # optional
409
 
            #   </url>
410
 
            # </urlset>
411
 
            
412
 
            $sitemap .= "<url>\n";
413
 
            $sitemap .= "<loc>$full</loc>\n";
414
 
            $sitemap .= "</loc>\n";
415
 
            $sitemap .= "</url>\n";
416
 
            print SITEMAP $sitemap;
417
 
           }
418
 
         }
419
 
       }
420
 
       # 404 - client cannot resolve server IP via DNS
421
 
       elsif($res->code eq RC_NOT_FOUND){
422
 
         write("$url: HTTP 404.", 3);
423
 
         $line1 = "$url $ipaddress ". $gmtime . " application/x-grub-error ";
424
 
         $line2 = "HTTP/1.0 404 client cannot resolve server IP via DNS\r\n\r\nclient cannot resolve server IP via DNS\n";
425
 
         $size = length($line1) + length($line2);
426
 
         $line1 .= $size ."\n";
427
 
         $arc .= $line1.$line2 ."\r\n";
428
 
         $validfile = 1;
429
 
         print ARC $arc;
430
 
       }
431
 
       # 406 - invalid data type sent (different than allowed by HTTP Accept header)
432
 
       elsif($res->code eq RC_NOT_ACCEPTABLE){
433
 
         write("$url: HTTP 406.", 3);
434
 
         $line1 = "$url $ipaddress ". $gmtime . " application/x-grub-error ";
435
 
         $line2 = "HTTP/1.0 406 invalid data type sent\r\n\r\ninvalid data type sent\n";
436
 
         $size = length($line1) + length($line2);
437
 
         $line1 .= $size ."\n";
438
 
         $arc .= $line1.$line2 ."\r\n";
439
 
         $validfile = 1;
440
 
         print ARC $arc;
441
 
       }
442
 
       # 408 - timeout
443
 
       elsif($res->code eq RC_REQUEST_TIMEOUT){
444
 
         write("$url: HTTP 408.", 3);
445
 
         $line1 = "$url $ipaddress ". $gmtime . " application/x-grub-error ";
446
 
         $line2 = "HTTP/1.0 408 timeout\r\n\r\ntimeout\n";
447
 
         $size = length($line1) + length($line2);
448
 
         $line1 .= $size ."\n";
449
 
         $arc .= $line1.$line2 ."\r\n";
450
 
         $validfile = 1;
451
 
         print ARC $arc;
452
 
       }
453
 
       # 503 - server not sent any data (client connect to server but don't get any data in response)
454
 
       elsif($res->code eq RC_SERVICE_UNAVAILABLE){
455
 
         write("$url: HTTP 503.", 3);
456
 
         $line1 = "$url $ipaddress " . $gmtime . " application/x-grub-error ";
457
 
         $line2 = "HTTP/1.0 503 server not sent any data\r\n\r\nserver not sent any data\n";
458
 
         $size = length($line1) + length($line2);
459
 
         $line1 .= $size ."\n";
460
 
         $arc .= $line1.$line2 ."\r\n";
461
 
         $validfile = 1;
462
 
         print ARC $arc;
463
 
       }
464
 
       # handle all other response
465
 
       else{
466
 
         my $code = $res->code;
467
 
         my $msg = $res->message;
468
 
         write("$url: HTTP $responsecode.", 4);
469
 
         $line1 = "$url $ipaddress " . $gmtime . " application/x-grub-error ";
470
 
         $line2 = "HTTP/1.0 $code $msg\n";
471
 
         $size = length($line1) + length($line2);
472
 
         $line1 .= $size ."\n";
473
 
         $arc .= $line1.$line2 ."\r\n";
474
 
         $validfile = 1;
475
 
         print ARC $arc;
476
 
      }
477
 
    }
478
 
    elsif($unitblk{'method'} =~ /PUT/i){
479
 
      write("Entering PUT block.",3);   
480
 
     
481
 
      # upload .arc.gz file
482
 
      if($validfile){
483
 
       write("Compressing file $arcfile", 3);
484
 
       
485
 
       if(! gzip $arcfile => $arcgz){
486
 
        write ("Error in compressing arc file. Error is $GzipError.", 1);
487
 
       }
488
 
       write("Completed writing compressed file $arcfile.gz to filesystem", 3);
489
 
       close ARC;
490
 
       if(!$$self{testmode}){
491
 
        # upload file to upload server
492
 
        $req = HTTP::Request(PUT => $unitblk{'host'}, Content_Type => 'form-data', Content => [arcfile => [$arcgz,$arcgz]]);
493
 
        $req->authorization_basic($$workunitcfg{'usr'}, $$workunitcfg{'pwd'});
494
 
        
495
 
        # add required headers
496
 
        if($$self{'useproxy'}){
497
 
          $$headers_r{'Pragma'} = 'no-cache\r\n';
498
 
          $$headers_r{'Cache-Control'} = 'no-cache\r\n' if ($unitblk{'protocolversion'} eq '1.1');
499
 
       }
500
 
         
501
 
       $$headers_r{'Connection'} = 'keep-alive\r\n';
502
 
       $$headers_r{'Content-Length'} = -s $$self{tmpdir}.$arcfile;
503
 
       add_http_headers($ua,$headers_r);
504
 
      
505
 
       write ("Upload of $filename.arc.gz started at: ". scalar localtime, 3);
506
 
       
507
 
       # make upload request
508
 
       while($retryctr < $$workunitcfg{retries}){
509
 
        # try uploading the .arcz file to upload server
510
 
        $res = $ua->request($req);
511
 
        
512
 
        # if upload did not go through, retry till the configured retry limit
513
 
        # if upload goes through, move the file to /uploaded/ dir else move to /failed/ dir
514
 
        if($res->is_error){
515
 
          write("Error in uploading .arc.gz file. Retrying in $$workunitcfg{retrysecs} seconds.", 3);
516
 
          sleep($$workunitcfg{retrysecs});
517
 
          $retryctr++;      
518
 
        }
519
 
        elsif($res->is_success){ # upload success, quit retrying
520
 
          move($arcz,$$self{uploadeddir});
521
 
          write ("Upload of $arcz finished at: ". scalar localtime, 3);
522
 
          $retryctr = 0;
523
 
          last;
524
 
        }
525
 
       }
526
 
       
527
 
       # upload failed; move the failed file to $failed dir
528
 
       if ($retryctr > 0){
529
 
        move($arcgz,$$self{faileddir});
530
 
        write("Upload of $arcz failed after $$workunitcfg{retries} retry attemps. The upload server may be unavailable at this time. Please try uploading it later. The compressed file is available at $$self{faileddir}.",3);
531
 
      }
532
 
     }
533
 
   }
534
 
   
535
 
   $retryctr = 0;
536
 
     
537
 
   # upload sitemap file
538
 
   if($validfile){
539
 
     print SITEMAP "</urlset>\n";
540
 
     close SITEMAP;
541
 
     write("Finished writing sitemap file $smfile to filesystem.", 3);
542
 
     $smfilegz = $smfile.'.gz';
543
 
     
544
 
     # compress $smfile
545
 
     write("Compressing file $smfile", 3);
546
 
     if(! gzip $smfile => $smfilegz){
547
 
      write("Error in compressing $smfile. Error is $GzipError.", 1); 
548
 
     }
549
 
     if(! $$self{testmode}){
550
 
       # upload file to upload server
551
 
       $req = HTTP::Request(PUT => $$self{sitemapurl}, Content_Type => 'form-data', Content => [smfile => [$smfilegz,$smfilegz]]);
552
 
       $req->authorization_basic($$self{'sitemapusr'}, $$self{'sitemappwd'});
553
 
       
554
 
       # add required headers
555
 
       if($$self{'useproxy'}){
556
 
         $$headers_r{'Pragma'} = 'no-cache\r\n';
557
 
         $$headers_r{'Cache-Control'} = 'no-cache\r\n' if ($unitblk{'protocolversion'} eq '1.1');
558
 
       }
559
 
       $$headers_r{'Connection'} = 'keep-alive\r\n';
560
 
       $$headers_r{'Content-Length'} = -s $$self{tmpdir}.$smfile;
561
 
       add_http_headers($ua,$headers_r);
562
 
       
563
 
       # make upload request
564
 
       write ("Upload of $smfile started at:". scalar localtime, 3);
565
 
       
566
 
       # make upload request
567
 
       # if the upload goes through, move the file to /uploaded/ dir else move it to /failed/ dir
568
 
       while($retryctr < $$workunitcfg{retries}){
569
 
         $res = $ua->request($req);
570
 
         if($res->is_success){
571
 
           move($smfilegz,$$self{uploadeddir});
572
 
           write ("Upload of $smfilegz finished at: ". scalar localtime, 3);
573
 
           $retryctr = 0;
574
 
           last;
575
 
         }
576
 
         elsif($res->is_error){
577
 
           write("Error in uploading $smfilegz file. Retrying in $$workunitcfg{retrysecs} seconds.", 3);
578
 
           sleep($$workunitcfg{retrysecs});
579
 
           $retryctr++;  
580
 
         }
581
 
       }
582
 
       
583
 
       # upload of sitemap file failed; move the file to /failed/ dir
584
 
       if ($retryctr > 0){ 
585
 
        move($smfilegz,$$self{faileddir});
586
 
        write("Upload of $smfilegz failed after $$workunitcfg{retries} retry attemps. The upload server may be unavailable at this time. Please try uploading it later. The compressed file is available at $smfilegz.",3);
587
 
      }
588
 
     }
589
 
   }
590
 
   last;
591
 
  }
592
 
 }
593
 
}
594
 
 
595
 
# http://www.wellho.net/resources/ex.php4?item=p408/page_checker
596
 
# Sample (simplified code!) to reduce all URLs to a full, standard format
597
 
sub canonicalise($$){
598
 
  my $source = shift;
599
 
  my $site = shift;
600
 
  $canon = "";
601
 
  return ($canon) if ($source =~ /^(mailto:|telnet:|callto:)/) ;
602
 
  if ($source =~ /^\//) {
603
 
    $source = $site . $source;
604
 
  }
605
 
  $source =~ s/[\#?].*//;
606
 
  return $source;
607
 
}
608
 
 
609
 
1;