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 $path = $tx->req->url->path;
        if ( $path =~ m{/($rewrite_regex)} ) {
                my $from = $1;
                my $to = $mapping_url->{$from} || return tx_die( $tx, 500, "Unknown $from" );
                $tx->req->url->path( $to );
                warn "ACL $from -> $to OK\n";
        } else {
                return tx_die( $tx, 404, "Noting at $path") if ! $ENV{FREY_DEV};
        }

        my $body;

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

        my $url = $tx->req->url->to_abs->to_string;
        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	package Frey::Mojo;
2
3	use strict;
4	use warnings;
5
6	use base 'Mojo';
7
8	use MojoX::Dispatcher::Static;
9	use Data::Dump qw/dump/;
10
11	use lib 'lib';
12	use Frey::Server;
13
14	use Frey::CouchAPI;
15	my $couch_api = 0;
16
17	# 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
25
26	__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	# warn "# home ", $self->home;
41
42	$self->static->root( './' );
43
44	return $self;
45	}
46
47	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
55	sub handler {
56	my ($self, $tx) = @_;
57
58	# 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	# warn "## $self app ", @_;
65	$self;
66	}
67	sub log {
68	my $self = shift;
69	# warn "## $self log ",@_;
70	return $self;
71	}
72	sub debug {
73	my $self = shift;
74	warn "## ",@_, $/;
75	return $self;
76	}
77	}
78	bless $tx, 'Fake::App';
79
80	# rewrite URL
81	Frey::CouchAPI->rewrite_urls( $tx ) if $couch_api;
82
83	if ( ! $self->static->dispatch($tx) ) {
84	# warn "# static ",dump( $tx );
85	return $tx;
86	}
87
88	# FIXME this should move somewhere
89	my $path = $tx->req->url->path;
90	if ( $path =~ m{/($rewrite_regex)} ) {
91	my $from = $1;
92	my $to = $mapping_url->{$from} \|\| return tx_die( $tx, 500, "Unknown $from" );
93	$tx->req->url->path( $to );
94	warn "ACL $from -> $to OK\n";
95	} else {
96	return tx_die( $tx, 404, "Noting at $path") if ! $ENV{FREY_DEV};
97	}
98
99	my $body;
100
101	my $server = Frey::Server->new;
102	$server->{_print} = sub {
103	$body .= join("\n", @_);
104	};
105
106	my $url = $tx->req->url->to_abs->to_string;
107	my $params = $tx->req->params->to_hash;
108
109	my $referer = $tx->req->content->headers->header('Referer');
110	my $ajax = $tx->req->content->headers->header('X-Requested-With');
111	warn "# referer $referer\n";
112	# warn "## headers = ", dump( $tx->req->content->headers );
113
114	if ( $referer =~ m{/_utils} \|\| $ajax =~ m{XMLHttpRequest}i ) {
115	return Frey::CouchAPI->dispatch( $tx ) if $couch_api;
116	}
117
118	warn "# url $url from $referer params ",dump($params);
119
120	my $request = $server->request( $url, $params ); # fetch body
121
122	warn "# request ", dump( $request );
123
124	foreach ( 'content_type', 'code' ) {
125	die "missing $_" unless defined $request->{$_};
126	}
127
128	=for developer
129
130	# compatiblity with unpatched Mojo
131	sub class2rest {
132	my $c = shift;
133	$c =~ s/::/-/gs;
134	$c;
135	}
136	$body =~ s{(/\w+::\w+[\w:]+)}{class2rest($1)}sge;
137
138	=cut
139
140	$tx->res->code( $request->{code} );
141	$tx->res->headers->content_type( $request->{content_type} );
142	$tx->res->body( $body );
143
144	warn dump( $tx->res->headers );
145	return $tx;
146	}
147
148	1;