/[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 115 by dpavlin, Sun Jul 13 18:01:19 2008 UTC revision 617 by dpavlin, Sat Nov 29 15:05:55 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    our $editor = Frey::Editor->new;
39    
40  sub run {  sub run {
41          my ( $self, $port ) = @_;          my ( $self, $port ) = @_;
42          $server = Continuity->new(          $server = Continuity->new(
43                  port => $port || 16001,                  port => $port || $self->config->{port} || 16001,
44                  path_session => 1,                  path_session => 1,
45                  cookie_session => 'sid',                  cookie_session => 'sid',
46                  callback => \&main,                  callback => \&main,
47                  debug_level => 1,                  debug_level => 2,
48                  staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?)$/ },                  staticp => sub {
49                            $_[0]->url =~ m{^/+(static|var).*\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$}
50                    },
51          );          );
52          $Module::Reload::Debug = 1;          $Module::Reload::Debug = 1; # auto if debug_level > 1
53          Frey::ClassLoader->new->load_all_classes();          Frey::ClassLoader->new->load_all_classes();
54            $editor->switch_screen if $ENV{FREY_SWITCH_SCREEN};
55          $server->loop;          $server->loop;
56  }  }
57    
58  # This is the main entrypoint. We are looking for one of three things -- a  =head2 main
59  # pushstream, a sent message, or a request for the main HTML. We delegate each  
60  # 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
61    documented only in source code.
62    
63    =cut
64    
65  sub main {  sub main {
66          my ($req) = @_;          my ($req) = @_;
     
         my $path = $req->request->url->path;  
         warn "REQUEST: $path\n";  
67    
68          warn $req->request->header('User_Agent');  #       $req->send_headers("X-Frey-VERSION: $Frey::VERSION");
69  #warn dump( $req );  
70            my $path = $req->request->url->path;
71    
72          eval {          eval {
73    
74                    if ( $path =~ m{/reload(.*)} ) {
75    
76                            $ENV{FREY_NO_LOG} = 1;
77                            my $cmd = "perl -c $0";
78                            warn "# check config with $cmd";
79                            if ( system($cmd) == 0 ) {
80                                    $req->print( "\r\n" );
81                                    my $server = Frey::Server->new;
82                                    $server->load_config;
83                                    $req->print( "\r\n" );
84                                    Module::Reload->check;
85                                    $req->print( "\r\n" );
86                                    $req->print( refresh( $1, 1 ) );
87                                    $req->print( "\r\n" );
88                                    warn "# reload done";
89                                    return;
90                            } else {
91                                    warn "ERROR: $?";
92                            }
93                            $ENV{FREY_NO_LOG} = 0;
94            
95                    } elsif ( $path =~ m{/exit(.*)} ) {
96                            # FIXME do we need some kind of check here for production? :-)
97                            # ./bin/dev.sh will restart us during development
98                            $req->print( refresh( $1, 2 ) );
99                            $req->print( "\r\n" );
100                            exit;
101                    }
102    
103    #               warn $req->request->header('User_Agent');
104    
105                    my %params = $req->params;
106                    my $html;
107    
108                    sub rest2class {
109                            my $class = shift;
110                            $class =~ s/-/::/; # sigh!
111                            return $class;
112                    }
113    
114    
115                  my $f;                  my $f;
116    
117                  if ( $path =~ m!/~/([^/]+)(.*)! ) {                  # shared run params
118                          $f = Frey::Introspect->new( package => $1 );                  my $run = {
119                  } elsif ( $path =~ m!/ob/([^/]+)(.*)! ) {                          request_url => $req->request->url,
120                          $f = Frey::ObjectBrowser->new( fey_class => $1 );                          debug => 1,
121                  } elsif ( $path =~ m!/od/([^/]+)(.*)! ) {                  };
122                          $f = Frey::ObjectDesigner->new( fey_class => $1 );  
123                    if (
124                            $path =~ m{/Frey[:-]+ObjectBrowser}
125                    ) {
126                            $f = Frey::ObjectBrowser->new( fey_class => $params{class} );
127                            $f->request( $req );
128                    } elsif (
129                            $path =~ m{/Frey[:-]+ObjectDesigner}
130                    ) {
131                            $f = Frey::ObjectDesigner->new( fey_class => $params{class} );
132                            $f->request( $req );
133                    } elsif ( $path =~ $editor->url_regex ) {
134                            $req->print( $editor->command( $path ) );
135                            $editor->command( $path );
136                            return;
137                    } elsif (
138                            $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
139                    ) {
140                            my $class = rest2class $1;
141                            warn "# run $path -> $class $2";
142                            $run->{format} = $3 if $3;
143                            $params{request_url} = $req->request->url;
144                            $req->print( "\r\n\r\n" ); # send something to browser so we don't time-out
145                            $f = Frey::Run->new( class => $class, params => \%params, run => $2, %$run );
146                    } elsif (
147                            $path =~ m{/([^/]+)/?$}
148                    ) {
149                            my $class = rest2class $1;
150                            warn "# introspect $class";
151                            $f = Frey::Run->new( class => 'Frey::Introspect', params => { class => $class }, %$run );
152                    } else {
153                            $f = Frey::Run->new( class => 'Frey::ClassBrowser', %$run );
154                    }
155    
156                    if ( $f ) {
157                            $f->clean_status;
158                            $f->add_status( { request => $req } );
159                            $f->status_parts;
160                            if ( my $html = $f->html ) {
161                                    warn "## html ",length($html)," bytes";
162                                    $req->print( $html );
163                            } else {
164                                    confess "no output from $f";
165                            }
166                    } else {
167                            confess "# can't call request on nothing!";
168                  }                  }
                 $f->html( $req ) if $f;  
169    
170          };          };
171    
172          if ( $@ ) {          if ( $@ ) {
173                  warn $@;                  warn "SERVER ERROR: $@";
174                  #$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
175                  $req->print( qq{<pre class="error">$@<pre>} );                  $req->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
176  #               Carp::REPL::repl;       # FIXME if $self->debug  #               Carp::REPL::repl;
         } else {  
   
                 my $f = Frey::ClassLoader->new;  
                 my $classes = dom2html(  
                         table => [  
                                 map {  
                                         my $package = $_;  
                                         ( tr => [  
                                                 td => [ a => { href => '/~/' . $package, title => $f->package_path( $package ) } => [ $package ] ],  
                                                 td => [ $package->can('meta') ? ( a => { href => '/od/' . $package } => [ 'design' ] ) : '' ],  
                                                 td => [ $package->can('collection') ? ( a => { href => '/ob/' . $package } => [ 'collection' ] ) : '' ],  
                                         ] )  
                                 } $f->classes  
                         ],  
                 );  
                 $req->print( "<h1>Classes</h1>$classes" );  
   
177          }          }
178    
179          # If this is a request for the pushtream, then give them that          # If this is a request for the pushtream, then give them that
180          if($path =~ /pushstream/) {          if($path =~ /pushstream/) {
181                  pushstream($req);                  pushstream($req);
182          }          }
183      
184          # 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
185          if($path =~ /sendmessage/) {          if($path =~ /sendmessage/) {
186                  send_message($req);                  send_message($req);
187          }          }
188    
189            if ( $req->conn ) {
190                    $req->print( "\r\n" ); # flush
191                    $req->conn->close;
192                    warn "## close connection: $@";
193            }
194  }  }
195    
196  # 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 133  sub send_message { Line 230  sub send_message {
230    }    }
231  }  }
232    
233    sub refresh {
234            my ( $url, $time ) = @_;
235            $url  ||= '/';
236            $time ||= 1;
237            warn "# refresh $url";
238            qq|
239                    <html>
240                    <head>
241                            <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
242                    </head>
243                    <body>
244                            Refresh <a href="$url"><tt>$url</tt></a> in $time sec
245                    </body>
246                    </html>
247                    \n\r\n\r
248            |; # XXX newlines at end are important to flush content to browser
249    }
250    
251  1;  1;
Legend:
Removed from v.115  
changed lines
  Added in v.617
  ViewVC Help
Powered by ViewVC 1.1.26