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

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

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

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			return { code => 200 };
62			}
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	627	$run->{$_} = $params->{$_} foreach keys %$params;
131	dpavlin	653	$f = Frey::Run->new( class => $class, params => $run, run => $2 );
132	dpavlin	292	} elsif (
133			$path =~ m{/([^/]+)/?$}
134			) {
135			my $class = rest2class $1;
136			warn "# introspect $class";
137	dpavlin	625	$run->{class} \|\|= $class;
138	dpavlin	653	$f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
139	dpavlin	121	} else {
140	dpavlin	793	$f = Frey::Run->new( class => 'Frey::Class::Browser', params => $run );
141	dpavlin	66	}
142
143	dpavlin	277	if ( $f ) {
144	dpavlin	519	$f->clean_status;
145	dpavlin	627	# $f->add_status( { request => $req } );
146	dpavlin	581	$f->status_parts;
147			if ( my $html = $f->html ) {
148			warn "## html ",length($html)," bytes";
149	dpavlin	627	$self->print( $html );
150	dpavlin	581	} else {
151	dpavlin	589	confess "no output from $f";
152	dpavlin	581	}
153	dpavlin	277	} else {
154	dpavlin	589	confess "# can't call request on nothing!";
155	dpavlin	277	}
156
157	dpavlin	948	$request->{content_type} = $f->content_type;
158	dpavlin	66	};
159
160			if ( $@ ) {
161	dpavlin	581	warn "SERVER ERROR: $@";
162	dpavlin	948	$self->print( qq\|<pre class="frey-error">$@<pre>\| );
163	dpavlin	190	# Carp::REPL::repl;
164	dpavlin	948	return {
165			content_type => 'text/html',
166			code => 404,
167			}
168	dpavlin	53	}
169
170	dpavlin	948	return $request;
171	dpavlin	2	}
172
173	dpavlin	581	sub refresh {
174			my ( $url, $time ) = @_;
175			$url \|\|= '/';
176	dpavlin	643	$time \|\|= 0;
177	dpavlin	581	warn "# refresh $url";
178			qq\|
179			<html>
180			<head>
181			<META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
182			</head>
183			<body>
184			Refresh <a href="$url"><tt>$url</tt></a> in $time sec
185			</body>
186			</html>
187			\n\r\n\r
188			\|; # XXX newlines at end are important to flush content to browser
189			}
190
191	dpavlin	25	1;