|
| 1 | +package ModProxyCluster; |
| 2 | + |
| 3 | +use v5.32; |
| 4 | + |
| 5 | +require Exporter; |
| 6 | +use HTTP::Request; |
| 7 | +use HTTP::Request::Common; |
| 8 | +use LWP::UserAgent; |
| 9 | + |
| 10 | +our @ISA = qw(Exporter); |
| 11 | + |
| 12 | +our @EXPORT = qw( |
| 13 | + CMD |
| 14 | + parse_params |
| 15 | + parse_response |
| 16 | +); |
| 17 | + |
| 18 | +our $VERSION = '0.0.1'; |
| 19 | + |
| 20 | +sub CMD_internal { |
| 21 | + my ($cmd, $url, $params) = @_; |
| 22 | + my $header = []; |
| 23 | + |
| 24 | + my $ua = LWP::UserAgent->new(); |
| 25 | + my $request = HTTP::Request->new($cmd, $url, $header, $params); |
| 26 | + |
| 27 | + return $ua->request($request); |
| 28 | +} |
| 29 | + |
| 30 | +sub concat_params { |
| 31 | + my (%params) = @_; |
| 32 | + my $p = ""; |
| 33 | + my $d = ""; |
| 34 | + |
| 35 | + foreach my $k (sort(keys %params)) { |
| 36 | + if ($params{$k}) { |
| 37 | + $p .= $d . $k . '=' . $params{$k}; |
| 38 | + $d = "&"; |
| 39 | + } |
| 40 | + } |
| 41 | + |
| 42 | + return $p; |
| 43 | +} |
| 44 | + |
| 45 | +sub parse_two_layers { |
| 46 | + my ($d1, $d2, $string) = @_; |
| 47 | + |
| 48 | + my %params; |
| 49 | + for my $pair (split $d1, $string) { |
| 50 | + my ($key, $val) = split $d2, $pair; |
| 51 | + # Needed because of the leading whitespace before Type field in DUMP/node... |
| 52 | + # TODO: Remove this after we fix the issue... |
| 53 | + (my $fixkey = $key) =~ s/\s+//g; |
| 54 | + $params{$fixkey} = $val; |
| 55 | + } |
| 56 | + |
| 57 | + return %params; |
| 58 | + |
| 59 | +} |
| 60 | + |
| 61 | +sub parse_params { |
| 62 | + return parse_two_layers '&', '=', @_; |
| 63 | +} |
| 64 | + |
| 65 | +sub parse_INFO { |
| 66 | + my $input = shift; |
| 67 | + my @lines = split '\n', $input; |
| 68 | + my (@nodes, @hosts, @contexts); |
| 69 | + |
| 70 | + my $line = ""; |
| 71 | + my $i = 0; |
| 72 | + for (; $i < @lines; $i++) { |
| 73 | + $line = $lines[$i]; |
| 74 | + if ($line !~ m/Node:/) { |
| 75 | + last; |
| 76 | + } |
| 77 | + my %node = parse_two_layers ',', ': ', $line; |
| 78 | + push @nodes, \%node; |
| 79 | + } |
| 80 | + |
| 81 | + for (; $i < @lines; $i++) { |
| 82 | + $line = $lines[$i]; |
| 83 | + if ($line !~ m/Vhost:/) { |
| 84 | + last; |
| 85 | + } |
| 86 | + my %host = parse_two_layers ',', ': ', $line; |
| 87 | + push @hosts, \%host; |
| 88 | + } |
| 89 | + |
| 90 | + for (; $i < @lines; $i++) { |
| 91 | + $line = $lines[$i]; |
| 92 | + if ($line !~ m/Context:/) { |
| 93 | + last; |
| 94 | + } |
| 95 | + my %context = parse_two_layers ',', ': ', $line; |
| 96 | + push @contexts, \%context; |
| 97 | + } |
| 98 | + |
| 99 | + # Check that everything was parsed |
| 100 | + return () if $i != @lines; |
| 101 | + return (Nodes => \@nodes, Hosts => \@hosts, Contexts => \@contexts ); |
| 102 | +} |
| 103 | + |
| 104 | +sub parse_DUMP { |
| 105 | + my $input = shift; |
| 106 | + my @lines = split '\n', $input; |
| 107 | + my (@balancers, @nodes, @hosts, @contexts); |
| 108 | + |
| 109 | + my $line = ""; |
| 110 | + my $i = 0; |
| 111 | + for (; $i < @lines; $i++) { |
| 112 | + $line = $lines[$i]; |
| 113 | + if ($line !~ m/^balancer:/) { |
| 114 | + last |
| 115 | + } |
| 116 | + (my $b = $line) =~ s/: /=/g; |
| 117 | + $b =~ s/\[([^\]]*)\]\/\[([^\]]*)\]/Cookie=$1 Path=$2/; |
| 118 | + my %balancer = parse_two_layers ' ', '=', $b; |
| 119 | + push @balancers, \%balancer; |
| 120 | + } |
| 121 | + |
| 122 | + for (; $i < @lines; $i++) { |
| 123 | + $line = $lines[$i]; |
| 124 | + if ($line !~ m/^node:/) { |
| 125 | + last; |
| 126 | + } |
| 127 | + (my $n = $line) =~ s/LBGroup: \[([^\]]*)\]/LBGroup: $1/; |
| 128 | + my %node = parse_two_layers ',', ': ', $n; |
| 129 | + push @nodes, \%node; |
| 130 | + } |
| 131 | + |
| 132 | + for (; $i < @lines; $i++) { |
| 133 | + $line = $lines[$i]; |
| 134 | + if ($line !~ m/^host:/) { |
| 135 | + last; |
| 136 | + } |
| 137 | + (my $h = $line) =~ s/: /=/g; |
| 138 | + $h =~ s/\[([^\]]*)\]/alias=$1/; |
| 139 | + my %host = parse_two_layers ' ', '=', $h; |
| 140 | + push @hosts, \%host; |
| 141 | + } |
| 142 | + |
| 143 | + |
| 144 | + for (; $i < @lines; $i++) { |
| 145 | + $line = $lines[$i]; |
| 146 | + if ($line !~ m/^context:/) { |
| 147 | + last; |
| 148 | + } |
| 149 | + (my $c = $line) =~ s/: /=/g; |
| 150 | + $c =~ s/\[([^\]]*)\]/path=$1/; |
| 151 | + my %context = parse_two_layers ' ', '=', $c; |
| 152 | + push @contexts, \%context; |
| 153 | + } |
| 154 | + |
| 155 | + # Check that the whole input was consumed! |
| 156 | + return () if $i != @lines; |
| 157 | + return ( Balancers => \@balancers, Nodes => \@nodes, Hosts => \@hosts, Contexts => \@contexts ); |
| 158 | +} |
| 159 | + |
| 160 | +sub CMD { |
| 161 | + my ($cmd, $url, %params) = @_; |
| 162 | + my @mpc_commands = qw(CONFIG ENABLE-APP DISABLE-APP STOP-APP REMOVE-APP STOP-APP-RSP |
| 163 | + STATUS STATUS-RSP INFO INFO-RSP DUMP DUMP-RSP PING PING-RSP); |
| 164 | + |
| 165 | + if (grep /^$cmd$/, @mpc_commands) { |
| 166 | + return CMD_internal $cmd, $url, concat_params %params; |
| 167 | + } |
| 168 | + |
| 169 | + return HTTP::Response->new(); |
| 170 | +} |
| 171 | + |
| 172 | +sub parse_response { |
| 173 | + my ($cmd, $resp) = @_; |
| 174 | + |
| 175 | + if ($cmd eq 'CONFIG') { |
| 176 | + return parse_params $resp; |
| 177 | + } elsif ($cmd eq 'DUMP') { |
| 178 | + return parse_DUMP $resp; |
| 179 | + } elsif ($cmd eq 'INFO') { |
| 180 | + return parse_INFO $resp; |
| 181 | + } elsif ($cmd eq 'STATUS') { |
| 182 | + return parse_params $resp; |
| 183 | + } elsif ($cmd eq 'PING') { |
| 184 | + return parse_params $resp; |
| 185 | + } elsif ($cmd eq 'STOP-APP') { |
| 186 | + return parse_params $resp; |
| 187 | + } |
| 188 | + |
| 189 | + return {}; |
| 190 | +} |
| 191 | + |
| 192 | + |
| 193 | +1; |
| 194 | + |
0 commit comments