1package App::Netdisco::Util::Web; 2 3use strict; 4use warnings; 5 6use Dancer ':syntax'; 7 8use Time::Piece; 9use Time::Seconds; 10 11use base 'Exporter'; 12our @EXPORT = (); 13our @EXPORT_OK = qw/ 14 sort_port sort_modules 15 interval_to_daterange 16 sql_match 17 request_is_api 18 request_is_api_report 19 request_is_api_search 20/; 21our %EXPORT_TAGS = (all => \@EXPORT_OK); 22 23=head1 NAME 24 25App::Netdisco::Util::Web 26 27=head1 DESCRIPTION 28 29A set of helper subroutines to support parts of the Netdisco application. 30 31There are no default exports, however the C<:all> tag will export all 32subroutines. 33 34=head1 EXPORT_OK 35 36=head2 request_is_api 37 38Client has requested JSON format data and an endpoint under C</api>. 39 40=cut 41 42sub request_is_api { 43 return ((request->accept and request->accept =~ m/(?:json|javascript)/) and ( 44 index(request->path, uri_for('/api/')->path) == 0 45 or 46 (param('return_url') 47 and index(param('return_url'), uri_for('/api/')->path) == 0) 48 )); 49} 50 51=head2 request_is_api_report 52 53Same as C<request_is_api> but also requires path to start "C</api/v1/report/...>". 54 55=cut 56 57sub request_is_api_report { 58 return (request_is_api and ( 59 index(request->path, uri_for('/api/v1/report/')->path) == 0 60 or 61 (param('return_url') 62 and index(param('return_url'), uri_for('/api/v1/report/')->path) == 0) 63 )); 64} 65 66=head2 request_is_api_search 67 68Same as C<request_is_api> but also requires path to start "C</api/v1/search/...>". 69 70=cut 71 72sub request_is_api_search { 73 return (request_is_api and ( 74 index(request->path, uri_for('/api/v1/search/')->path) == 0 75 or 76 (param('return_url') 77 and index(param('return_url'), uri_for('/api/v1/search/')->path) == 0) 78 )); 79} 80 81=head2 sql_match( $value, $exact? ) 82 83Convert wildcard characters "C<*>" and "C<?>" to "C<%>" and "C<_>" 84respectively. 85 86Pass a true value to C<$exact> to only substitute the existing wildcards, and 87not also add "C<*>" to each end of the value. 88 89In list context, returns two values, the translated value, and also an 90L<SQL::Abstract> LIKE clause. 91 92=cut 93 94sub sql_match { 95 my ($text, $exact) = @_; 96 return unless $text; 97 98 $text =~ s/^\s+//; 99 $text =~ s/\s+$//; 100 101 $text =~ s/[*]+/%/g; 102 $text =~ s/[?]/_/g; 103 104 $text = '%'. $text . '%' unless $exact; 105 $text =~ s/\%+/%/g; 106 107 return ( wantarray ? ($text, {-ilike => $text}) : $text ); 108} 109 110=head2 sort_port( $a, $b ) 111 112Sort port names of various types used by device vendors. Interface is as 113Perl's own C<sort> - two input args and an integer return value. 114 115=cut 116 117sub sort_port { 118 my ($aval, $bval) = @_; 119 120 # hack for foundry "10GigabitEthernet" -> cisco-like "TenGigabitEthernet" 121 $aval = $1 if $aval =~ qr/^10(GigabitEthernet.+)$/; 122 $bval = $1 if $bval =~ qr/^10(GigabitEthernet.+)$/; 123 124 my $numbers = qr{^(\d+)$}; 125 my $numeric = qr{^([\d\.]+)$}; 126 my $dotted_numeric = qr{^(\d+)[:.](\d+)$}; 127 my $letter_number = qr{^([a-zA-Z]+)(\d+)$}; 128 my $wordcharword = qr{^([^:\/.]+)[-\ :\/\.]+([^:\/.0-9]+)(\d+)?$}; #port-channel45 129 my $netgear = qr{^Slot: (\d+) Port: (\d+) }; # "Slot: 0 Port: 15 Gigabit - Level" 130 my $ciscofast = qr{^ 131 # Word Number slash (Gigabit0/) 132 (\D+)(\d+)[\/:] 133 # Groups of symbol float (/5.5/5.5/5.5), separated by slash or colon 134 ([\/:\.\d]+) 135 # Optional dash (-Bearer Channel) 136 (-.*)? 137 $}x; 138 139 my @a = (); my @b = (); 140 141 if ($aval =~ $dotted_numeric) { 142 @a = ($1,$2); 143 } elsif ($aval =~ $letter_number) { 144 @a = ($1,$2); 145 } elsif ($aval =~ $netgear) { 146 @a = ($1,$2); 147 } elsif ($aval =~ $numbers) { 148 @a = ($1); 149 } elsif ($aval =~ $ciscofast) { 150 @a = ($1,$2); 151 push @a, split(/[:\/]/,$3), $4; 152 } elsif ($aval =~ $wordcharword) { 153 @a = ($1,$2,$3); 154 } else { 155 @a = ($aval); 156 } 157 158 if ($bval =~ $dotted_numeric) { 159 @b = ($1,$2); 160 } elsif ($bval =~ $letter_number) { 161 @b = ($1,$2); 162 } elsif ($bval =~ $netgear) { 163 @b = ($1,$2); 164 } elsif ($bval =~ $numbers) { 165 @b = ($1); 166 } elsif ($bval =~ $ciscofast) { 167 @b = ($1,$2); 168 push @b, split(/[:\/]/,$3),$4; 169 } elsif ($bval =~ $wordcharword) { 170 @b = ($1,$2,$3); 171 } else { 172 @b = ($bval); 173 } 174 175 # Equal until proven otherwise 176 my $val = 0; 177 while (scalar(@a) or scalar(@b)){ 178 # carried around from the last find. 179 last if $val != 0; 180 181 my $a1 = shift @a; 182 my $b1 = shift @b; 183 184 # A has more components - loses 185 unless (defined $b1){ 186 $val = 1; 187 last; 188 } 189 190 # A has less components - wins 191 unless (defined $a1) { 192 $val = -1; 193 last; 194 } 195 196 if ($a1 =~ $numeric and $b1 =~ $numeric){ 197 $val = $a1 <=> $b1; 198 } elsif ($a1 ne $b1) { 199 $val = $a1 cmp $b1; 200 } 201 } 202 203 return $val; 204} 205 206=head2 sort_modules( $modules ) 207 208Sort devices modules into tree hierarchy based upon position and parent - 209input arg is module list. 210 211=cut 212 213sub sort_modules { 214 my $input = shift; 215 my %modules; 216 217 foreach my $module (@$input) { 218 $modules{$module->index}{module} = $module; 219 if ($module->parent) { 220 # Example 221 # index | description | type | parent | class | pos 222 #-------+----------------------------------------+---------------------+--------+---------+----- 223 # 1 | Cisco Aironet 1200 Series Access Point | cevChassisAIRAP1210 | 0 | chassis | -1 224 # 3 | PowerPC405GP Ethernet | cevPortFEIP | 1 | port | -1 225 # 2 | 802.11G Radio | cevPortUnknown | 1 | port | 0 226 227 # Some devices do not implement correctly, so given parent 228 # can have multiple items within the same class at a single pos 229 # value. However, the database results are sorted by 1) parent 230 # 2) class 3) pos 4) index so we should just be able to push onto 231 # the array and ordering be preserved. 232 { 233 no warnings 'uninitialized'; 234 push(@{$modules{$module->parent}{children}{$module->class}}, $module->index); 235 } 236 } else { 237 push(@{$modules{root}}, $module->index); 238 } 239 } 240 return \%modules; 241} 242 243=head2 interval_to_daterange( $interval ) 244 245Takes an interval in days, weeks, months, or years in a format like '7 days' 246and returns a date range in the format 'YYYY-MM-DD to YYYY-MM-DD' by 247subtracting the interval from the current date. 248 249If C<$interval> is not passed, epoch zero (1970-01-01) is used as the start. 250 251=cut 252 253sub interval_to_daterange { 254 my $interval = shift; 255 256 unless ($interval 257 and $interval =~ m/^(?:\d+)\s+(?:day|week|month|year)s?$/) { 258 259 return "1970-01-01 to " . Time::Piece->new->ymd; 260 } 261 262 my %const = ( 263 day => ONE_DAY, 264 week => ONE_WEEK, 265 month => ONE_MONTH, 266 year => ONE_YEAR 267 ); 268 269 my ( $amt, $factor ) 270 = $interval =~ /^(\d+)\s+(day|week|month|year)s?$/gmx; 271 272 $amt-- if $factor eq 'day'; 273 274 my $start = Time::Piece->new - $const{$factor} * $amt; 275 276 return $start->ymd . " to " . Time::Piece->new->ymd; 277} 278 2791; 280