lib/Frey/Server.pm

package Frey::Server;

use Moose;
extends 'Frey::Editor';
with 'Frey::Config';

use Data::Dump qw/dump/;

use lib 'lib';
use Frey::Run;

has 'port' => (
        documentation => 'port on which server listen',
        is => 'ro',
        isa => 'Int',
        default => sub {
                my $self = shift;
                $ENV{FREY_PORT} || $self->config->{port} || 16001
        },
);

has 'editor' => (
        is => 'ro',
        isa => 'Frey::Editor',
        lazy => 1,
        default => sub {
                Frey::Editor->new;
        },
);

=head2 request

This is simple dispatcher for our server. Currently it's in flux and
documented only in source code.

  my $content_type = $self->request( $url, $params );

=cut

sub print {
        my $self = shift;
        warn "# print ", join(' ', map { length $_ } @_ );
        $self->{_print}->( @_ );
}

sub request {
        my ( $self, $url, $params ) = @_;

        if ( my $ref = ref($url) ) {
                die "url not URI but ", dump( $url ) unless $ref =~ m{^URI};
        } else {
                $url = URI->new($url);
        }

        my $path = $url->path;
        my $content_type = 'text/plain';

        eval {
#       {

                if ( $path =~ m{/reload(.*)} ) {

                        $ENV{FREY_NO_LOG} = 1;
                        my $cmd = "perl -c $0";
                        warn "# check syntax with $cmd";
                        if ( system($cmd) == 0 ) {
                                my $server = Frey::Server->new;
                                $self->load_config;
#                               Module::Reload->check;
                                warn "# reload done";
                                $self->print( refresh( $1, 0 ) );
                                return;
                        } else {
                                warn "ERROR: $?";
                        }
                        $ENV{FREY_NO_LOG} = 0;
        
                } elsif ( $path =~ m{/exit(.*)} ) {
                        # FIXME do we need some kind of check here for production? :-)
                        # ./bin/dev.sh will restart us during development
                        $self->print( refresh( $1, 2 ) );
                        exit;
                }

                my $html;

                sub rest2class {
                        my $class = shift;
                        $class =~ s/-/::/; # sigh!
                        return $class;
                }

                my $f;

                # shared run params
                my $run = {
                        request_url => $url,
#                       debug => 1,
                };

                if (
                        $path =~ m{/Frey[:-]+ObjectBrowser}
                ) {
                        $f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
#                       $f->request( $req );
                } elsif (
                        $path =~ m{/Frey[:-]+ObjectDesigner}
                ) {
                        $f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
#                       $f->request( $req );
                } elsif ( $path =~ $self->editor->url_regex ) {
                        $self->print( $self->editor->command( $path ) );
                        return;
                } elsif (
                        $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
                ) {
                        my $class = rest2class $1;
                        warn "# run $path -> $class $2";
                        $run->{format} = $3 if $3;
                        $run->{$_} = $params->{$_} foreach keys %$params;
                        $f = Frey::Run->new( class => $class, params => $run, run => $2 );
                } elsif (
                        $path =~ m{/([^/]+)/?$}
                ) {
                        my $class = rest2class $1;
                        warn "# introspect $class";
                        $run->{class} ||= $class;
                        $f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
                } else {
                        $f = Frey::Run->new( class => 'Frey::Class::Browser', params => $run );
                }

                if ( $f ) {
                        $f->clean_status;
#                       $f->add_status( { request => $req } );
                        $f->status_parts;
                        if ( my $html = $f->html ) {
                                warn "## html ",length($html)," bytes";
                                $self->print( $html );
                        } else {
                                confess "no output from $f";
                        }
                } else {
                        confess "# can't call request on nothing!";
                }

                $content_type = $f->content_type;
        };

        if ( $@ ) {
                warn "SERVER ERROR: $@";
#               $req->conn->send_error( 404 );  # FIXME this should probably be 500, but we can't ship page with it
                $self->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
#               Carp::REPL::repl;
        }

        return $content_type;
}

sub refresh {
        my ( $url, $time ) = @_;
        $url  ||= '/';
        $time ||= 0;
        warn "# refresh $url";
        qq|
                <html>
                <head>
                        <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
                </head>
                <body>
                        Refresh <a href="$url"><tt>$url</tt></a> in $time sec
                </body>
                </html>
                \n\r\n\r
        |; # XXX newlines at end are important to flush content to browser
}

1;
1	dpavlin	19	package Frey::Server;
2	dpavlin	2
3	dpavlin	55	use Moose;
4	dpavlin	627	extends 'Frey::Editor';
5	dpavlin	341	with 'Frey::Config';
6	dpavlin	100
7	dpavlin	2	use Data::Dump qw/dump/;
8
9	dpavlin	790	use lib 'lib';
10	dpavlin	223	use Frey::Run;
11	dpavlin	23
12	dpavlin	627	has 'port' => (
13			documentation => 'port on which server listen',
14			is => 'ro',
15			isa => 'Int',
16			default => sub {
17			my $self = shift;
18			$ENV{FREY_PORT} \|\| $self->config->{port} \|\| 16001
19			},
20			);
21	dpavlin	2
22	dpavlin	627	has 'editor' => (
23			is => 'ro',
24			isa => 'Frey::Editor',
25			lazy => 1,
26			default => sub {
27			Frey::Editor->new;
28			},
29			);
30	dpavlin	2
31	dpavlin	627	=head2 request
32	dpavlin	37
33	dpavlin	627	This is simple dispatcher for our server. Currently it's in flux and
34			documented only in source code.
35	dpavlin	182
36	dpavlin	790	my $content_type = $self->request( $url, $params );
37
38	dpavlin	182	=cut
39
40	dpavlin	627	sub print {
41			my $self = shift;
42	dpavlin	628	warn "# print ", join(' ', map { length $_ } @_ );
43			$self->{_print}->( @_ );
44	dpavlin	25	}
45	dpavlin	2
46	dpavlin	627	sub request {
47			my ( $self, $url, $params ) = @_;
48	dpavlin	182
49	dpavlin	627	if ( my $ref = ref($url) ) {
50			die "url not URI but ", dump( $url ) unless $ref =~ m{^URI};
51	dpavlin	632	} else {
52	dpavlin	627	$url = URI->new($url);
53			}
54	dpavlin	182
55	dpavlin	627	my $path = $url->path;
56	dpavlin	790	my $content_type = 'text/plain';
57	dpavlin	182
58	dpavlin	653	eval {
59			# {
60	dpavlin	120
61	dpavlin	477	if ( $path =~ m{/reload(.*)} ) {
62	dpavlin	542
63			$ENV{FREY_NO_LOG} = 1;
64			my $cmd = "perl -c $0";
65	dpavlin	627	warn "# check syntax with $cmd";
66	dpavlin	542	if ( system($cmd) == 0 ) {
67	dpavlin	581	my $server = Frey::Server->new;
68	dpavlin	627	$self->load_config;
69	dpavlin	639	# Module::Reload->check;
70	dpavlin	542	warn "# reload done";
71	dpavlin	639	$self->print( refresh( $1, 0 ) );
72	dpavlin	542	return;
73			} else {
74			warn "ERROR: $?";
75			}
76			$ENV{FREY_NO_LOG} = 0;
77
78	dpavlin	477	} elsif ( $path =~ m{/exit(.*)} ) {
79			# FIXME do we need some kind of check here for production? :-)
80			# ./bin/dev.sh will restart us during development
81	dpavlin	627	$self->print( refresh( $1, 2 ) );
82	dpavlin	477	exit;
83	dpavlin	429	}
84	dpavlin	66
85	dpavlin	429	my $html;
86	dpavlin	292
87	dpavlin	429	sub rest2class {
88			my $class = shift;
89			$class =~ s/-/::/; # sigh!
90			return $class;
91			}
92	dpavlin	277
93	dpavlin	114	my $f;
94	dpavlin	66
95	dpavlin	421	# shared run params
96			my $run = {
97	dpavlin	627	request_url => $url,
98	dpavlin	625	# debug => 1,
99	dpavlin	421	};
100
101	dpavlin	292	if (
102			$path =~ m{/Frey[:-]+ObjectBrowser}
103			) {
104	dpavlin	627	$f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
105			# $f->request( $req );
106	dpavlin	292	} elsif (
107			$path =~ m{/Frey[:-]+ObjectDesigner}
108			) {
109	dpavlin	627	$f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
110			# $f->request( $req );
111			} elsif ( $path =~ $self->editor->url_regex ) {
112			$self->print( $self->editor->command( $path ) );
113	dpavlin	346	return;
114			} elsif (
115	dpavlin	581	$path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
116	dpavlin	292	) {
117			my $class = rest2class $1;
118	dpavlin	421	warn "# run $path -> $class $2";
119			$run->{format} = $3 if $3;
120	dpavlin	627	$run->{$_} = $params->{$_} foreach keys %$params;
121	dpavlin	653	$f = Frey::Run->new( class => $class, params => $run, run => $2 );
122	dpavlin	292	} elsif (
123			$path =~ m{/([^/]+)/?$}
124			) {
125			my $class = rest2class $1;
126			warn "# introspect $class";
127	dpavlin	625	$run->{class} \|\|= $class;
128	dpavlin	653	$f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
129	dpavlin	121	} else {
130	dpavlin	793	$f = Frey::Run->new( class => 'Frey::Class::Browser', params => $run );
131	dpavlin	66	}
132
133	dpavlin	277	if ( $f ) {
134	dpavlin	519	$f->clean_status;
135	dpavlin	627	# $f->add_status( { request => $req } );
136	dpavlin	581	$f->status_parts;
137			if ( my $html = $f->html ) {
138			warn "## html ",length($html)," bytes";
139	dpavlin	627	$self->print( $html );
140	dpavlin	581	} else {
141	dpavlin	589	confess "no output from $f";
142	dpavlin	581	}
143	dpavlin	277	} else {
144	dpavlin	589	confess "# can't call request on nothing!";
145	dpavlin	277	}
146
147	dpavlin	790	$content_type = $f->content_type;
148	dpavlin	66	};
149
150			if ( $@ ) {
151	dpavlin	581	warn "SERVER ERROR: $@";
152			# $req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it
153	dpavlin	627	$self->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
154	dpavlin	190	# Carp::REPL::repl;
155	dpavlin	53	}
156
157	dpavlin	790	return $content_type;
158	dpavlin	2	}
159
160	dpavlin	581	sub refresh {
161			my ( $url, $time ) = @_;
162			$url \|\|= '/';
163	dpavlin	643	$time \|\|= 0;
164	dpavlin	581	warn "# refresh $url";
165			qq\|
166			<html>
167			<head>
168			<META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
169			</head>
170			<body>
171			Refresh <a href="$url"><tt>$url</tt></a> in $time sec
172			</body>
173			</html>
174			\n\r\n\r
175			\|; # XXX newlines at end are important to flush content to browser
176			}
177
178	dpavlin	25	1;