lib/Frey/Mojo.pm

package Frey::Mojo;

use strict;
use warnings;

use base 'Mojo';

use MojoX::Dispatcher::Static;
use Data::Dump qw/dump/;

use lib 'lib';
use Frey::Server;

use Frey::CouchAPI;
my $couch_api = 0;

# FIXME move this somewhere
use App::RoomReservation;
my $mapping_url;
my $url_mapping = App::RoomReservation->url_mapping;
map { $mapping_url->{ $url_mapping->{$_} } = $_ } keys %$url_mapping;
my $rewrite_regex = join('|', sort { length $b <=> length $a } keys %$mapping_url);
warn "# mapping $rewrite_regex ",dump( $mapping_url );


__PACKAGE__->attr(
    static => (                             
        chained => 1,                       
        default => sub { MojoX::Dispatcher::Static->new }
    )
);

sub new {
    my $self = shift->SUPER::new();

    # This app should log only errors to STDERR
    $self->log->level('error');
    $self->log->path(undef);

#       warn "# home ", $self->home;

        $self->static->root( './' );

    return $self;
}

sub tx_die {
        my $tx = shift;
        $tx->res->code( shift );
        $tx->res->body( shift );
        $tx->res->headers->content_type( shift || 'text/plain' );
        return $tx;
}

sub handler {
        my ($self, $tx) = @_;

        # XXX fake app so static dispatcher won't die on us
        {
                package Fake::App;
                use base 'Mojo::Transaction';
                sub app {
                        my $self = shift;
#                       warn "## $self app ", @_;
                        $self;
                }
                sub log {
                        my $self = shift;
#                       warn "## $self log ",@_;
                        return $self;
                }
                sub debug {
                        my $self = shift;
                        warn "## ",@_, $/;
                        return $self;
                }
        }
        bless $tx, 'Fake::App';

        # rewrite URL
        Frey::CouchAPI->rewrite_urls( $tx ) if $couch_api;

        if ( ! $self->static->dispatch($tx) ) {
#               warn "# static ",dump( $tx );
                return $tx;
        }

        # FIXME this should move somewhere
        my $url = $tx->req->url->to_abs->to_string;
        if ( $url =~ m{/($rewrite_regex)} ) {
                my $from = $1;
                my $to = $mapping_url->{$from} || return tx_die( $tx, 500, "Unknown $from" );

                $url =~ s{/($from)}{/$to};

                $tx->req->url( Mojo::URL->new($url) );
                warn "ACL $from -> $to OK\n";
        } else {
                return tx_die( $tx, 404, "Noting at $url") if ! $ENV{FREY_DEV};
        }

        my $body;

        my $server = Frey::Server->new;
        $server->{_print} = sub {
                $body .= join("\n", @_);
        };

        my $params = $tx->req->params->to_hash;

        my $referer = $tx->req->content->headers->header('Referer');
        my $ajax = $tx->req->content->headers->header('X-Requested-With');
        warn "# referer $referer\n";
#       warn "## headers = ", dump( $tx->req->content->headers );

        if ( $referer =~ m{/_utils} || $ajax =~ m{XMLHttpRequest}i ) {
                return Frey::CouchAPI->dispatch( $tx ) if $couch_api;
        }

        warn "# url $url from $referer params ",dump($params);

        my $request = $server->request( $url, $params ); # fetch body

        warn "# request ", dump( $request );

        foreach ( 'content_type', 'code' ) {
                die "missing $_" unless defined $request->{$_};
        }

=for developer

        # compatiblity with unpatched Mojo
        sub class2rest {
                my $c = shift;
                $c =~ s/::/-/gs;
                $c;
        }
        $body =~ s{(/\w+::\w+[\w:]+)}{class2rest($1)}sge;

=cut

        $tx->res->code( $request->{code} );
        $tx->res->headers->content_type( $request->{content_type} );
        $tx->res->body( $body );

        warn dump( $tx->res->headers );
        return $tx;
}

1;
1	dpavlin	267	package Frey::Mojo;
2
3			use strict;
4			use warnings;
5
6	dpavlin	633	use base 'Mojo';
7	dpavlin	267
8	dpavlin	633	use MojoX::Dispatcher::Static;
9	dpavlin	1168	use Data::Dump qw/dump/;
10	dpavlin	267
11	dpavlin	790	use lib 'lib';
12	dpavlin	633	use Frey::Server;
13	dpavlin	1168
14	dpavlin	1046	use Frey::CouchAPI;
15	dpavlin	1168	my $couch_api = 0;
16	dpavlin	267
17	dpavlin	1168	# FIXME move this somewhere
18			use App::RoomReservation;
19			my $mapping_url;
20			my $url_mapping = App::RoomReservation->url_mapping;
21			map { $mapping_url->{ $url_mapping->{$_} } = $_ } keys %$url_mapping;
22			my $rewrite_regex = join('\|', sort { length $b <=> length $a } keys %$mapping_url);
23			warn "# mapping $rewrite_regex ",dump( $mapping_url );
24	dpavlin	267
25	dpavlin	1168
26	dpavlin	633	__PACKAGE__->attr(
27			static => (
28			chained => 1,
29			default => sub { MojoX::Dispatcher::Static->new }
30			)
31			);
32
33			sub new {
34			my $self = shift->SUPER::new();
35
36			# This app should log only errors to STDERR
37			$self->log->level('error');
38			$self->log->path(undef);
39
40	dpavlin	1046	# warn "# home ", $self->home;
41	dpavlin	633
42			$self->static->root( './' );
43
44			return $self;
45	dpavlin	267	}
46
47	dpavlin	1168	sub tx_die {
48			my $tx = shift;
49			$tx->res->code( shift );
50			$tx->res->body( shift );
51			$tx->res->headers->content_type( shift \|\| 'text/plain' );
52			return $tx;
53			}
54	dpavlin	803
55	dpavlin	633	sub handler {
56			my ($self, $tx) = @_;
57	dpavlin	267
58	dpavlin	803	# XXX fake app so static dispatcher won't die on us
59			{
60			package Fake::App;
61			use base 'Mojo::Transaction';
62			sub app {
63			my $self = shift;
64	dpavlin	1046	# warn "## $self app ", @_;
65	dpavlin	803	$self;
66			}
67			sub log {
68			my $self = shift;
69	dpavlin	1046	# warn "## $self log ",@_;
70	dpavlin	803	return $self;
71			}
72			sub debug {
73			my $self = shift;
74	dpavlin	1046	warn "## ",@_, $/;
75	dpavlin	803	return $self;
76			}
77			}
78			bless $tx, 'Fake::App';
79
80	dpavlin	1046	# rewrite URL
81	dpavlin	1168	Frey::CouchAPI->rewrite_urls( $tx ) if $couch_api;
82	dpavlin	1046
83	dpavlin	1138	if ( ! $self->static->dispatch($tx) ) {
84	dpavlin	636	# warn "# static ",dump( $tx );
85	dpavlin	633	return $tx;
86			}
87	dpavlin	267
88	dpavlin	1168	# FIXME this should move somewhere
89	dpavlin	1169	my $url = $tx->req->url->to_abs->to_string;
90			if ( $url =~ m{/($rewrite_regex)} ) {
91	dpavlin	1168	my $from = $1;
92			my $to = $mapping_url->{$from} \|\| return tx_die( $tx, 500, "Unknown $from" );
93	dpavlin	1169
94			$url =~ s{/($from)}{/$to};
95
96			$tx->req->url( Mojo::URL->new($url) );
97	dpavlin	1168	warn "ACL $from -> $to OK\n";
98			} else {
99	dpavlin	1169	return tx_die( $tx, 404, "Noting at $url") if ! $ENV{FREY_DEV};
100	dpavlin	1168	}
101
102	dpavlin	633	my $body;
103	dpavlin	272
104	dpavlin	633	my $server = Frey::Server->new;
105			$server->{_print} = sub {
106			$body .= join("\n", @_);
107			};
108	dpavlin	272
109	dpavlin	636	my $params = $tx->req->params->to_hash;
110	dpavlin	318
111	dpavlin	1046	my $referer = $tx->req->content->headers->header('Referer');
112			my $ajax = $tx->req->content->headers->header('X-Requested-With');
113			warn "# referer $referer\n";
114	dpavlin	1047	# warn "## headers = ", dump( $tx->req->content->headers );
115	dpavlin	318
116	dpavlin	1046	if ( $referer =~ m{/_utils} \|\| $ajax =~ m{XMLHttpRequest}i ) {
117	dpavlin	1168	return Frey::CouchAPI->dispatch( $tx ) if $couch_api;
118	dpavlin	1046	}
119
120			warn "# url $url from $referer params ",dump($params);
121
122	dpavlin	948	my $request = $server->request( $url, $params ); # fetch body
123	dpavlin	633
124	dpavlin	948	warn "# request ", dump( $request );
125
126			foreach ( 'content_type', 'code' ) {
127			die "missing $_" unless defined $request->{$_};
128			}
129
130	dpavlin	633	=for developer
131
132			# compatiblity with unpatched Mojo
133			sub class2rest {
134			my $c = shift;
135			$c =~ s/::/-/gs;
136			$c;
137			}
138			$body =~ s{(/\w+::\w+[\w:]+)}{class2rest($1)}sge;
139
140			=cut
141
142	dpavlin	948	$tx->res->code( $request->{code} );
143			$tx->res->headers->content_type( $request->{content_type} );
144	dpavlin	633	$tx->res->body( $body );
145
146			warn dump( $tx->res->headers );
147			return $tx;
148	dpavlin	267	}
149
150			1;