File Coverage

blib/lib/Apache/SdnFw.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


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__