FS/FS/UI/Web.pm

   1 package FS::UI::Web;
   2
   3 use strict;
   4 use vars qw($DEBUG @ISA @EXPORT_OK $me);
   5 use Exporter;
   6 use Carp qw( confess );
   7 use HTML::Entities;
   8 use FS::Conf;
   9 use FS::Misc::DateTime qw( parse_datetime day_end );
  10 use FS::Record qw(dbdef);
  11 use FS::cust_main;  # are sql_balance and sql_date_balance in the right module?
  12
  13 #use vars qw(@ISA);
  14 #use FS::UI
  15 #@ISA = qw( FS::UI );
  16 @ISA = qw( Exporter );
  17
  18 @EXPORT_OK = qw( svc_url );
  19
  20 $DEBUG = 0;
  21 $me = '[FS::UID::Web]';
  22
  23 ###
  24 # date parsing
  25 ###
  26
  27 use Date::Parse;
  28 sub parse_beginning_ending {
  29   my($cgi, $prefix) = @_;
  30   $prefix .= '_' if $prefix;
  31
  32   my $beginning = 0;
  33   if ( $cgi->param($prefix.'begin') =~ /^(\d+)$/ ) {
  34     $beginning = $1;
  35   } elsif ( $cgi->param($prefix.'beginning') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
  36     $beginning = parse_datetime($1) || 0;
  37   }
  38
  39   my $ending = 4294967295; #2^32-1
  40   if ( $cgi->param($prefix.'end') =~ /^(\d+)$/ ) {
  41     $ending = $1 - 1;
  42   } elsif ( $cgi->param($prefix.'ending') =~ /^([ 0-9\-\/\:]{1,64})$/ ) {
  43     $ending = parse_datetime($1);
  44     $ending = day_end($ending) unless $ending =~ /:/;
  45   }
  46
  47   ( $beginning, $ending );
  48 }
  49
  50 =item svc_url
  51
  52 Returns a service URL, first checking to see if there is a service-specific
  53 page to link to, otherwise to a generic service handling page.  Options are
  54 passed as a list of name-value pairs, and include:
  55
  56 =over 4
  57
  58 =item * m - Mason request object ($m)
  59
  60 =item * action - The action for which to construct "edit", "view", or "search"
  61
  62 =item ** part_svc - Service definition (see L<FS::part_svc>)
  63
  64 =item ** svcdb - Service table
  65
  66 =item *** query - Query string
  67
  68 =item *** svc   - FS::cust_svc or FS::svc_* object
  69
  70 =item ahref - Optional flag, if set true returns <A HREF="$url"> instead of just the URL.
  71
  72 =back
  73
  74 * Required fields
  75
  76 ** part_svc OR svcdb is required
  77
  78 *** query OR svc is required
  79
  80 =cut
  81
  82   # ##
  83   # #required
  84   # ##
  85   #  'm'        => $m, #mason request object
  86   #  'action'   => 'edit', #or 'view'
  87   #
  88   #  'part_svc' => $part_svc, #usual
  89   #   #OR
  90   #  'svcdb'    => 'svc_table',
  91   #
  92   #  'query'    => #optional query string
  93   #                # (pass a blank string if you want a "raw" URL to add your
  94   #                #  own svcnum to)
  95   #   #OR
  96   #  'svc'      => $svc_x, #or $cust_svc, it just needs a svcnum
  97   #
  98   # ##
  99   # #optional
 100   # ##
 101   #  'ahref'    => 1, # if set true, returns <A HREF="$url">
 102
 103 use FS::CGI qw(rooturl);
 104 sub svc_url {
 105   my %opt = @_;
 106
 107   #? return '' unless ref($opt{part_svc});
 108
 109   my $svcdb = $opt{svcdb} || $opt{part_svc}->svcdb;
 110   my $query = exists($opt{query}) ? $opt{query} : $opt{svc}->svcnum;
 111   my $url;
 112   warn "$me [svc_url] checking for /$opt{action}/$svcdb.cgi component"
 113     if $DEBUG;
 114   if ( $opt{m}->interp->comp_exists("/$opt{action}/$svcdb.cgi") ) {
 115     $url = "$svcdb.cgi?";
 116   } else {
 117
 118     my $generic = $opt{action} eq 'search' ? 'cust_svc' : 'svc_Common';
 119
 120     $url = "$generic.html?svcdb=$svcdb;";
 121     $url .= 'svcnum=' if $query =~ /^\d+(;|$)/ or $query eq '';
 122   }
 123
 124   import FS::CGI 'rooturl'; #WTF!  why is this necessary
 125   my $return = rooturl(). "$opt{action}/$url$query";
 126
 127   $return = qq!<A HREF="$return">! if $opt{ahref};
 128
 129   $return;
 130 }
 131
 132 sub svc_link {
 133   my($m, $part_svc, $cust_svc) = @_ or return '';
 134   svc_X_link( $part_svc->svc, @_ );
 135 }
 136
 137 sub svc_label_link {
 138   my($m, $part_svc, $cust_svc) = @_ or return '';
 139   my($svc, $label, $svcdb) = $cust_svc->label;
 140   svc_X_link( $label, @_ );
 141 }
 142
 143 sub svc_X_link {
 144   my ($x, $m, $part_svc, $cust_svc) = @_ or return '';
 145
 146   return $x
 147    unless $FS::CurrentUser::CurrentUser->access_right('View customer services');
 148
 149   confess "svc_X_link called without a service ($x, $m, $part_svc, $cust_svc)\n"
 150     unless $cust_svc;
 151
 152   my $ahref = svc_url(
 153     'ahref'    => 1,
 154     'm'        => $m,
 155     'action'   => 'view',
 156     'part_svc' => $part_svc,
 157     'svc'      => $cust_svc,
 158   );
 159
 160   "$ahref$x</A>";
 161 }
 162
 163 #this probably needs an ACL too...
 164 sub svc_export_links {
 165   my ($m, $part_svc, $cust_svc) = @_ or return '';
 166
 167   my $ahref = $cust_svc->export_links;
 168
 169   join('', @$ahref);
 170 }
 171
 172 sub parse_lt_gt {
 173   my($cgi, $field) = @_;
 174
 175   my @search = ();
 176
 177   my %op = (
 178     'lt' => '<',
 179     'gt' => '>',
 180   );
 181
 182   foreach my $op (keys %op) {
 183
 184     warn "checking for ${field}_$op field\n"
 185       if $DEBUG;
 186
 187     if ( $cgi->param($field."_$op") =~ /^\s*\$?\s*(-?[\d\,\s]+(\.\d\d)?)\s*$/ ) {
 188
 189       my $num = $1;
 190       $num =~ s/[\,\s]+//g;
 191       my $search = "$field $op{$op} $num";
 192       push @search, $search;
 193
 194       warn "found ${field}_$op field; adding search element $search\n"
 195         if $DEBUG;
 196     }
 197
 198   }
 199
 200   @search;
 201
 202 }
 203
 204 ###
 205 # cust_main report subroutines
 206 ###
 207
 208
 209 =item cust_header [ CUST_FIELDS_VALUE ]
 210
 211 Returns an array of customer information headers according to the supplied
 212 customer fields value, or if no value is supplied, the B<cust-fields>
 213 configuration value.
 214
 215 =cut
 216
 217 use vars qw( @cust_fields @cust_colors @cust_styles @cust_aligns );
 218
 219 sub cust_header {
 220
 221   warn "FS::UI:Web::cust_header called"
 222     if $DEBUG;
 223
 224   my $conf = new FS::Conf;
 225
 226   my %header2method = (
 227     'Customer'                 => 'name',
 228     'Cust. Status'             => 'ucfirst_cust_status',
 229     'Cust#'                    => 'custnum',
 230     'Name'                     => 'contact',
 231     'Company'                  => 'company',
 232     '(bill) Customer'          => 'name',
 233     '(service) Customer'       => 'ship_name',
 234     '(bill) Name'              => 'contact',
 235     '(service) Name'           => 'ship_contact',
 236     '(bill) Company'           => 'company',
 237     '(service) Company'        => 'ship_company',
 238     'Address 1'                => 'address1',
 239     'Address 2'                => 'address2',
 240     'City'                     => 'city',
 241     'State'                    => 'state',
 242     'Zip'                      => 'zip',
 243     'Country'                  => 'country_full',
 244     'Day phone'                => 'daytime', # XXX should use msgcat, but how?
 245     'Night phone'              => 'night',   # XXX should use msgcat, but how?
 246     'Fax number'               => 'fax',
 247     '(bill) Address 1'         => 'address1',
 248     '(bill) Address 2'         => 'address2',
 249     '(bill) City'              => 'city',
 250     '(bill) State'             => 'state',
 251     '(bill) Zip'               => 'zip',
 252     '(bill) Country'           => 'country_full',
 253     '(bill) Day phone'         => 'daytime', # XXX should use msgcat, but how?
 254     '(bill) Night phone'       => 'night',   # XXX should use msgcat, but how?
 255     '(bill) Fax number'        => 'fax',
 256     '(service) Address 1'      => 'ship_address1',
 257     '(service) Address 2'      => 'ship_address2',
 258     '(service) City'           => 'ship_city',
 259     '(service) State'          => 'ship_state',
 260     '(service) Zip'            => 'ship_zip',
 261     '(service) Country'        => 'ship_country_full',
 262     '(service) Day phone'      => 'ship_daytime', # XXX should use msgcat, how?
 263     '(service) Night phone'    => 'ship_night',   # XXX should use msgcat, how?
 264     '(service) Fax number'     => 'ship_fax',
 265     'Invoicing email(s)'       => 'invoicing_list_emailonly_scalar',
 266     'Payment Type'             => 'payby',
 267     'Current Balance'          => 'current_balance',
 268   );
 269   $header2method{'Cust#'} = 'display_custnum'
 270     if $conf->exists('cust_main-default_agent_custid');
 271
 272   my %header2colormethod = (
 273     'Cust. Status' => 'cust_statuscolor',
 274   );
 275   my %header2style = (
 276     'Cust. Status' => 'b',
 277   );
 278   my %header2align = (
 279     'Cust. Status' => 'c',
 280     'Cust#'        => 'r',
 281   );
 282
 283   my $cust_fields;
 284   my @cust_header;
 285   if ( @_ && $_[0] ) {
 286
 287     warn "  using supplied cust-fields override".
 288           " (ignoring cust-fields config file)"
 289       if $DEBUG;
 290     $cust_fields = shift;
 291
 292   } else {
 293
 294     if (    $conf->exists('cust-fields')
 295          && $conf->config('cust-fields') =~ /^([\w\. \|\#\(\)]+):?/
 296        )
 297     {
 298       warn "  found cust-fields configuration value"
 299         if $DEBUG;
 300       $cust_fields = $1;
 301     } else {
 302       warn "  no cust-fields configuration value found; using default 'Cust. Status | Customer'"
 303         if $DEBUG;
 304       $cust_fields = 'Cust. Status | Customer';
 305     }
 306
 307   }
 308
 309   @cust_header = split(/ \| /, $cust_fields);
 310   @cust_fields = map { $header2method{$_} || $_ } @cust_header;
 311   @cust_colors = map { exists $header2colormethod{$_}
 312                          ? $header2colormethod{$_}
 313                          : ''
 314                      }
 315                      @cust_header;
 316   @cust_styles = map { exists $header2style{$_} ? $header2style{$_} : '' }
 317                      @cust_header;
 318   @cust_aligns = map { exists $header2align{$_} ? $header2align{$_} : 'l' }
 319                      @cust_header;
 320
 321   #my $svc_x = shift;
 322   @cust_header;
 323 }
 324
 325 =item cust_sql_fields [ CUST_FIELDS_VALUE ]
 326
 327 Returns a list of fields for the SELECT portion of an SQL query.
 328
 329 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 330 defined by the supplied customer fields setting, or if no customer fields
 331 setting is supplied, the <B>cust-fields</B> configuration value.
 332
 333 =cut
 334
 335 sub cust_sql_fields {
 336
 337   my @fields = qw( last first company );
 338   push @fields, map "ship_$_", @fields;
 339   push @fields, 'country';
 340
 341   cust_header(@_);
 342   #inefficientish, but tiny lists and only run once per page
 343
 344   my @add_fields = qw( address1 address2 city state zip daytime night fax );
 345   push @fields,
 346     grep { my $field = $_; grep { $_ eq $field } @cust_fields }
 347          ( @add_fields, ( map "ship_$_", @add_fields ), 'payby' );
 348
 349   push @fields, 'agent_custid';
 350
 351   my @extra_fields = ();
 352   if (grep { $_ eq 'current_balance' } @cust_fields) {
 353     push @extra_fields, FS::cust_main->balance_sql . " AS current_balance";
 354   }
 355
 356   map("cust_main.$_", @fields), @extra_fields;
 357 }
 358
 359 =item cust_fields OBJECT [ CUST_FIELDS_VALUE ]
 360
 361 Given an object that contains fields from cust_main (say, from a
 362 JOINed search.  See httemplate/search/svc_* for examples), returns an array
 363 of customer information, or "(unlinked)" if this service is not linked to a
 364 customer.
 365
 366 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 367 defined by the supplied customer fields setting, or if no customer fields
 368 setting is supplied, the <B>cust-fields</B> configuration value.
 369
 370 =cut
 371
 372
 373 sub cust_fields {
 374   my $record = shift;
 375   warn "FS::UI::Web::cust_fields called for $record ".
 376        "(cust_fields: @cust_fields)"
 377     if $DEBUG > 1;
 378
 379   #cust_header(@_) unless @cust_fields; #now need to cache to keep cust_fields
 380   #                                     #override incase we were passed as a sub
 381
 382   my $seen_unlinked = 0;
 383
 384   map {
 385     if ( $record->custnum ) {
 386       warn "  $record -> $_" if $DEBUG > 1;
 387       encode_entities( $record->$_(@_) );
 388     } else {
 389       warn "  ($record unlinked)" if $DEBUG > 1;
 390       $seen_unlinked++ ? '' : '(unlinked)';
 391     }
 392   } @cust_fields;
 393 }
 394
 395 =item cust_fields_subs
 396
 397 Returns an array of subroutine references for returning customer field values.
 398 This is similar to cust_fields, but returns each field's sub as a distinct
 399 element.
 400
 401 =cut
 402
 403 sub cust_fields_subs {
 404   my $unlinked_warn = 0;
 405   return map {
 406     my $f = $_;
 407     if ( $unlinked_warn++ ) {
 408
 409       sub {
 410         my $record = shift;
 411         if ( $record->custnum ) {
 412           encode_entities( $record->$f(@_) );
 413         } else {
 414           '(unlinked)'
 415         };
 416       };
 417
 418     } else {
 419
 420       sub {
 421         my $record = shift;
 422         $record->custnum ? encode_entities( $record->$f(@_) ) : '';
 423       };
 424
 425     }
 426
 427   } @cust_fields;
 428 }
 429
 430 =item cust_colors
 431
 432 Returns an array of subroutine references (or empty strings) for returning
 433 customer information colors.
 434
 435 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 436 defined by the supplied customer fields setting, or if no customer fields
 437 setting is supplied, the <B>cust-fields</B> configuration value.
 438
 439 =cut
 440
 441 sub cust_colors {
 442   map {
 443     my $method = $_;
 444     if ( $method ) {
 445       sub { shift->$method(@_) };
 446     } else {
 447       '';
 448     }
 449   } @cust_colors;
 450 }
 451
 452 =item cust_styles
 453
 454 Returns an array of customer information styles.
 455
 456 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 457 defined by the supplied customer fields setting, or if no customer fields
 458 setting is supplied, the <B>cust-fields</B> configuration value.
 459
 460 =cut
 461
 462 sub cust_styles {
 463   map {
 464     if ( $_ ) {
 465       $_;
 466     } else {
 467       '';
 468     }
 469   } @cust_styles;
 470 }
 471
 472 =item cust_aligns
 473
 474 Returns an array or scalar (depending on context) of customer information
 475 alignments.
 476
 477 As with L<the cust_header subroutine|/cust_header>, the fields returned are
 478 defined by the supplied customer fields setting, or if no customer fields
 479 setting is supplied, the <B>cust-fields</B> configuration value.
 480
 481 =cut
 482
 483 sub cust_aligns {
 484   if ( wantarray ) {
 485     @cust_aligns;
 486   } else {
 487     join('', @cust_aligns);
 488   }
 489 }
 490
 491 =item is_mobile
 492
 493 Utility function to determine if the client is a mobile browser.
 494
 495 =cut
 496
 497 sub is_mobile {
 498   my $ua = $ENV{'HTTP_USER_AGENT'} || '';
 499   if ( $ua =~ /(?:hiptop|Blazer|Novarra|Vagabond|SonyEricsson|Symbian|NetFront|UP.Browser|UP.Link|Windows CE|MIDP|J2ME|DoCoMo|J-PHONE|PalmOS|PalmSource|iPhone|iPod|AvantGo|Nokia|Android|WebOS|S60|Opera Mini|Opera Mobi)/io ) {
 500     return 1;
 501   }
 502   return 0;
 503 }
 504
 505 ###
 506 # begin JSRPC code...
 507 ###
 508
 509 package FS::UI::Web::JSRPC;
 510
 511 use strict;
 512 use vars qw($DEBUG);
 513 use Carp;
 514 use Storable qw(nfreeze);
 515 use MIME::Base64;
 516 use JSON;
 517 use FS::UID qw(getotaker);
 518 use FS::Record qw(qsearchs);
 519 use FS::queue;
 520 use FS::CGI qw(rooturl);
 521
 522 $DEBUG = 0;
 523
 524 sub new {
 525         my $class = shift;
 526         my $self  = {
 527                 env => {},
 528                 job => shift,
 529                 cgi => shift,
 530         };
 531
 532         bless $self, $class;
 533
 534         croak "CGI object required as second argument" unless $self->{'cgi'};
 535
 536         return $self;
 537 }
 538
 539 sub process {
 540
 541   my $self = shift;
 542
 543   my $cgi = $self->{'cgi'};
 544
 545   # XXX this should parse JSON foo and build a proper data structure
 546   my @args = $cgi->param('arg');
 547
 548   #work around konqueror bug!
 549   @args = map { s/\x00$//; $_; } @args;
 550
 551   my $sub = $cgi->param('sub'); #????
 552
 553   warn "FS::UI::Web::JSRPC::process:\n".
 554        "  cgi=$cgi\n".
 555        "  sub=$sub\n".
 556        "  args=".join(', ',@args)."\n"
 557     if $DEBUG;
 558
 559   if ( $sub eq 'start_job' ) {
 560
 561     $self->start_job(@args);
 562
 563   } elsif ( $sub eq 'job_status' ) {
 564
 565     $self->job_status(@args);
 566
 567   } else {
 568
 569     die "unknown sub $sub";
 570
 571   }
 572
 573 }
 574
 575 sub start_job {
 576   my $self = shift;
 577
 578   warn "FS::UI::Web::start_job: ". join(', ', @_) if $DEBUG;
 579 #  my %param = @_;
 580   my %param = ();
 581   while ( @_ ) {
 582     my( $field, $value ) = splice(@_, 0, 2);
 583     unless ( exists( $param{$field} ) ) {
 584       $param{$field} = $value;
 585     } elsif ( ! ref($param{$field}) ) {
 586       $param{$field} = [ $param{$field}, $value ];
 587     } else {
 588       push @{$param{$field}}, $value;
 589     }
 590   }
 591   $param{CurrentUser} = getotaker();
 592   $param{RootURL} = rooturl($self->{cgi}->self_url);
 593   warn "FS::UI::Web::start_job\n".
 594        join('', map {
 595                       if ( ref($param{$_}) ) {
 596                         "  $_ => [ ". join(', ', @{$param{$_}}). " ]\n";
 597                       } else {
 598                         "  $_ => $param{$_}\n";
 599                       }
 600                     } keys %param )
 601     if $DEBUG;
 602
 603   #first get the CGI params shipped off to a job ASAP so an id can be returned
 604   #to the caller
 605
 606   my $job = new FS::queue { 'job' => $self->{'job'} };
 607
 608   #too slow to insert all the cgi params as individual args..,?
 609   #my $error = $queue->insert('_JOB', $cgi->Vars);
 610
 611   #warn 'froze string of size '. length(nfreeze(\%param)). " for job args\n"
 612   #  if $DEBUG;
 613
 614   my $error = $job->insert( '_JOB', encode_base64(nfreeze(\%param)) );
 615
 616   if ( $error ) {
 617
 618     warn "job not inserted: $error\n"
 619       if $DEBUG;
 620
 621     $error;  #this doesn't seem to be handled well,
 622              # will trigger "illegal jobnum" below?
 623              # (should never be an error inserting the job, though, only thing
 624              #  would be Pg f%*kage)
 625   } else {
 626
 627     warn "job inserted successfully with jobnum ". $job->jobnum. "\n"
 628       if $DEBUG;
 629
 630     $job->jobnum;
 631   }
 632
 633 }
 634
 635 sub job_status {
 636   my( $self, $jobnum ) = @_; #$url ???
 637
 638   sleep 1; # XXX could use something better...
 639
 640   my $job;
 641   if ( $jobnum =~ /^(\d+)$/ ) {
 642     $job = qsearchs('queue', { 'jobnum' => $jobnum } );
 643   } else {
 644     die "FS::UI::Web::job_status: illegal jobnum $jobnum\n";
 645   }
 646
 647   my @return;
 648   if ( $job && $job->status ne 'failed' && $job->status ne 'done' ) {
 649     my ($progress, $action) = split ',', $job->statustext, 2;
 650     $action ||= 'Server processing job';
 651     @return = ( 'progress', $progress, $action );
 652   } elsif ( !$job ) { #handle job gone case : job successful
 653                       # so close popup, redirect parent window...
 654     @return = ( 'complete' );
 655   } elsif ( $job->status eq 'done' ) {
 656     @return = ( 'done', $job->statustext, '' );
 657   } else {
 658     @return = ( 'error', $job ? $job->statustext : $jobnum );
 659   }
 660
 661   #to_json(\@return);  #waiting on deb 5.0 for new JSON.pm?
 662   #silence the warning though
 663   my $to_json = JSON->can('to_json') || JSON->can('objToJson');
 664   &$to_json(\@return);
 665
 666 }
 667
 668 1;
 669