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