FS/FS/Cron/upload.pm

   1 package FS::Cron::upload;
   2
   3 use strict;
   4 use vars qw( @ISA @EXPORT_OK $me $DEBUG );
   5 use Exporter;
   6 use Date::Format;
   7 use FS::UID qw(dbh);
   8 use FS::Record qw( qsearch qsearchs );
   9 use FS::Conf;
  10 use FS::queue;
  11 use FS::agent;
  12 use FS::Misc qw( send_email ); #for bridgestone
  13 use FS::upload_target;
  14 use LWP::UserAgent;
  15 use HTTP::Request;
  16 use HTTP::Request::Common;
  17 use HTTP::Response;
  18 use Net::FTP;
  19 use List::Util qw( sum );
  20
  21 @ISA = qw( Exporter );
  22 @EXPORT_OK = qw ( upload );
  23 $DEBUG = 0;
  24 $me = '[FS::Cron::upload]';
  25
  26 #freeside-daily %opt:
  27 #  -v: enable debugging
  28 #  -l: debugging level
  29 #  -m: Experimental multi-process mode uses the job queue for multi-process and/or multi-machine billing.
  30 #  -r: Multi-process mode dry run option
  31 #  -a: Only process customers with the specified agentnum
  32
  33
  34 sub upload {
  35   my %opt = @_;
  36
  37   my $debug = 0;
  38   $debug = 1 if $opt{'v'};
  39   $debug = $opt{'l'} if $opt{'l'};
  40
  41   local $DEBUG = $debug if $debug;
  42
  43   warn "$me upload called\n" if $DEBUG;
  44
  45   my @tasks;
  46
  47   my $date =  time2str('%Y%m%d%H%M%S', $^T); # more?
  48
  49   my $conf = new FS::Conf;
  50
  51   my @agents = $opt{'a'} ? FS::agent->by_key($opt{'a'}) : qsearch('agent', {});
  52
  53   my %task = (
  54     'date'      => $date,
  55     'l'         => $opt{'l'},
  56     'm'         => $opt{'m'},
  57     'v'         => $opt{'v'},
  58   );
  59
  60   my @agentnums = ('', map {$_->agentnum} @agents);
  61
  62   foreach my $target (qsearch('upload_target', {})) {
  63     # We don't know here if it's spooled on a per-agent basis or not.
  64     # (It could even be both, via different events.)  So queue up an
  65     # upload for each agent, plus one with null agentnum, and we'll
  66     # upload as many files as we find.
  67     foreach my $a (@agentnums) {
  68       push @tasks, {
  69         %task,
  70         'agentnum'  => $a,
  71         'targetnum' => $target->targetnum,
  72         'handling'  => $target->handling,
  73       };
  74     }
  75   }
  76
  77   # deprecated billco method
  78   foreach (@agents) {
  79     my $agentnum = $_->agentnum;
  80
  81     if ( $conf->config( 'billco-username', $agentnum, 1 ) ) {
  82       my $username = $conf->config('billco-username', $agentnum, 1);
  83       my $password = $conf->config('billco-password', $agentnum, 1);
  84       my $clicode  = $conf->config('billco-clicode',  $agentnum, 1);
  85       my $url      = $conf->config('billco-url',      $agentnum);
  86       push @tasks, {
  87         %task,
  88         'agentnum' => $agentnum,
  89         'username' => $username,
  90         'password' => $password,
  91         'url'      => $url,
  92         'clicode'  => $clicode,
  93         'handling' => 'billco',
  94       };
  95     }
  96   } # foreach @agents
  97
  98   # if there's nothing to do, don't hold up the rest of the process
  99   return '' if !@tasks;
 100
 101   # wait for any ongoing billing jobs to complete
 102   if ($opt{m}) {
 103     my $dbh = dbh;
 104     my $sql = "SELECT count(*) FROM queue LEFT JOIN cust_main USING(custnum) ".
 105     "WHERE queue.job='FS::cust_main::queued_bill' AND status != 'failed'";
 106     if (@agents) {
 107       $sql .= ' AND cust_main.agentnum IN('.
 108         join(',', map {$_->agentnum} @agents).
 109         ')';
 110     }
 111     my $sth = $dbh->prepare($sql) or die $dbh->errstr;
 112     while (1) {
 113       $sth->execute()
 114         or die "Unexpected error executing statement $sql: ". $sth->errstr;
 115       last if $sth->fetchrow_arrayref->[0] == 0;
 116       warn "Waiting 5min for billing to complete...\n" if $DEBUG;
 117       sleep 300;
 118     }
 119   }
 120
 121   foreach (@tasks) {
 122
 123     my $agentnum = $_->{agentnum};
 124
 125     if ( $opt{'m'} ) {
 126
 127       if ( $opt{'r'} ) {
 128         warn "DRY RUN: would add agent $agentnum for queued upload\n";
 129       } else {
 130         my $queue = new FS::queue {
 131           'job'      => 'FS::Cron::upload::spool_upload',
 132         };
 133         my $error = $queue->insert( %$_ );
 134       }
 135
 136     } else {
 137
 138       eval { spool_upload(%$_) };
 139       warn "spool_upload failed: $@\n"
 140         if $@;
 141
 142     }
 143
 144   }
 145
 146 }
 147
 148 sub spool_upload {
 149   my %opt = @_;
 150
 151   warn "$me spool_upload called\n" if $DEBUG;
 152   my $conf = new FS::Conf;
 153   my $dir = '%%%FREESIDE_EXPORT%%%/export.'. $FS::UID::datasrc. '/cust_bill';
 154
 155   my $date = $opt{date} or die "no date provided\n";
 156
 157   local $SIG{HUP} = 'IGNORE';
 158   local $SIG{INT} = 'IGNORE';
 159   local $SIG{QUIT} = 'IGNORE';
 160   local $SIG{TERM} = 'IGNORE';
 161   local $SIG{TSTP} = 'IGNORE';
 162   local $SIG{PIPE} = 'IGNORE';
 163
 164   my $oldAutoCommit = $FS::UID::AutoCommit;
 165   local $FS::UID::AutoCommit = 0;
 166   my $dbh = dbh;
 167
 168   my $agentnum = $opt{agentnum};
 169
 170   my $agent;
 171   if ( $agentnum ) {
 172     $agent = qsearchs( 'agent', { agentnum => $agentnum } )
 173       or die "no such agent: $agentnum";
 174     $agent->select_for_update; #mutex
 175   }
 176
 177   if ( $opt{'handling'} eq 'billco' ) {
 178
 179     my $file = "agentnum$agentnum";
 180     my $zipfile  = "$dir/$file-$date.zip";
 181
 182     unless ( -f "$dir/$file-header.csv" ||
 183              -f "$dir/$file-detail.csv" )
 184     {
 185       warn "$me neither $dir/$file-header.csv nor ".
 186            "$dir/$file-detail.csv found\n" if $DEBUG > 1;
 187       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 188       return;
 189     }
 190
 191     my $url      = $opt{url} or die "no url for agent $agentnum\n";
 192     $url =~ s/^\s+//; $url =~ s/\s+$//;
 193
 194     my $username = $opt{username} or die "no username for agent $agentnum\n";
 195     my $password = $opt{password} or die "no password for agent $agentnum\n";
 196
 197     foreach ( qw ( header detail ) ) {
 198       rename "$dir/$file-$_.csv",
 199              "$dir/$file-$date-$_.csv";
 200     }
 201
 202     my $command = "cd $dir; zip $zipfile ".
 203                   "$file-$date-header.csv ".
 204                   "$file-$date-detail.csv";
 205
 206     system($command) and die "$command failed\n";
 207
 208     unlink "$file-$date-header.csv",
 209            "$file-$date-detail.csv";
 210
 211     if ( $url =~ /^http/i ) {
 212
 213       my $ua = new LWP::UserAgent;
 214       my $res = $ua->request( POST( $url,
 215                                     'Content_Type' => 'form-data',
 216                                     'Content' => [ 'username' => $username,
 217                                                    'pass'     => $password,
 218                                                    'custid'   => $username,
 219                                                    'clicode'  => $opt{clicode},
 220                                                    'file1'    => [ $zipfile ],
 221                                                  ],
 222                                   )
 223                             );
 224
 225       die "upload failed: ". $res->status_line. "\n"
 226         unless $res->is_success;
 227
 228     } elsif ( $url =~ /^ftp:\/\/([\w\.]+)(\/.*)$/i ) {
 229
 230       my($hostname, $path) = ($1, $2);
 231
 232       my $ftp = new Net::FTP($hostname, Passive=>1)
 233         or die "can't connect to $hostname: $@\n";
 234       $ftp->login($username, $password)
 235         or die "can't login to $hostname: ". $ftp->message."\n";
 236       unless ( $ftp->cwd($path) ) {
 237         my $msg = "can't cd $path on $hostname: ". $ftp->message. "\n";
 238         ( $path eq '/' ) ? warn $msg : die $msg;
 239       }
 240       $ftp->binary
 241         or die "can't set binary mode on $hostname\n";
 242
 243       $ftp->put($zipfile)
 244         or die "can't put $zipfile: ". $ftp->message. "\n";
 245
 246       $ftp->quit;
 247
 248     } else {
 249       die "unknown scheme in URL $url\n";
 250     }
 251
 252   }
 253   else { #not billco
 254
 255     my $targetnum = $opt{targetnum};
 256     my $upload_target = FS::upload_target->by_key($targetnum)
 257       or die "FTP target $targetnum not found\n";
 258
 259     $dir .= "/target$targetnum";
 260     chdir($dir);
 261
 262     my $file  = $agentnum ? "agentnum$agentnum" : 'spool'; #.csv
 263
 264     unless ( -f "$dir/$file.csv" ) {
 265       warn "$me $dir/$file.csv not found\n" if $DEBUG > 1;
 266       $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 267       return;
 268     }
 269
 270     rename "$dir/$file.csv", "$dir/$file-$date.csv";
 271
 272     if ( $opt{'handling'} eq 'bridgestone' ) {
 273
 274       my $prefix = $conf->config('bridgestone-prefix', $agentnum);
 275       unless ( $prefix ) {
 276         warn "$me agent $agentnum has no bridgestone-prefix, skipped\n";
 277         $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 278         return;
 279       }
 280
 281       my $seq = $conf->config('bridgestone-batch_counter', $agentnum) || 1;
 282
 283       # extract zip code
 284       join(' ',$conf->config('company_address', $agentnum)) =~
 285         /(\d{5}(\-\d{4})?)\s*$/;
 286       my $ourzip = $1 || ''; #could be an explicit option if really needed
 287       $ourzip  =~ s/\D//;
 288       my $newfile = sprintf('%s_%s_%0.6d.dat',
 289                             $prefix,
 290                             time2str('%Y%m%d', time),
 291                             $seq);
 292       warn "copying spool to $newfile\n" if $DEBUG;
 293
 294       my ($in, $out);
 295       open $in, '<', "$dir/$file-$date.csv"
 296         or die "unable to read $file-$date.csv\n";
 297       open $out, '>', "$dir/$newfile" or die "unable to write $newfile\n";
 298       #header--not sure how much of this generalizes at all
 299       my $head = sprintf(
 300         "%-6s%-4s%-27s%-6s%0.6d%-5s%-9s%-9s%-7s%0.8d%-7s%0.6d\n",
 301         ' COMP:', 'VISP', '', ',SEQ#:', $seq, ',ZIP:', $ourzip, ',VERS:1.1',
 302         ',RUNDT:', time2str('%m%d%Y', $^T),
 303         ',RUNTM:', time2str('%H%M%S', $^T),
 304       );
 305       warn "HEADER: $head" if $DEBUG;
 306       print $out $head;
 307
 308       my $rows = 0;
 309       while( <$in> ) {
 310         print $out $_;
 311         $rows++;
 312       }
 313
 314       #trailer
 315       my $trail = sprintf(
 316         "%-6s%-4s%-27s%-6s%0.6d%-7s%0.9d%-9s%0.9d\n",
 317         ' COMP:', 'VISP', '', ',SEQ:', $seq,
 318         ',LINES:', $rows+2, ',LETTERS:', $rows,
 319       );
 320       warn "TRAILER: $trail" if $DEBUG;
 321       print $out $trail;
 322
 323       close $in;
 324       close $out;
 325
 326       my $zipfile = sprintf('%s_%0.6d.zip', $prefix, $seq);
 327       my $command = "cd $dir; zip $zipfile $newfile";
 328       warn "compressing to $zipfile\n$command\n" if $DEBUG;
 329       system($command) and die "$command failed\n";
 330
 331       my $error = $upload_target->put($zipfile);
 332       if ( $error ) {
 333         foreach ( qw ( header detail ) ) {
 334           rename "$dir/$file-$date-$_.csv",
 335                  "$dir/$file-$_.csv";
 336           die $error;
 337         }
 338       }
 339
 340       send_email(
 341         prepare_report('bridgestone-confirm_template',
 342           {
 343             agentnum=> $agentnum,
 344             zipfile => $zipfile,
 345             prefix  => $prefix,
 346             seq     => $seq,
 347             rows    => $rows,
 348           }
 349         )
 350       );
 351
 352       $seq++;
 353       warn "setting batch counter to $seq\n" if $DEBUG;
 354       $conf->set('bridgestone-batch_counter', $seq, $agentnum);
 355
 356     } elsif ( $opt{'handling'} eq 'ics' ) {
 357
 358       my ($basename, $regfile, $bigfile);
 359       $basename = sprintf('c%sc1', time2str('%m%d', time));
 360       $regfile = $basename . 'i.txt'; # for "regular" (short) invoices
 361       $bigfile = $basename . 'b.txt'; # for "big" invoices
 362
 363       warn "copying spool to $regfile, $bigfile\n" if $DEBUG;
 364
 365       my ($in, $reg, $big); #filehandles
 366       my %count = (B => 0, 1 => 0, 2 => 0); # number of invoices
 367       my %sum = (B => 0, R => 0); # total of charges field
 368       open $in, '<', "$dir/$file-$date.csv"
 369         or die "unable to read $file-$date.csv\n";
 370
 371       open $reg, '>', "$dir/$regfile" or die "unable to write $regfile\n";
 372       open $big, '>', "$dir/$bigfile" or die "unable to write $bigfile\n";
 373
 374       while (my $line = <$in>) {
 375         chomp($line);
 376         my $tag = substr($line, -1, 1, '');
 377         my $charge = substr($line, 252, 10);
 378         if ( $tag eq 'B' ) {
 379           print $big $line, "\n";
 380           $count{B}++;
 381           $sum{B} += $charge;
 382         } else {
 383           print $reg $line, "\n";
 384           $count{$tag}++;
 385           $sum{R} += $charge;
 386         }
 387       }
 388       close $in;
 389       close $reg;
 390       close $big;
 391
 392       # zip up all three files for transport
 393       my $zipfile = "$basename" . '.zip';
 394       my $command = "cd $dir; zip $zipfile $regfile $bigfile";
 395       system($command) and die "'$command' failed\n";
 396
 397       # upload them, unless we're using email, in which case
 398       # the zip file will ride along with the report.  yes, this
 399       # kind of defeats the purpose of the upload_target interface,
 400       # but at least we have a place to store the configuration.
 401       my $error = '';
 402       if ( $upload_target->protocol ne 'email' ) {
 403         $error = $upload_target->put("$dir/$zipfile");
 404       }
 405
 406       # create the report
 407       for (values %sum) {
 408         $_ = sprintf('%.2f', $_);
 409       }
 410
 411       my %report = prepare_report('ics-confirm_template',
 412         {
 413           agentnum  => $agentnum,
 414           count     => \%count,
 415           sum       => \%sum,
 416           error     => $error,
 417         }
 418       );
 419       if ( $upload_target->protocol eq 'email' ) {
 420         $report{'to'} =
 421           join('@', $upload_target->username, $upload_target->hostname);
 422         $report{'subject'} = $upload_target->subject;
 423         $report{'mimeparts'} = [
 424           { Path        => "$dir/$zipfile",
 425             Type        => 'application/zip',
 426             Encoding    => 'base64',
 427             Filename    => $zipfile,
 428             Disposition => 'attachment',
 429           }
 430         ];
 431       }
 432       $error = send_email(%report);
 433
 434       if ( $error ) {
 435         # put the original spool file back
 436         rename "$dir/$file-$date.csv", "$dir/$file.csv";
 437         die $error;
 438       }
 439
 440     } else { # not bridgestone or ics
 441
 442       # this is the usual case
 443
 444       my $error = $upload_target->put("$file-$date.csv");
 445       if ( $error ) {
 446         rename "$dir/$file-$date.csv", "$dir/$file.csv";
 447         die $error;
 448       }
 449
 450     }
 451
 452   } #opt{handling}
 453
 454   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 455   '';
 456
 457 }
 458
 459 =item send_report CONFIG PARAMS
 460
 461 Retrieves the config value named CONFIG, parses it as a Text::Template,
 462 extracts "to" and "subject" headers, and returns a hash that can be passed
 463 to L<FS::Misc::send_email>.
 464
 465 PARAMS is a hashref to be passed to C<fill_in>.  It must contain
 466 'agentnum' to look up the per-agent config.
 467
 468 =cut
 469
 470 # we used it twice, so it's now a subroutine
 471
 472 sub prepare_report {
 473
 474   my ($config, $params) = @_;
 475   my $agentnum = $params->{agentnum};
 476   my $conf = FS::Conf->new;
 477
 478   my $template = join("\n", $conf->config($config, $agentnum));
 479   if (!$template) {
 480     warn "$me agent $agentnum has no $config, no email report sent\n";
 481     return;
 482   }
 483
 484   my $tmpl_obj = Text::Template->new(
 485     TYPE => 'STRING', SOURCE => $template
 486   );
 487   my $content = $tmpl_obj->fill_in( HASH => $params );
 488   my ($head, $body) = split("\n\n", $content, 2);
 489   $head =~ /^subject:\s*(.*)$/im;
 490   my $subject = $1;
 491
 492   $head =~ /^to:\s*(.*)$/im;
 493   my $to = $1;
 494
 495   (
 496     to      => $to,
 497     from    => $conf->config('invoice_from', $agentnum),
 498     subject => $subject,
 499     body    => $body,
 500   );
 501
 502 }
 503
 504 1;