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;

        if ( $path =~ m{^/(favicon.ico|__history__.html)$} ) {
                warn "INFO: $path ignored";
                return { code => 404, content_type => 'text/plain' };
        }

        my $request = {
                content_type => 'text/html',
                code => 200,
        };

        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+)/?([^/]+)?}
                ) {
                        my $class = rest2class $1;
                        warn "# run $path -> $class $2";
                        $run->{format} = $3 if $3;
                        foreach my $p ( keys %$params ) {
                                $run->{$p} = $params->{$p} if defined $params->{$p} && $params->{$p} ne '';
                        }
                        $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->setup_request;
#                       $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!";
                }

                $request->{content_type} = $f->content_type;
        };

        if ( $@ ) {
                warn "SERVER ERROR: $@";
                $self->print( qq|<pre class="frey-error">$@<pre>| );
#               Carp::REPL::repl;
                return {
                        content_type => 'text/html',
                        code => 404,
                }
        }

        return $request;
}

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
}

__PACKAGE__->meta->make_immutable;
no Moose;

my $timestamp_interval = 3;
my $output_tell = 0;

$SIG{ALRM} = sub {
        if ( tell(STDERR) != $output_tell ) {
                warn "\nTIMESTAMP: " . localtime() . "\n\n";
                $output_tell = tell(STDERR);
        }
        alarm $timestamp_interval;
};
alarm $timestamp_interval;

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	182
59	dpavlin	948	if ( $path =~ m{^/(favicon.ico\|__history__.html)$} ) {
60			warn "INFO: $path ignored";
61	dpavlin	954	return { code => 404, content_type => 'text/plain' };
62	dpavlin	948	}
63
64			my $request = {
65			content_type => 'text/html',
66			code => 200,
67			};
68
69	dpavlin	653	eval {
70	dpavlin	120
71	dpavlin	477	if ( $path =~ m{/reload(.*)} ) {
72	dpavlin	542
73			$ENV{FREY_NO_LOG} = 1;
74			my $cmd = "perl -c $0";
75	dpavlin	627	warn "# check syntax with $cmd";
76	dpavlin	542	if ( system($cmd) == 0 ) {
77	dpavlin	581	my $server = Frey::Server->new;
78	dpavlin	627	$self->load_config;
79	dpavlin	639	# Module::Reload->check;
80	dpavlin	542	warn "# reload done";
81	dpavlin	639	$self->print( refresh( $1, 0 ) );
82	dpavlin	542	return;
83			} else {
84			warn "ERROR: $?";
85			}
86			$ENV{FREY_NO_LOG} = 0;
87
88	dpavlin	477	} elsif ( $path =~ m{/exit(.*)} ) {
89			# FIXME do we need some kind of check here for production? :-)
90			# ./bin/dev.sh will restart us during development
91	dpavlin	627	$self->print( refresh( $1, 2 ) );
92	dpavlin	477	exit;
93	dpavlin	429	}
94	dpavlin	66
95	dpavlin	429	my $html;
96	dpavlin	292
97	dpavlin	429	sub rest2class {
98			my $class = shift;
99			$class =~ s/-/::/; # sigh!
100			return $class;
101			}
102	dpavlin	277
103	dpavlin	114	my $f;
104	dpavlin	66
105	dpavlin	421	# shared run params
106			my $run = {
107	dpavlin	627	request_url => $url,
108	dpavlin	625	# debug => 1,
109	dpavlin	421	};
110
111	dpavlin	292	if (
112			$path =~ m{/Frey[:-]+ObjectBrowser}
113			) {
114	dpavlin	627	$f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
115			# $f->request( $req );
116	dpavlin	292	} elsif (
117			$path =~ m{/Frey[:-]+ObjectDesigner}
118			) {
119	dpavlin	627	$f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
120			# $f->request( $req );
121			} elsif ( $path =~ $self->editor->url_regex ) {
122			$self->print( $self->editor->command( $path ) );
123	dpavlin	346	return;
124			} elsif (
125	dpavlin	886	$path =~ m{/([^/]+)/(\w+)/?([^/]+)?}
126	dpavlin	292	) {
127			my $class = rest2class $1;
128	dpavlin	421	warn "# run $path -> $class $2";
129			$run->{format} = $3 if $3;
130	dpavlin	1107	foreach my $p ( keys %$params ) {
131			$run->{$p} = $params->{$p} if defined $params->{$p} && $params->{$p} ne '';
132			}
133	dpavlin	653	$f = Frey::Run->new( class => $class, params => $run, run => $2 );
134	dpavlin	292	} elsif (
135			$path =~ m{/([^/]+)/?$}
136			) {
137			my $class = rest2class $1;
138			warn "# introspect $class";
139	dpavlin	625	$run->{class} \|\|= $class;
140	dpavlin	653	$f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
141	dpavlin	121	} else {
142	dpavlin	793	$f = Frey::Run->new( class => 'Frey::Class::Browser', params => $run );
143	dpavlin	66	}
144
145	dpavlin	277	if ( $f ) {
146	dpavlin	1158	$f->setup_request;
147	dpavlin	627	# $f->add_status( { request => $req } );
148	dpavlin	581	$f->status_parts;
149			if ( my $html = $f->html ) {
150			warn "## html ",length($html)," bytes";
151	dpavlin	627	$self->print( $html );
152	dpavlin	581	} else {
153	dpavlin	589	confess "no output from $f";
154	dpavlin	581	}
155	dpavlin	277	} else {
156	dpavlin	589	confess "# can't call request on nothing!";
157	dpavlin	277	}
158
159	dpavlin	948	$request->{content_type} = $f->content_type;
160	dpavlin	66	};
161
162			if ( $@ ) {
163	dpavlin	581	warn "SERVER ERROR: $@";
164	dpavlin	948	$self->print( qq\|<pre class="frey-error">$@<pre>\| );
165	dpavlin	190	# Carp::REPL::repl;
166	dpavlin	948	return {
167			content_type => 'text/html',
168			code => 404,
169			}
170	dpavlin	53	}
171
172	dpavlin	948	return $request;
173	dpavlin	2	}
174
175	dpavlin	581	sub refresh {
176			my ( $url, $time ) = @_;
177			$url \|\|= '/';
178	dpavlin	643	$time \|\|= 0;
179	dpavlin	581	warn "# refresh $url";
180			qq\|
181			<html>
182			<head>
183			<META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
184			</head>
185			<body>
186			Refresh <a href="$url"><tt>$url</tt></a> in $time sec
187			</body>
188			</html>
189			\n\r\n\r
190			\|; # XXX newlines at end are important to flush content to browser
191			}
192
193	dpavlin	1133	__PACKAGE__->meta->make_immutable;
194			no Moose;
195
196	dpavlin	1058	my $timestamp_interval = 3;
197			my $output_tell = 0;
198
199			$SIG{ALRM} = sub {
200			if ( tell(STDERR) != $output_tell ) {
201			warn "\nTIMESTAMP: " . localtime() . "\n\n";
202			$output_tell = tell(STDERR);
203			}
204			alarm $timestamp_interval;
205			};
206			alarm $timestamp_interval;
207
208	dpavlin	25	1;