FS/FS/svc_port.pm

   1 package FS::svc_port;
   2
   3 use strict;
   4 use vars qw($conf $system $DEBUG $me );
   5 use base qw( FS::svc_Common );
   6 use List::Util qw(max);
   7 use Date::Format qw(time2str);
   8 use Data::Dumper;
   9 use GD;
  10 use GD::Graph;
  11 use GD::Graph::mixed;
  12 use FS::UID qw( driver_name );
  13 use FS::Record qw( qsearch qsearchs
  14                    str2time_sql str2time_sql_closing concat_sql );
  15 use FS::cust_svc;
  16
  17 $DEBUG = 1;
  18 $me = '[FS::svc_port]';
  19
  20 FS::UID->install_callback( sub {
  21   $conf = new FS::Conf;
  22   $system = $conf->config('network_monitoring_system');
  23 } );
  24
  25 =head1 NAME
  26
  27 FS::svc_port - Object methods for svc_port records
  28
  29 =head1 SYNOPSIS
  30
  31   use FS::svc_port;
  32
  33   $record = new FS::svc_port \%hash;
  34   $record = new FS::svc_port { 'column' => 'value' };
  35
  36   $error = $record->insert;
  37
  38   $error = $new_record->replace($old_record);
  39
  40   $error = $record->delete;
  41
  42   $error = $record->check;
  43
  44   $error = $record->suspend;
  45
  46   $error = $record->unsuspend;
  47
  48   $error = $record->cancel;
  49
  50 =head1 DESCRIPTION
  51
  52 An FS::svc_port object represents a router port.  FS::table_name inherits from
  53 FS::svc_Common.  The following fields are currently supported:
  54
  55 =over 4
  56
  57 =item svcnum -
  58
  59 =item serviceid - Torrus serviceid (in srvexport and reportfields tables)
  60
  61 =back
  62
  63 =head1 METHODS
  64
  65 =over 4
  66
  67 =item new HASHREF
  68
  69 Creates a new port.  To add the port to the database, see L<"insert">.
  70
  71 Note that this stores the hash reference, not a distinct copy of the hash it
  72 points to.  You can ask the object for a copy with the I<hash> method.
  73
  74 =cut
  75
  76 sub table { 'svc_port'; }
  77
  78 sub table_info {
  79   {
  80     'name' => 'Port',
  81     #'name_plural' => 'Ports', #optional,
  82     #'longname_plural' => 'Ports', #optional
  83     #'sorts' => [ 'svcnum', 'serviceid' ], # optional sort field (or arrayref of sort fields, main first)
  84     'sorts' => [ 'serviceid' ], # optional sort field (or arrayref of sort fields, main first)
  85     'display_weight' => 75,
  86     'cancel_weight'  => 10,
  87     'fields' => {
  88       'svcnum'    => 'Service',
  89       'serviceid' => 'Torrus serviceid',
  90     },
  91   };
  92 }
  93
  94 =item search_sql STRING
  95
  96 Class method which returns an SQL fragment to search for the given string.
  97
  98 =cut
  99
 100 #or something more complicated if necessary
 101 sub search_sql {
 102   my($class, $string) = @_;
 103   $class->search_sql_field('serviceid', $string);
 104 }
 105
 106 =item label
 107
 108 Returns a meaningful identifier for this port
 109
 110 =cut
 111
 112 sub label {
 113   my $self = shift;
 114   $self->serviceid; #or something more complicated if necessary
 115 }
 116
 117 =item insert
 118
 119 Adds this record to the database.  If there is an error, returns the error,
 120 otherwise returns false.
 121
 122 The additional fields pkgnum and svcpart (see L<FS::cust_svc>) should be
 123 defined.  An FS::cust_svc record will be created and inserted.
 124
 125 =cut
 126
 127 sub insert {
 128   my $self = shift;
 129   my $error;
 130
 131   $error = $self->SUPER::insert;
 132   return $error if $error;
 133
 134   '';
 135 }
 136
 137 =item delete
 138
 139 Delete this record from the database.
 140
 141 =cut
 142
 143 sub delete {
 144   my $self = shift;
 145   my $error;
 146
 147   $error = $self->SUPER::delete;
 148   return $error if $error;
 149
 150   '';
 151 }
 152
 153
 154 =item replace OLD_RECORD
 155
 156 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 157 returns the error, otherwise returns false.
 158
 159 =cut
 160
 161 sub replace {
 162   my ( $new, $old ) = ( shift, shift );
 163   my $error;
 164
 165   $error = $new->SUPER::replace($old);
 166   return $error if $error;
 167
 168   '';
 169 }
 170
 171 =item suspend
 172
 173 Called by the suspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 174
 175 =item unsuspend
 176
 177 Called by the unsuspend method of FS::cust_pkg (see L<FS::cust_pkg>).
 178
 179 =item cancel
 180
 181 Called by the cancel method of FS::cust_pkg (see L<FS::cust_pkg>).
 182
 183 =item check
 184
 185 Checks all fields to make sure this is a valid port.  If there is
 186 an error, returns the error, otherwise returns false.  Called by the insert
 187 and repalce methods.
 188
 189 =cut
 190
 191 sub check {
 192   my $self = shift;
 193
 194   my $x = $self->setfixed;
 195   return $x unless ref($x);
 196   my $part_svc = $x;
 197
 198   my $error = $self->ut_textn('serviceid'); #too lenient?
 199   return $error if $error;
 200
 201   $self->SUPER::check;
 202 }
 203
 204 =item graph_png
 205
 206 Returns a PNG graph for this port.
 207
 208 The following options must be specified:
 209
 210 =over 4
 211
 212 =item start
 213 =item end
 214
 215 =back
 216
 217 =cut
 218
 219 sub _format_bandwidth {
 220     my $self = shift;
 221     my $value = shift;
 222     my $space = shift;
 223     $space = ' ' if $space;
 224
 225     my $suffix = '';
 226
 227     warn "$me _format_bandwidth $value" if $DEBUG > 1;
 228
 229     if ( $value >= 1000 && $value < 1000000 ) {
 230         $value = ($value/1000);
 231         $suffix = $space. "k";
 232     }
 233     elsif( $value >= 1000000 && $value < 1000000000 ) {
 234         $value = ($value/1000/1000);
 235         $suffix = $space . "M";
 236     }
 237     elsif( $value >= 1000000000 && $value < 1000000000000 ) {
 238         $value = ($value/1000/1000/1000);
 239         $suffix = $space . "G";
 240     }
 241     # and hopefully we don't have folks doing Tbps on a single port :)
 242
 243     $value = sprintf("%6.2f$suffix",$value) if $value >= 0;
 244
 245     $value;
 246 }
 247
 248 sub _percentile {
 249   my $self = shift;
 250   my @values = sort { $a <=> $b } @{$_[0]};
 251   $values[ int(.95 * $#values) ];
 252 }
 253
 254 sub graph_png {
 255   my($self, %opt) = @_;
 256   my $serviceid = $self->serviceid;
 257
 258   return '' unless $serviceid && $system eq 'Torrus_Internal'; #empty/error png?
 259
 260   my $start = -1;
 261   my $end = -1;
 262   my $now = time;
 263
 264   $start = $opt{start} if $opt{start};
 265   $end = $opt{end} if $opt{end};
 266
 267         $end = $now if $end > $now;
 268
 269   return 'Invalid date range' if ($start < 0 || $start >= $end
 270       || $end <= $start || $end < 0 || $end > $now || $start > $now
 271       || $end-$start > 86400*366 );
 272
 273   my $_date = concat_sql([ 'srv_date', "' '", 'srv_time' ]);
 274   $_date = "CAST( $_date AS TIMESTAMP )" if driver_name =~ /^Pg/i;
 275   $_date = str2time_sql. $_date.  str2time_sql_closing;
 276
 277   my $serviceid_sql = "('${serviceid}_IN','${serviceid}_OUT')";
 278
 279   local($FS::Record::nowarn_classload) = 1;
 280   my @records = qsearch({
 281     'table'     => 'srvexport',
 282     'select'    => "*, $_date as _date",
 283     'extra_sql' => "where serviceid in $serviceid_sql
 284                       and $_date >= $start
 285                       and $_date <= $end",
 286     'order_by'  => "order by $_date asc",
 287   });
 288
 289   if ( ! scalar(@records) ) {
 290     warn "$me no records returned for $serviceid\n";
 291     return ''; #should actually return a blank png (or, even better, the
 292                # error message in the image)
 293   }
 294
 295   warn "$me ". scalar(@records). " records returned for $serviceid\n"
 296     if $DEBUG;
 297
 298   # assume data in DB is correct,
 299   # assume always _IN and _OUT pair, assume intvl = 300
 300
 301   my @times;
 302   my @in;
 303   my @out;
 304   foreach my $rec ( @records ) {
 305       push @times, $rec->_date
 306           unless grep { $_ eq $rec->_date } @times;
 307       push @in, $rec->value*8 if $rec->serviceid =~ /_IN$/;
 308       push @out, $rec->value*8 if $rec->serviceid =~ /_OUT$/;
 309   }
 310
 311   my $timediff = $times[-1] - $times[0]; # they're sorted ascending
 312
 313   my $y_min = 999999999999; # ~1Tbps
 314   my $y_max = 0;
 315   my $in_sum = 0;
 316   my $out_sum = 0;
 317   my $in_min = 999999999999;
 318   my $in_max = 0;
 319   my $out_min = 999999999999;
 320   my $out_max = 0;
 321   foreach my $in ( @in ) {
 322       $y_max = $in if $in > $y_max;
 323       $y_min = $in if $in < $y_min;
 324       $in_sum += $in;
 325       $in_max = $in if $in > $in_max;
 326       $in_min = $in if $in < $in_min;
 327   }
 328   foreach my $out ( @out ) {
 329       $y_max = $out if $out > $y_max;
 330       $y_min = $out if $out < $y_min;
 331       $out_sum += $out;
 332       $out_max = $out if $out > $out_max;
 333       $out_min = $out if $out < $out_min;
 334   }
 335   my $bwdiff = $y_max - $y_min;
 336   $in_min = $self->_format_bandwidth($in_min);
 337   $out_min = $self->_format_bandwidth($out_min);
 338   $in_max = $self->_format_bandwidth($in_max);
 339   $out_max = $self->_format_bandwidth($out_max);
 340   my $in_curr = $self->_format_bandwidth($in[-1]);
 341   my $out_curr = $self->_format_bandwidth($out[-1]);
 342   my $numsamples = scalar(@records)/2;
 343   my $in_avg = $self->_format_bandwidth($in_sum/$numsamples);
 344   my $out_avg = $self->_format_bandwidth($out_sum/$numsamples);
 345
 346   my $percentile = max( $self->_percentile(\@in), $self->_percentile(\@out) );
 347   my @percentile = map $percentile, @in;
 348   $percentile = $self->_format_bandwidth($percentile); #for below
 349
 350   warn "$me timediff=$timediff bwdiff=$bwdiff start=$start end=$end ".
 351        "in_min=$in_min out_min=$out_min in_max=$in_max ".
 352        "out_max=$out_max in_avg=$in_avg out_avg=$out_avg ".
 353        "percentile=$percentile ".
 354        " # records = " . scalar(@records) . "\n\ntimes:\n".
 355        Dumper(@times) . "\n\nin:\n" . Dumper(@in) . "\n\nout:\n". Dumper(@out)
 356     if $DEBUG > 1;
 357
 358   my @data = ( \@times, \@in, \@out, \@percentile );
 359
 360
 361   # hardcoded size, colour, etc.
 362
 363   #don't change width/height other than through here; breaks legend otherwise
 364   my $width = 600;
 365   my $height = 360;
 366
 367   my $graph = new GD::Graph::mixed($width,$height);
 368   $graph->set(
 369     types => ['area','lines','lines'],
 370     dclrs => ['green','blue','red',],
 371     x_label => '   ',
 372     x_tick_number => 'auto',
 373     x_number_format => sub {
 374         my $value = shift;
 375         if ( $timediff < 86401 ) { # one day
 376             $value = time2str("%a %H:%M",$value)
 377         } elsif ( $timediff < 86401*7 ) { # one week
 378             $value = time2str("%d",$value)
 379         } elsif ( $timediff < 86401*30 ) { # one month
 380             $value = time2str("Week %U",$value)
 381         } elsif ( $timediff < 86401*366 ) { # one year
 382             $value = time2str("%b",$value)
 383         }
 384         $value;
 385     },
 386     y_number_format => sub {
 387         my $value = shift;
 388         $self->_format_bandwidth($value,1);
 389     },
 390         y_tick_number => 'auto',
 391     y_label => 'bps',
 392     legend_placement => 'BR',
 393         lg_cols => 1,
 394     title => $self->serviceid,
 395   ) or return "can't create graph: ".$graph->error;
 396
 397   $graph->set_text_clr('black')
 398     or return "can't set text colour: ".$graph->error;
 399   $graph->set_legend(('In','Out','95th'))
 400     or return "can't set legend: ".$graph->error;
 401   $graph->set_title_font(['verdana', 'arial', gdGiantFont], 16)
 402         or return "can't set title font: ".$graph->error;
 403   $graph->set_legend_font(['verdana', 'arial', gdMediumBoldFont], 12)
 404         or return "can't set legend font: ".$graph->error;
 405   $graph->set_x_axis_font(['verdana', 'arial', gdMediumBoldFont], 12)
 406         or return "can't set font: ".$graph->error;
 407   $graph->set_y_axis_font(['verdana', 'arial', gdMediumBoldFont], 12)
 408         or return "can't set font: ".$graph->error;
 409   $graph->set_y_label_font(['verdana', 'arial', gdMediumBoldFont], 12)
 410         or return "can't set font: ".$graph->error;
 411
 412   my $gd = $graph->plot(\@data);
 413   return "graph error: ".$graph->error unless($gd);
 414
 415   my $black = $gd->colorAllocate(0,0,0);
 416   $gd->string(gdMediumBoldFont,50,$height-55,
 417     "Current:$in_curr   Average:$in_avg   Maximum:$in_max   Minimum:$in_min",$black);
 418   $gd->string(gdMediumBoldFont,50,$height-35,
 419     "Current:$out_curr   Average:$out_avg   Maximum:$out_max   Minimum:$out_min",$black);
 420   $gd->string(gdMediumBoldFont,50,$height-15,
 421     "95th percentile:$percentile", $black);
 422
 423   return $gd->png;
 424 }
 425
 426 =back
 427
 428 =head1 BUGS
 429
 430 =head1 SEE ALSO
 431
 432 L<FS::svc_Common>, L<FS::Record>, L<FS::cust_svc>, L<FS::part_svc>,
 433 L<FS::cust_pkg>, schema.html from the base documentation.
 434
 435 =cut
 436
 437 1;
 438