lib/Frey/Server.pm

package Frey::Server;

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

use Data::Dump qw/dump/;

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.

=cut

sub print {
        my $self = shift;
        warn "# print ",dump( @_ );
        $self->{print}->( @_ );
}

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

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

        my $path = $url->path;

#       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, 1 ) );
                                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;
                        $params->{request_url} = $url,
                        $run->{$_} = $params->{$_} foreach keys %$params;
                        $f = Frey::Run->new( class => $class, params => $run, run => $2, request_url => $url );
                } elsif (
                        $path =~ m{/([^/]+)/?$}
                ) {
                        my $class = rest2class $1;
                        warn "# introspect $class";
                        $run->{class} ||= $class;
                        $f = Frey::Run->new( class => 'Frey::Introspect', params => $run, request_url => $url );
                } else {
                        $f = Frey::Run->new( class => 'Frey::ClassBrowser', params => $run, request_url => $url );
                }

                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!";
                }

        };

        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;
        }

}

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