lib/Frey/Server.pm

package Frey::Server;

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

use Data::Dump qw/dump/;

#use Carp::REPL; # 'nodie';

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