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