/[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 158 by dpavlin, Thu Jul 17 18:00:55 2008 UTC revision 542 by dpavlin, Wed Nov 26 19:13:53 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?)$/ },                  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) = @_;
64      
65          my $path = $req->request->url->path;          my $path = $req->request->url->path;
         warn "REQUEST: $path ",dump( $req->params ),"\n";  
66    
67          Module::Reload->check if $path =~ m!reload! || $req->param('reload');          eval {
68    
69                    sub refresh {
70                            my ( $url, $time ) = @_;
71                            $url  ||= '/';
72                            $time ||= 1;
73                            warn "# refresh $url";
74                            qq|
75                                    <html>
76                                    <head>
77                                            <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
78                                    </head>
79                                    <body>
80                                            Refresh <a href="$url"><tt>$url</tt></a> in $time sec
81                                    </body>
82                                    </html>
83                                    \n\r\n\r
84                            |; # XXX newlines at end are important to flush content to browser
85                    }
86    
87                    if ( $path =~ m{/reload(.*)} ) {
88    
89                            $ENV{FREY_NO_LOG} = 1;
90                            my $cmd = "perl -c $0";
91                            warn "# check config with $cmd";
92                            if ( system($cmd) == 0 ) {
93                                    Frey::Server->new->load_config;
94                                    Module::Reload->check;
95                                    $req->print( refresh( $1, 1 ) );
96                                    warn "# reload done";
97                                    return;
98                            } else {
99                                    warn "ERROR: $?";
100                            }
101                            $ENV{FREY_NO_LOG} = 0;
102            
103                    } elsif ( $path =~ m{/exit(.*)} ) {
104                            # FIXME do we need some kind of check here for production? :-)
105                            # ./bin/dev.sh will restart us during development
106                            $req->print( refresh( $1, 2 ) );
107                            exit;
108                    }
109    
110  #       warn $req->request->header('User_Agent');  #               warn $req->request->header('User_Agent');
111    
112                    my %params = $req->params;
113                    my $html;
114    
115                    sub rest2class {
116                            my $class = shift;
117                            $class =~ s/-/::/; # sigh!
118                            return $class;
119                    }
120    
 #       eval {  
         {  
121    
122                  my $f;                  my $f;
123    
124                  if ( $path =~ m!/~/([^/]+)(.*)! ) {                  my $editor = Frey::Editor->new;
125                          $f = Frey::Introspect->new( package => $1 );  
126                  } elsif ( $path =~ m!/ob/([^/]+)(.*)! ) {                  # shared run params
127                          $f = Frey::ObjectBrowser->new( fey_class => $1 );                  my $run = {
128                  } elsif ( $path =~ m!/od/([^/]+)(.*)! ) {                          request_url => $req->request->url,
129                          $f = Frey::ObjectDesigner->new( fey_class => $1 );                          debug => 1,
130                  } elsif ( $path =~ m!/pod/([^/]+)(.*)! ) {                  };
131                          $f = Frey::Pod->new( class => $1 );  
132                  } elsif ( $path =~ m!/markup/([^/]+)(.*)! ) {                  if (
133                          my $o = $1->new( $req->params );                          $path =~ m{/Frey[:-]+ObjectBrowser}
134                          $o->depends if $o->can('depends');                  ) {
135                          my $html = $o->markup( $req->params );                          $f = Frey::ObjectBrowser->new( fey_class => $params{class} );
136                          warn ">>> markup $1 ",length( $html ), " bytes\n";                          $f->request( $req );
137                          $req->print( $html );                  } elsif (
138                            $path =~ m{/Frey[:-]+ObjectDesigner}
139                    ) {
140                            $f = Frey::ObjectDesigner->new( fey_class => $params{class} );
141                            $f->request( $req );
142                    } elsif ( $path =~ $editor->url_regex ) {
143                            $req->print( $editor->command( $path ) );
144                            system( $editor->command( $path ) );
145                            return;
146                    } elsif (
147                            $path =~ m{/([^/]+)/(as_\w+)/?([^/]+)?}
148                    ) {
149                            my $class = rest2class $1;
150                            warn "# run $path -> $class $2";
151                            $run->{format} = $3 if $3;
152                            $params{request_url} = $req->request->url;
153                            $f = Frey::Run->new( class => $class, params => \%params, run => $2, %$run );
154                    } elsif (
155                            $path =~ m{/([^/]+)/?$}
156                    ) {
157                            my $class = rest2class $1;
158                            warn "# introspect $class";
159                            $f = Frey::Run->new( class => 'Frey::Introspect', params => { class => $class }, %$run );
160                  } else {                  } else {
161                          $f = Frey::ClassBrowser->new;                          $f = Frey::Run->new( class => 'Frey::ClassBrowser', %$run );
162                    }
163    
164                    if ( $f ) {
165                            $f->clean_status;
166                            $f->add_status( { request => $req } );
167                            warn "## status ", dump( map { keys %$_ } $f->status );
168                            my $html = $f->html;
169                            die "no html output" unless $html;
170                            warn "## html ",length($html)," bytes";
171                            eval {
172                                    $req->print( $html );
173                            };
174                            die "can't send to wire: $@" if $@;
175                    } else {
176                            warn "# can't call request on nothing!";
177                  }                  }
                 $f->html( $req ) if $f;  
178    
179          };          };
180    
181          if ( $@ ) {          if ( $@ ) {
182                  warn $@;                  warn $@;
183                  #$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
184                  $req->print( qq{<pre class="error">$@<pre>} );                  $req->print( qq{<pre class="frey-error">$@<pre>} );
185                  Carp::REPL::repl;       # FIXME if $self->debug  #               Carp::REPL::repl;
   
186          }          }
187    
188          # 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 85  sub main { Line 190  sub main {
190                  pushstream($req);                  pushstream($req);
191          }          }
192    
         if ( $path =~ m/die/ ) {  
                 Carp::REPL::repl;       # FIXME if $self->debug  
         }  
   
193          # 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
194          if($path =~ /sendmessage/) {          if($path =~ /sendmessage/) {
195                  send_message($req);                  send_message($req);
196          }          }
197    
198            if ( $req->conn ) {
199                    $req->conn->close;
200                    warn "## close connection: $@";
201            }
202  }  }
203    
204  # 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
Legend:
Removed from v.158  
changed lines
  Added in v.542
  ViewVC Help
Powered by ViewVC 1.1.26