Add reqJSON and resJSON for simple JSON API support

7 files changed, 76 insertions, 12 deletions

diff --git a/examples/singlefile.pl b/examples/singlefile.pl
index 272a9d6..6544ce1 100755
--- a/examples/singlefile.pl
+++ b/examples/singlefile.pl
@@ -32,6 +32,8 @@ TUWF::register(
   # /sub/ as the second argument to subpage().
   qr/sub\/(.*)/ => \&subpage,
 
+  qr{api/echo\.json} => \&echoapi,
+
   # all requests for non-registered URIs will throw a 404
 );
 
@@ -70,3 +72,9 @@ sub subpage {
 }
 
 
+sub echoapi {
+  my $self = shift;
+  $self->resJSON($self->reqJSON);
+}
+
+
diff --git a/lib/TUWF.pm b/lib/TUWF.pm
index baf80f0..4c43f6a 100644
--- a/lib/TUWF.pm
+++ b/lib/TUWF.pm
@@ -210,7 +210,8 @@ sub _handle_request {
     my $err = $self->reqInit();
     if($err) {
       warn "Client sent non-UTF-8-encoded data. Generating HTTP 400 response.\n" if $err eq 'utf8';
-      $self->{_TUWF}{error_400_handler}->($self) if $err eq 'utf8';
+      warn "Client sent an invalid JSON object. Generating HTTP 400 response.\n" if $err eq 'json';
+      $self->{_TUWF}{error_400_handler}->($self) if $err eq 'utf8' || $err eq 'json';
       $self->{_TUWF}{error_405_handler}->($self) if $err eq 'method';
       $self->{_TUWF}{error_413_handler}->($self) if $err eq 'maxpost';
       return 1;
diff --git a/lib/TUWF.pod b/lib/TUWF.pod
index 44d20b3..ca2a02c 100644
--- a/lib/TUWF.pod
+++ b/lib/TUWF.pod
@@ -25,11 +25,19 @@ other hand, B<is> quite small. Its total codebase is significantly smaller than
 the primary code of CGI.pm, and TUWF requires absolutely no extra dependencies
 to run.
 
-Some optional features, however, do require extra modules. In order to run TUWF
-in a FastCGI environment, the L<FCGI|FCGI> module is required. The
-L<TUWF::DB|TUWF::DB> methods require L<DBI|DBI>, and
-L<PerlIO::gzip|PerlIO::gzip> is required when you want to enable content
-encoding.
+Some optional features, however, do require extra modules:
+
+=over
+
+=item * L<DBI>: For the L<TUWF::DB> database handling methods.
+
+=item * L<FCGI>: To run TUWF in a FastCGI environment.
+
+=item * L<JSON::XS>: If you need to handle requests with a JSON body, or wish to output JSON yourself.
+
+=item * L<PerlIO::gzip>: For output compression.
+
+=back
 
 =item The generated response is buffered.
 
@@ -43,8 +51,8 @@ added bonus, your pages will be compressed more efficiently when output
 compression is enabled.
 
 On the other hand, this means that you can't use TUWF for applications that
-require streaming dynamic content (e.g. a chat application), and you may get
-into memory issues when sending large files.
+require Websockets or other forms of streaming dynamic content (e.g. a chat
+application), and you may get into memory issues when sending large files.
 
 =item Everything is UTF-8.
 
@@ -520,7 +528,7 @@ C<examples/singlefile.pl> script from the TUWF distribution. I assume the TUWF
 distribution is unpacked in C</tuwf> and the site runs on the hostname
 C<test.example.com>.
 
-=head2 Examples for Apache (2.2)
+=head2 Examples for Apache (2.2 or 2.4)
 
 CGI mode:
 
diff --git a/lib/TUWF/Request.pm b/lib/TUWF/Request.pm
index 9595663..d71cf16 100644
--- a/lib/TUWF/Request.pm
+++ b/lib/TUWF/Request.pm
@@ -9,7 +9,7 @@ use Carp 'croak';
 
 our $VERSION = '1.1';
 our @EXPORT = qw|
-  reqInit reqGets reqGet reqPosts reqPost reqParams reqParam
+  reqInit reqGets reqGet reqPosts reqPost reqParams reqParam reqJSON
   reqUploadMIMEs reqUploadMIME reqUploadRaws reqUploadRaw reqSaveUpload
   reqCookie reqMethod reqHeader reqPath reqQuery reqProtocol reqBaseURI reqURI reqHost reqIP reqFCGI
 |;
@@ -45,7 +45,10 @@ sub reqInit {
     die "Couldn't read all POST data.\n" if $ENV{CONTENT_LENGTH} > read STDIN, $data, $ENV{CONTENT_LENGTH}, 0;
 
     $err = eval {
-      if(($ENV{'CONTENT_TYPE'}||'') =~ m{^multipart/form-data; boundary=(.+)$}) {
+      if(($ENV{'CONTENT_TYPE'}||'') =~ m{^application/json(?:;.*)?$}) {
+        $self->{_TUWF}{Req}{JSON} = _parse_json($data);
+        return 'json' if !$self->{_TUWF}{Req}{JSON};
+      } elsif(($ENV{'CONTENT_TYPE'}||'') =~ m{^multipart/form-data; boundary=(.+)$}) {
         _parse_multipart($self, $data, $1);
       } else {
         $self->{_TUWF}{Req}{POST} = _parse_urlencoded($data);
@@ -81,6 +84,16 @@ sub _parse_urlencoded {
 }
 
 
+sub _parse_json {
+  my $d = shift;
+  die "Received a JSON request body, but was unable to load JSON::XS. Is it installed?\n"
+    unless eval { require JSON::XS; 1 };
+  my $res = eval { JSON::XS::decode_json($d) };
+  return undef if !$res || ref $res ne 'HASH'; # We always expect to receive a JSON object.
+  return $res;
+}
+
+
 # Heavily inspired by CGI::Minimal::Multipart::_burst_multipart_buffer()
 sub _parse_multipart {
   my($self, $data, $boundary) = @_;
@@ -206,6 +219,11 @@ sub reqParam {
 }
 
 
+sub reqJSON {
+  return shift->{_TUWF}{Req}{JSON};
+}
+
+
 # saves file contents identified by the form name to the specified file
 # (doesn't support multiple file upload using the same form name yet)
 sub reqSaveUpload {
diff --git a/lib/TUWF/Request.pod b/lib/TUWF/Request.pod
index 62eeb64..bf65373 100644
--- a/lib/TUWF/Request.pod
+++ b/lib/TUWF/Request.pod
@@ -74,6 +74,14 @@ Behaves the same as C<reqGet()>, but works on both POST and GET data. If a
 parameter is set in both the POST and GET data, only the value in the POST data
 is returned.
 
+=head2 reqJSON()
+
+Returns the decoded JSON object if the request body was of type
+C<application/json>; Returns C<undef> otherwise.
+
+This requires the L<JSON::XS> module. If this module is not available, any
+request with a JSON body will automatically get a 500 response.
+
 =head2 reqUploadMIMEs(name)
 
 When I<name> is not given, returns a list of all parameter names that represent
diff --git a/lib/TUWF/Response.pm b/lib/TUWF/Response.pm
index d29aa81..88617ab 100644
--- a/lib/TUWF/Response.pm
+++ b/lib/TUWF/Response.pm
@@ -6,11 +6,12 @@ use strict;
 use warnings;
 use Exporter 'import';
 use POSIX 'strftime';
+use Carp 'croak';
 
 
 our $VERSION = '1.1';
 our @EXPORT = qw|
-  resInit resHeader resCookie resBuffer resFd resStatus resRedirect resNotFound resFinish
+  resInit resHeader resCookie resBuffer resFd resStatus resRedirect resNotFound resJSON resFinish
 |;
 
 
@@ -182,6 +183,18 @@ sub resNotFound {
 }
 
 
+sub resJSON {
+  my($self, $obj) = @_;
+  croak "Unable to load JSON::XS, is it installed?\n"
+    unless eval { require JSON::XS; 1 };
+
+  $self->resInit;
+  $self->resHeader('Content-Type' => 'application/json');
+  my $fd = $self->resFd();
+  print $fd JSON::XS::encode_json($obj);
+}
+
+
 # Send everything we have buffered to the client
 sub resFinish {
   my $self = shift;
diff --git a/lib/TUWF/Response.pod b/lib/TUWF/Response.pod
index 52a5c28..98e9429 100644
--- a/lib/TUWF/Response.pod
+++ b/lib/TUWF/Response.pod
@@ -171,6 +171,14 @@ browser to use a GET request for the redirect.
 C<resRedirect()> calls C<resInit()>, so if you wish to send any additional
 headers or cookies, you have to set these B<after> calling C<resRedirect()>.
 
+=head2 resJSON(data)
+
+Sets the content type to C<application/json> and sends the encoded JSON object
+to the client.
+
+C<resJSON()> calls C<resInit()>, so if you wish to send any additional headers
+or cookies, you have to set these B<after> calling C<resJSON()>.
+
 =head2 resNotFound()
 
 Return a 404 Page Not Found response. The response will be exactly the same as