/[Frey]/trunk/lib/Frey/Server.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/Frey/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 179 by dpavlin, Sun Aug 31 17:44:03 2008 UTC revision 589 by dpavlin, Fri Nov 28 15:07:32 2008 UTC
# Line 1  Line 1 
1  package Frey::Server;  package Frey::Server;
2    
3  use Moose;  use Moose;
4    extends 'Frey';
5  with 'Frey::Web';  with 'Frey::Web';
6    with 'Frey::Config';
7    
8  use Continuity;  use Continuity;
9  #use Continuity::REPL;  #use Continuity::REPL;
10  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
11    
12  use Carp::REPL;  #use Carp::REPL; ## XXX it would be nice, but it breaks error reporting too much
13  use Frey::ClassLoader;  use Frey::ClassLoader;
14    use Frey::Run;
15    use Frey::Editor;
16    
17  my @messages;    # Global (shared) list of messages  my @messages;    # Global (shared) list of messages
18  my $got_message; # Flag to indicate that there is a new message to display  my $got_message; # Flag to indicate that there is a new message to display
# Line 18  use vars qw( $repl $server ); Line 21  use vars qw( $repl $server );
21    
22  #$repl = Continuity::REPL->new;  #$repl = Continuity::REPL->new;
23    
24    =head1 NAME
25    
26    Frey::Server - Continuity based server for Frey
27    
28    =head2 DESCRIPTION
29    
30    This is one of pissible server implementations for Frey. In it's current stage, it's also most complete one.
31    
32    =head2 run
33    
34      $o->run( $optional_port );
35    
36    =cut
37    
38  sub run {  sub run {
39          my ( $self, $port ) = @_;          my ( $self, $port ) = @_;
40          $server = Continuity->new(          $server = Continuity->new(
41                  port => $port || 16001,                  port => $port || $self->config->{port} || 16001,
42                  path_session => 1,                  path_session => 1,
43                  cookie_session => 'sid',                  cookie_session => 'sid',
44                  callback => \&main,                  callback => \&main,
45                  debug_level => 1,                  debug_level => 2,
46                  staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$/ },                  staticp => sub {
47                            $_[0]->url =~ m{^/+(static|var).*\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$}
48                    },
49          );          );
50          $Module::Reload::Debug = 1;          $Module::Reload::Debug = 1; # auto if debug_level > 1
51          Frey::ClassLoader->new->load_all_classes();          Frey::ClassLoader->new->load_all_classes();
52          $server->loop;          $server->loop;
53  }  }
54    
55  # This is the main entrypoint. We are looking for one of three things -- a  =head2 main
56  # pushstream, a sent message, or a request for the main HTML. We delegate each  
57  # of these cases, none of which will return (they all loop forever).  This is simple dispatcher for our server. Currently it's in flux and
58    documented only in source code.
59    
60    =cut
61    
62  sub main {  sub main {
63          my ($req) = @_;          my ($req) = @_;
     
         my $path = $req->request->url->path;  
         warn "REQUEST: $path ",dump( $req->params ),"\n";  
64    
65          Module::Reload->check if $path =~ m!reload! || $req->param('reload');  #       $req->send_headers("X-Frey-VERSION: $Frey::VERSION");
66    
67  #       warn $req->request->header('User_Agent');          my $path = $req->request->url->path;
68    
69          sub run_markup {          eval {
                 my ( $req, $class ) = @_;  
70    
71                  my %params = $req->params;                  if ( $path =~ m{/reload(.*)} ) {
72    
73                  my @required =                          $ENV{FREY_NO_LOG} = 1;
74                          grep {                          my $cmd = "perl -c $0";
75                                  defined $_ && !defined( $params{$_} )                          warn "# check config with $cmd";
76                            if ( system($cmd) == 0 ) {
77                                    $req->print( "\r\n" );
78                                    my $server = Frey::Server->new;
79                                    $server->load_config;
80                                    $req->print( "\r\n" );
81                                    Module::Reload->check;
82                                    $req->print( "\r\n" );
83                                    $req->print( refresh( $1, 1 ) );
84                                    $req->print( "\r\n" );
85                                    warn "# reload done";
86                                    return;
87                            } else {
88                                    warn "ERROR: $?";
89                          }                          }
90                          map {                          $ENV{FREY_NO_LOG} = 0;
91                                  my $attr = $class->meta->get_attribute($_);          
92                                  $attr->is_required && $_                  } elsif ( $path =~ m{/exit(.*)} ) {
93                          } $class->meta->get_attribute_list;                          # FIXME do we need some kind of check here for production? :-)
94                            # ./bin/dev.sh will restart us during development
95                            $req->print( refresh( $1, 2 ) );
96                            $req->print( "\r\n" );
97                            exit;
98                    }
99    
100                  warn "## required = ",dump( @required );  #               warn $req->request->header('User_Agent');
                 warn "## params = ",dump( %params );  
101    
102                    my %params = $req->params;
103                  my $html;                  my $html;
104    
105                  if ( @required ) {                  sub rest2class {
106                          $html = qq|<form method="post">|;                          my $class = shift;
107                          $html .= qq|<input type="text" name="$_">| foreach @required;                          $class =~ s/-/::/; # sigh!
108                          $html .= qq|<input type="submit" value="Run $class"></form>|;                          return $class;
                 } else {  
                         my $o = $class->new( %params );  
                         $o->depends if $o->can('depends');  
                         $html = $o->markup;  
109                  }                  }
110    
                 warn ">>> markup $class ",length( $html ), " bytes\n";  
                 return $html;  
         }  
111    
112                    my $f;
113    
114  #       eval {                  my $editor = Frey::Editor->new;
         {  
115    
116                  my $f;                  # shared run params
117                    my $run = {
118                            request_url => $req->request->url,
119                            debug => 1,
120                    };
121    
122                    if (
123                            $path =~ m{/Frey[:-]+ObjectBrowser}
124                    ) {
125                            $f = Frey::ObjectBrowser->new( fey_class => $params{class} );
126                            $f->request( $req );
127                    } elsif (
128                            $path =~ m{/Frey[:-]+ObjectDesigner}
129                    ) {
130                            $f = Frey::ObjectDesigner->new( fey_class => $params{class} );
131                            $f->request( $req );
132                    } elsif ( $path =~ $editor->url_regex ) {
133                            $req->print( $editor->command( $path ) );
134                            system( $editor->command( $path ) );
135                            return;
136                    } elsif (
137                            $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
138                    ) {
139                            my $class = rest2class $1;
140                            warn "# run $path -> $class $2";
141                            $run->{format} = $3 if $3;
142                            $params{request_url} = $req->request->url;
143                            $req->print( "\r\n\r\n" ); # send something to browser so we don't time-out
144                            $f = Frey::Run->new( class => $class, params => \%params, run => $2, %$run );
145                    } elsif (
146                            $path =~ m{/([^/]+)/?$}
147                    ) {
148                            my $class = rest2class $1;
149                            warn "# introspect $class";
150                            $f = Frey::Run->new( class => 'Frey::Introspect', params => { class => $class }, %$run );
151                    } else {
152                            $f = Frey::Run->new( class => 'Frey::ClassBrowser', %$run );
153                    }
154    
155                  if ( $path =~ m!/~/([^/]+)(.*)! ) {                  if ( $f ) {
156                          $f = Frey::Introspect->new( package => $1 );                          $f->clean_status;
157                  } elsif ( $path =~ m!/ob/([^/]+)(.*)! ) {                          $f->add_status( { request => $req } );
158                          $f = Frey::ObjectBrowser->new( fey_class => $1 );                          $f->status_parts;
159                  } elsif ( $path =~ m!/od/([^/]+)(.*)! ) {                          if ( my $html = $f->html ) {
160                          $f = Frey::ObjectDesigner->new( fey_class => $1 );                                  warn "## html ",length($html)," bytes";
161                  } elsif ( $path =~ m!/markup/([^/]+)(.*)! ) {                                  $req->print( $html );
162                          $req->print( run_markup( $req, $1 )  );                          } else {
163                                    confess "no output from $f";
164                            }
165                  } else {                  } else {
166                          $f = Frey::ClassBrowser->new;                          confess "# can't call request on nothing!";
167                  }                  }
                 $f->html( $req ) if $f;  
168    
169          };          };
170    
171          if ( $@ ) {          if ( $@ ) {
172                  warn $@;                  warn "SERVER ERROR: $@";
173                  #$req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it  #               $req->conn->send_error( 404 );  # FIXME this should probably be 500, but we can't ship page with it
174                  $req->print( qq{<pre class="error">$@<pre>} );                  $req->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
175                  Carp::REPL::repl;       # FIXME if $self->debug  #               Carp::REPL::repl;
   
176          }          }
177    
178          # If this is a request for the pushtream, then give them that          # If this is a request for the pushtream, then give them that
# Line 113  sub main { Line 180  sub main {
180                  pushstream($req);                  pushstream($req);
181          }          }
182    
         if ( $path =~ m/die/ ) {  
                 Carp::REPL::repl;       # FIXME if $self->debug  
         }  
   
183          # If they are sending us a message, we give them a thread for that too          # If they are sending us a message, we give them a thread for that too
184          if($path =~ /sendmessage/) {          if($path =~ /sendmessage/) {
185                  send_message($req);                  send_message($req);
186          }          }
187    
188            if ( $req->conn ) {
189                    $req->print( "\r\n" ); # flush
190                    $req->conn->close;
191                    warn "## close connection: $@";
192            }
193  }  }
194    
195  # Here we accept a connection to the browser, and keep it open. Meanwhile we  # Here we accept a connection to the browser, and keep it open. Meanwhile we
# Line 161  sub send_message { Line 229  sub send_message {
229    }    }
230  }  }
231    
232    sub refresh {
233            my ( $url, $time ) = @_;
234            $url  ||= '/';
235            $time ||= 1;
236            warn "# refresh $url";
237            qq|
238                    <html>
239                    <head>
240                            <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
241                    </head>
242                    <body>
243                            Refresh <a href="$url"><tt>$url</tt></a> in $time sec
244                    </body>
245                    </html>
246                    \n\r\n\r
247            |; # XXX newlines at end are important to flush content to browser
248    }
249    
250  1;  1;
Legend:
Removed from v.179  
changed lines
  Added in v.589
  ViewVC Help
Powered by ViewVC 1.1.26