From 3e569a76cce898b2ef8d2181eb220f9af249e327 Mon Sep 17 00:00:00 2001
From: Sebastian Riedel <sri@labs.kraih.com>
Date: Wed, 16 Dec 2009 07:38:28 +0100
Subject: [PATCH] added native PSGI support

---
 Changes                 |   1 +
 lib/Mojo/Server/PSGI.pm | 127 ++++++++++++++++++++++++++++++++++++++++
 t/mojo/psgi.t           |  53 +++++++++++++++++
 3 files changed, 181 insertions(+)
 create mode 100644 lib/Mojo/Server/PSGI.pm
 create mode 100644 t/mojo/psgi.t

diff --git a/Changes b/Changes
index fbdaf87e69..9c95492119 100644
--- a/Changes
+++ b/Changes
@@ -3,6 +3,7 @@ This file documents the revision history for Perl extension Mojo.
 0.999915 2009-12-10 00:00:00
         - Added routes captures to params in Mojolicious.
         - Added charset plugin to Mojolicious. (charsbar)
+        - Added native PSGI support.
         - Made param decoding more defensive and allow malformed data to pass
           through for debugging.
         - Fixed a case where an ending tag would be interpreted as a line
diff --git a/lib/Mojo/Server/PSGI.pm b/lib/Mojo/Server/PSGI.pm
new file mode 100644
index 0000000000..ca5fe62a68
--- /dev/null
+++ b/lib/Mojo/Server/PSGI.pm
@@ -0,0 +1,127 @@
+# Copyright (C) 2008-2009, Sebastian Riedel.
+
+package Mojo::Server::PSGI;
+
+use strict;
+use warnings;
+
+use base 'Mojo::Server';
+use bytes;
+
+use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 4096;
+
+# Things aren't as happy as they used to be down here at the unemployment
+# office.
+# Joblessness is no longer just for philosophy majors.
+# Useful people are starting to feel the pinch.
+sub run {
+    my ($self, $env) = @_;
+
+    my $tx  = $self->build_tx_cb->($self);
+    my $req = $tx->req;
+
+    # Environment
+    $req->parse($env);
+
+    # Store connection information
+    $tx->remote_address($env->{REMOTE_ADDR});
+    $tx->local_port($env->{SERVER_PORT});
+
+    # Request body
+    while (!$req->is_finished) {
+        my $read = $env->{'psgi.input'}->read(my $buffer, CHUNK_SIZE, 0);
+        last if $read == 0;
+        $req->parse($buffer);
+    }
+
+    # Handle
+    $self->handler_cb->($self, $tx);
+
+    my $res = $tx->res;
+
+    # Status
+    my $status = $res->code;
+
+    # Response headers
+    $res->fix_headers;
+    my $headers = $res->content->headers;
+    my @headers;
+    for my $name (@{$headers->names}) {
+        for my $value ($headers->header($name)) {
+            push @headers, $name => $value;
+        }
+    }
+
+    # Response body
+    my $body = Mojo::Server::PSGI::Handle->new(res => $res);
+
+    return [$status, \@headers, $body];
+}
+
+package Mojo::Server::PSGI::Handle;
+
+use strict;
+use warnings;
+
+use base 'Mojo::Base';
+
+__PACKAGE__->attr(offset => 0);
+__PACKAGE__->attr('res');
+
+sub close { }
+
+sub getline {
+    my $self = shift;
+
+    # Blocking read
+    my $offset = $self->offset;
+    while (1) {
+        my $chunk = $self->res->get_body_chunk($offset);
+
+        # No content yet, try again
+        unless (defined $chunk) {
+            sleep 1;
+            next;
+        }
+
+        # End of content
+        last unless length $chunk;
+
+        # Content
+        $offset += length $chunk;
+        $self->offset($offset);
+        return $chunk;
+    }
+
+    return;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Mojo::Server::PSGI - PSGI Server
+
+=head1 SYNOPSIS
+
+    # myapp.psgi
+    use Mojo::Server::PSGI;
+    my $psgi = Mojo::Server::PSGI->new->app_class('MyApp');
+    my $app  = sub { $psgi->run(@_) };
+
+=head1 DESCRIPTION
+
+L<Mojo::Server::PSGI> allows L<Mojo> applications to run on all PSGI
+compatible servers.
+
+=head1 METHODS
+
+L<Mojo::Server::PSGI> inherits all methods from L<Mojo::Server> and
+implements the following new ones.
+
+=head2 C<run>
+
+    $psgi->run;
+
+=cut
diff --git a/t/mojo/psgi.t b/t/mojo/psgi.t
new file mode 100644
index 0000000000..d8f24fc919
--- /dev/null
+++ b/t/mojo/psgi.t
@@ -0,0 +1,53 @@
+#!/usr/bin/env perl
+
+# Copyright (C) 2008-2009, Sebastian Riedel.
+
+use strict;
+use warnings;
+
+use Test::More tests => 11;
+
+use_ok('Mojo::Server::PSGI');
+
+# We need some more secret sauce. Put the mayonnaise in the sun.
+my $psgi = Mojo::Server::PSGI->new;
+my $app = sub { $psgi->run(@_) };
+
+# Request
+my $content = 'hello=world';
+open my $body, '<', \$content;
+my $env = {
+    CONTENT_LENGTH      => 11,
+    CONTENT_TYPE        => 'application/x-www-form-urlencoded',
+    PATH_INFO           => '/diag/dump_params',
+    QUERY_STRING        => 'lalala=23&bar=baz',
+    REQUEST_METHOD      => 'POST',
+    SCRIPT_NAME         => '/',
+    HTTP_HOST           => 'localhost:8080',
+    SERVER_PROTOCOL     => 'HTTP/1.0',
+    'psgi.version'      => [1, 0],
+    'psgi.url_scheme'   => 'http',
+    'psgi.input'        => $body,
+    'psgi.errors'       => *STDERR,
+    'psgi.multithread'  => 0,
+    'psgi.multiprocess' => 1,
+    'psgi.run_once'     => 0
+};
+
+# Process
+my $res = $app->($env);
+
+# Response
+is($res->[0],      200);
+is($res->[1]->[0], 'Date');
+ok($res->[1]->[1]->[0]);
+is($res->[1]->[2],      'Content-Length');
+is($res->[1]->[3]->[0], 104);
+is($res->[1]->[4],      'Content-Type');
+is($res->[1]->[5]->[0], 'text/plain');
+is($res->[1]->[6],      'X-Powered-By');
+is($res->[1]->[7]->[0], 'Mojo (Perl)');
+my $params = '';
+while (defined(my $chunk = $res->[2]->getline)) { $params .= $chunk }
+$params = eval "my $params";
+is_deeply($params, {bar => 'baz', hello => 'world', lalala => 23});