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