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