line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Apache::SdnFw; |
2
|
|
|
|
|
|
|
|
3
|
1
|
|
|
1
|
|
29648
|
use strict; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
42
|
|
4
|
1
|
|
|
1
|
|
5
|
use Carp; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
98
|
|
5
|
1
|
|
|
1
|
|
495
|
use Apache; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
use Apache::Constants qw(:common :response :http); |
7
|
|
|
|
|
|
|
use Compress::Zlib 1.0; |
8
|
|
|
|
|
|
|
use Time::HiRes qw(time); |
9
|
|
|
|
|
|
|
use Date::Format; |
10
|
|
|
|
|
|
|
use Apache::SdnFw::lib::Core; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.92'; |
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub handler { |
15
|
|
|
|
|
|
|
my $r = shift; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
# our goal here is to facilitate handing off to the main |
18
|
|
|
|
|
|
|
# system processor with some basic information |
19
|
|
|
|
|
|
|
# which will then return a very structured data object |
20
|
|
|
|
|
|
|
# back, which we will then dump back out to the client |
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
my %options; |
23
|
|
|
|
|
|
|
$options{uri} = $r->uri(); |
24
|
|
|
|
|
|
|
$options{args} = $r->args(); |
25
|
|
|
|
|
|
|
$options{remote_addr} = $r->get_remote_host(); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my %headers = $r->headers_in(); |
28
|
|
|
|
|
|
|
if ($headers{Cookie}) { |
29
|
|
|
|
|
|
|
foreach my $kv (split '; ', $headers{Cookie}) { |
30
|
|
|
|
|
|
|
my ($k,$v) = split '=', $kv; |
31
|
|
|
|
|
|
|
$options{cookies}{$k} = $v; |
32
|
|
|
|
|
|
|
} |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
$options{server_name} = $headers{Host}; |
35
|
|
|
|
|
|
|
$options{server_name} =~ s/^www\.//; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# pull in some other information |
38
|
|
|
|
|
|
|
foreach my $key (qw( |
39
|
|
|
|
|
|
|
HTTPS HTTPD_ROOT HTTP_COOKIE HTTP_REFERER HTTP_USER_AGENT DB_STRING |
40
|
|
|
|
|
|
|
DB_USER BASE_URL DOCUMENT_ROOT REQUEST_METHOD QUERY_STRING HIDE_PERMISSION |
41
|
|
|
|
|
|
|
GOOGLE_MAPS_KEY DEV FORCE_HTTPS GAUTH GUSER IP_LOGIN TITLE IPHONE DBDEBUG |
42
|
|
|
|
|
|
|
OBJECT_BASE CONTENT_LENGTH CONTENT_TYPE APACHE_SERVER_NAME IP_ADDR ETERNAL_COOKIE |
43
|
|
|
|
|
|
|
CRYPT_KEY)) { |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
$options{env}{$key} = ($r->dir_config($key) or $r->subprocess_env->{$key}); |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# get incoming parameters (black box function) |
49
|
|
|
|
|
|
|
get_params($r,\%options); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
# kill some shit |
52
|
|
|
|
|
|
|
foreach my $k (qw(__EVENTARGUMENT __EVENTVALIDATION __VIEWSTATE __EVENTTARGET)) { |
53
|
|
|
|
|
|
|
delete $options{in}{$k}; |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
# what content type do we want back? (default to text/html) |
57
|
|
|
|
|
|
|
$options{content_type} = $options{in}{c} || 'text/html'; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
# try and get a Core object and pass this information to it |
60
|
|
|
|
|
|
|
# setup our database debug output file |
61
|
|
|
|
|
|
|
if ($options{env}{DBDEBUG}) { |
62
|
|
|
|
|
|
|
_start_dbdebug(\%options); |
63
|
|
|
|
|
|
|
} |
64
|
|
|
|
|
|
|
|
65
|
|
|
|
|
|
|
my $s; |
66
|
|
|
|
|
|
|
eval { |
67
|
|
|
|
|
|
|
$s = Apache::SdnFw::lib::Core->new(%options); |
68
|
|
|
|
|
|
|
$s->process(); |
69
|
|
|
|
|
|
|
#croak "test".Data::Dumper->Dump([$s]); |
70
|
|
|
|
|
|
|
}; |
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
if ($options{env}{DBDEBUG}) { |
73
|
|
|
|
|
|
|
_end_dbdebug($s); |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# so from all that happens below here is what $s->{r} should have |
77
|
|
|
|
|
|
|
# error => , |
78
|
|
|
|
|
|
|
# redirect => , |
79
|
|
|
|
|
|
|
# return_code => , |
80
|
|
|
|
|
|
|
# set_cookie => [ array ], |
81
|
|
|
|
|
|
|
# filename => , |
82
|
|
|
|
|
|
|
# file_path => , |
83
|
|
|
|
|
|
|
# content => , |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
if ($@) { |
86
|
|
|
|
|
|
|
$s->{dbh}->rollback if (defined($s->{dbh}));; |
87
|
|
|
|
|
|
|
return error($r,"Eval Error: $@"); |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
unless(ref $s->{r} eq "HASH") { |
91
|
|
|
|
|
|
|
return error($r,"r hash not returned by core"); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
if ($s->{r}{error}) { |
95
|
|
|
|
|
|
|
return error($r,"Process Error: $s->{r}{error}"); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
if ($s->{r}{redirect}) { |
99
|
|
|
|
|
|
|
$r->header_out('Location' => $s->{r}{redirect}); |
100
|
|
|
|
|
|
|
return MOVED; |
101
|
|
|
|
|
|
|
} |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
#if ($s->{r}{remote_user}) { |
104
|
|
|
|
|
|
|
# $r->subprocess_env(REMOTE_USER => $s->{r}{remote_user}); |
105
|
|
|
|
|
|
|
$r->subprocess_env(USER_ID => $s->{r}{log_user}); |
106
|
|
|
|
|
|
|
$r->subprocess_env(LOCATION_ID => $s->{r}{log_location}); |
107
|
|
|
|
|
|
|
#} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
if ($s->{r}{return_code}) { |
110
|
|
|
|
|
|
|
return NOT_FOUND if ($s->{r}{return_code} eq "NOT_FOUND"); |
111
|
|
|
|
|
|
|
return FORBIDDEN if ($s->{r}{return_code} eq "FORBIDDEN"); |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
# unknown return code |
114
|
|
|
|
|
|
|
return error($r,"Unknown return_code: $s->{r}{return_code}"); |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
# add cookies |
118
|
|
|
|
|
|
|
foreach my $cookie (@{$s->{r}{set_cookie}}) { |
119
|
|
|
|
|
|
|
$r->err_headers_out->add('Set-Cookie' => $cookie); |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
|
|
|
|
|
|
#return error($r,"Missing content_type") unless($s->{r}{content_type}); |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# compress the data? |
125
|
|
|
|
|
|
|
my $gzip = $r->header_in('Accept-Encoding') =~ /gzip/; |
126
|
|
|
|
|
|
|
if ($gzip && !$s->{r}{file_path}) { |
127
|
|
|
|
|
|
|
if ($r->protocol =~ /1\.1/) { |
128
|
|
|
|
|
|
|
my %vary = map {$_,1} qw(Accept-Encoding User-Agent); |
129
|
|
|
|
|
|
|
if (my @vary = $r->header_out('Vary')) { |
130
|
|
|
|
|
|
|
@vary{@vary} = (); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
$r->header_out('Vary' => join ',', keys %vary); |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
$r->content_encoding('gzip'); |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
$r->content_type($s->{r}{content_type}); |
138
|
|
|
|
|
|
|
$r->headers_out->add('Content-Disposition' => "filename=$s->{r}{filename}") |
139
|
|
|
|
|
|
|
if ($s->{r}{filename}); |
140
|
|
|
|
|
|
|
|
141
|
|
|
|
|
|
|
if (defined($s->{r}{headers})) { |
142
|
|
|
|
|
|
|
foreach my $k (keys %{$s->{r}{headers}}) { |
143
|
|
|
|
|
|
|
$r->headers_out->add($k => $s->{r}{headers}{$k}); |
144
|
|
|
|
|
|
|
} |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
$r->send_http_header; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
if ($s->{r}{file_path}) { |
150
|
|
|
|
|
|
|
# send a raw file |
151
|
|
|
|
|
|
|
open(FILE, $s->{r}{file_path}); |
152
|
|
|
|
|
|
|
$r->send_fd( \*FILE ); |
153
|
|
|
|
|
|
|
close(FILE); |
154
|
|
|
|
|
|
|
} else { |
155
|
|
|
|
|
|
|
# or just send back content |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
wrap_template($s) if ($s->{r}{content_type} eq 'text/html' && !$s->{raw_html}); |
158
|
|
|
|
|
|
|
|
159
|
|
|
|
|
|
|
if ($s->{save_static}) { |
160
|
|
|
|
|
|
|
my $fname = "$s->{object}_$s->{function}.html"; |
161
|
|
|
|
|
|
|
open F, ">/data/$s->{obase}/content/$fname"; |
162
|
|
|
|
|
|
|
print F $s->{r}{content}; |
163
|
|
|
|
|
|
|
close F; |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
if ($gzip) { |
167
|
|
|
|
|
|
|
$r->print(Compress::Zlib::memGzip($s->{r}{content})); |
168
|
|
|
|
|
|
|
} else { |
169
|
|
|
|
|
|
|
$r->print($s->{r}{content}); |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
|
174
|
|
|
|
|
|
|
return HTTP_OK; |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub wrap_template { |
178
|
|
|
|
|
|
|
my $s = shift; |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
my $favicon = qq() |
181
|
|
|
|
|
|
|
if (-e "/data/$s->{obase}/content/favicon.ico"); |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
$s->{r}{content} = <
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
$favicon |
189
|
|
|
|
|
|
|
$s->{r}{head} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
{r}{body}> |
192
|
|
|
|
|
|
|
$s->{r}{content} |
193
|
|
|
|
|
|
|
|
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
END |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
sub _start_dbdebug { |
200
|
|
|
|
|
|
|
my $options = shift; |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
$options->{dbdbst} = time; |
203
|
|
|
|
|
|
|
$options->{dbdbdata} = "!!!$options->{dbdbst}|$options->{uri}\t"; |
204
|
|
|
|
|
|
|
} |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
sub _end_dbdebug { |
207
|
|
|
|
|
|
|
my $s = shift; |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
my $elapse = sprintf "%.4f", time-$s->{dbdbst}; |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
$s->{dbdbdata} .= "###($elapse)"; |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
my $sock = IO::Socket::INET->new( |
214
|
|
|
|
|
|
|
PeerAddr => '127.0.0.1', |
215
|
|
|
|
|
|
|
PeerPort => 11271, |
216
|
|
|
|
|
|
|
Proto => 'udp', |
217
|
|
|
|
|
|
|
Blocking => 0, |
218
|
|
|
|
|
|
|
); |
219
|
|
|
|
|
|
|
|
220
|
|
|
|
|
|
|
print $sock $s->{dbdbdata}; |
221
|
|
|
|
|
|
|
$sock->close(); |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub error { |
225
|
|
|
|
|
|
|
my $r = shift; |
226
|
|
|
|
|
|
|
my $msg = shift; |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# TODO: Dump out the message somewhere |
229
|
|
|
|
|
|
|
# about where this error occured |
230
|
|
|
|
|
|
|
|
231
|
|
|
|
|
|
|
# for now just print the crap that comes back |
232
|
|
|
|
|
|
|
#$r->content_type('text/plain'); |
233
|
|
|
|
|
|
|
#$r->send_http_header; |
234
|
|
|
|
|
|
|
$r->print($msg); |
235
|
|
|
|
|
|
|
|
236
|
|
|
|
|
|
|
return HTTP_OK; |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub get_params { |
240
|
|
|
|
|
|
|
my $r = shift; |
241
|
|
|
|
|
|
|
my $o = shift; |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
my $input; |
244
|
|
|
|
|
|
|
if ($o->{env}{REQUEST_METHOD} ne "GET") { |
245
|
|
|
|
|
|
|
my $buffer; |
246
|
|
|
|
|
|
|
while (my $ret = $r->read_client_block($buffer,2048)) { |
247
|
|
|
|
|
|
|
$input .= substr($buffer,0,$ret); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
$o->{raw_input} = $input; |
250
|
|
|
|
|
|
|
if ($o->{env}{CONTENT_TYPE} =~ /^multipart\/form-data/) { |
251
|
|
|
|
|
|
|
my (@pairs,$boundary,$part); |
252
|
|
|
|
|
|
|
($boundary = $o->{env}{CONTENT_TYPE}) =~ s/^.*boundary=(.*)$/$1/; |
253
|
|
|
|
|
|
|
@pairs = split(/--$boundary/, $input); |
254
|
|
|
|
|
|
|
@pairs = splice(@pairs,1,$#pairs-1); |
255
|
|
|
|
|
|
|
for $part (@pairs) { |
256
|
|
|
|
|
|
|
$part =~ s/[\r]\n$//g; |
257
|
|
|
|
|
|
|
my ($blankline,$name,$currentColumn); |
258
|
|
|
|
|
|
|
my ($dump, $firstline, $datas) = split(/[\r]\n/, $part, 3); |
259
|
|
|
|
|
|
|
next if $firstline =~ /filename=\"\"/; |
260
|
|
|
|
|
|
|
# ignore stuff that starts with _raw: |
261
|
|
|
|
|
|
|
next if ($datas =~ m/^_raw:/i); |
262
|
|
|
|
|
|
|
$firstline =~ s/^Content-Disposition: form-data; //; |
263
|
|
|
|
|
|
|
my (@columns) = split(/;\s+/, $firstline); |
264
|
|
|
|
|
|
|
($name = $columns[0]) =~ s/^name="([^"]+)"$/$1/g; |
265
|
|
|
|
|
|
|
if ($#columns > 0) { |
266
|
|
|
|
|
|
|
if ($datas =~ /^Content-Type:/) { |
267
|
|
|
|
|
|
|
($o->{in}{$name}{'Content-Type'}, $blankline, $datas) = split(/[\r]\n/, $datas, 3); |
268
|
|
|
|
|
|
|
$o->{in}{$name}{'Content-Type'} =~ s/^Content-Type: ([^\s]+)$/$1/g; |
269
|
|
|
|
|
|
|
} else { |
270
|
|
|
|
|
|
|
($blankline, $datas) = split(/[\r]\n/, $datas, 2); |
271
|
|
|
|
|
|
|
$o->{in}{$name}{'Content-Type'} = "application/octet-stream"; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
} else { |
274
|
|
|
|
|
|
|
($blankline, $datas) = split(/[\r]\n/, $datas, 2); |
275
|
|
|
|
|
|
|
if (grep(/^$name$/, keys(%{$o->{in}}))) { |
276
|
|
|
|
|
|
|
if (exists($o->{in}{$name}) && (ref($$o{in}{$name}) eq 'ARRAY')) { |
277
|
|
|
|
|
|
|
push(@{$o->{in}{$name}}, $datas); |
278
|
|
|
|
|
|
|
} else { |
279
|
|
|
|
|
|
|
my $arrvalue = $o->{in}{$name}; |
280
|
|
|
|
|
|
|
undef $o->{in}{$name}; |
281
|
|
|
|
|
|
|
$o->{in}{$name}[0] = $arrvalue; |
282
|
|
|
|
|
|
|
push(@{$o->{in}{$name}}, $datas); |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
} else { |
285
|
|
|
|
|
|
|
$o->{in}{$name} = "", next if $datas =~ /^\s*$/; |
286
|
|
|
|
|
|
|
$o->{in}{$name} = $datas; |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
next; |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
for $currentColumn (@columns) { |
291
|
|
|
|
|
|
|
my ($currentHeader, $currentValue) = $currentColumn =~ /^([^=]+)="([^"]+)"$/; |
292
|
|
|
|
|
|
|
$o->{in}{$name}{$currentHeader} = $currentValue; |
293
|
|
|
|
|
|
|
} |
294
|
|
|
|
|
|
|
$o->{in}{$name}{'Contents'} = $datas; |
295
|
|
|
|
|
|
|
} |
296
|
|
|
|
|
|
|
undef $input; |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
} |
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
if ($o->{env}{QUERY_STRING}) { |
301
|
|
|
|
|
|
|
$input .= "&" if ($input); |
302
|
|
|
|
|
|
|
$input .= $o->{env}{QUERY_STRING}; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
my @kv = split('&',$input); |
306
|
|
|
|
|
|
|
foreach (@kv) { |
307
|
|
|
|
|
|
|
my ($k,$v) = split('='); |
308
|
|
|
|
|
|
|
$k =~ s/\+/ /g; |
309
|
|
|
|
|
|
|
$k =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg; |
310
|
|
|
|
|
|
|
$v =~ s/\+/ /g; |
311
|
|
|
|
|
|
|
$v =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg; |
312
|
|
|
|
|
|
|
# ignore stuff that starts with _raw: |
313
|
|
|
|
|
|
|
next if ($v =~ m/^_raw:/i); |
314
|
|
|
|
|
|
|
|
315
|
|
|
|
|
|
|
if (defined $o->{in}{$k}) { |
316
|
|
|
|
|
|
|
$o->{in}{$k} .= ",$v"; |
317
|
|
|
|
|
|
|
} else { |
318
|
|
|
|
|
|
|
$o->{in}{$k} = $v; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
foreach my $k (keys %{$o->{in}}) { |
323
|
|
|
|
|
|
|
if ($k =~ m/^[\dA-Fa-f]{32}::(.+)$/) { |
324
|
|
|
|
|
|
|
# check and see if we need to kill any acfb value (autocomplete form busting) |
325
|
|
|
|
|
|
|
$o->{in}{$1} = delete $o->{in}{$k}; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
1; |
331
|
|
|
|
|
|
|
__END__ |