/[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 626 by dpavlin, Sat Nov 29 17:48:54 2008 UTC revision 627 by dpavlin, Sat Nov 29 22:02:08 2008 UTC
# Line 1  Line 1 
1  package Frey::Server;  package Frey::Server;
2    
3  use Moose;  use Moose;
4  extends 'Frey';  extends 'Frey::Editor';
5  with 'Frey::Config';  with 'Frey::Config';
6    
 use Continuity;  
 #use Continuity::REPL;  
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    
 #use Carp::REPL; ## XXX it would be nice, but it breaks error reporting too much  
 use Frey::ClassLoader;  
9  use Frey::Run;  use Frey::Run;
 use Frey::Editor;  
10    
11  my @messages;    # Global (shared) list of messages  has 'port' => (
12  my $got_message; # Flag to indicate that there is a new message to display          documentation => 'port on which server listen',
13            is => 'ro',
14            isa => 'Int',
15            default => sub {
16                    my $self = shift;
17                    $ENV{FREY_PORT} || $self->config->{port} || 16001
18            },
19    );
20    
21    has 'editor' => (
22            is => 'ro',
23            isa => 'Frey::Editor',
24            lazy => 1,
25            default => sub {
26                    Frey::Editor->new;
27            },
28    );
29    
30  use vars qw( $repl $server );  =head2 request
   
 #$repl = Continuity::REPL->new;  
   
 =head1 NAME  
   
 Frey::Server - Continuity based server for Frey  
   
 =head2 DESCRIPTION  
   
 This is one of pissible server implementations for Frey. In it's current stage, it's also most complete one.  
   
 =head2 run  
   
   $o->run( $optional_port );  
   
 =cut  
   
 our $editor = Frey::Editor->new;  
 our $port;  
   
 sub run {  
         my ( $self ) = @_;  
   
         $port = $ENV{FREY_PORT} || $self->config->{port} || 16001;  
   
         $server = Continuity->new(  
                 port => $port,  
                 path_session => 1,  
                 cookie_session => 'sid',  
                 callback => \&main,  
                 debug_level => 2,  
                 staticp => sub {  
                         $_[0]->url =~ m{^/+(static|var).*\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$}  
                 },  
         );  
         $Module::Reload::Debug = 1; # auto if debug_level > 1  
         Frey::ClassLoader->new->load_all_classes();  
         $editor->switch_screen if $ENV{FREY_SWITCH_SCREEN};  
         $server->loop;  
 }  
   
 =head2 main  
31    
32  This is simple dispatcher for our server. Currently it's in flux and  This is simple dispatcher for our server. Currently it's in flux and
33  documented only in source code.  documented only in source code.
34    
35  =cut  =cut
36    
37  sub main {  sub print {
38          my ($req) = @_;          my $self = shift;
39            warn "# print ",dump( @_ );
40            $self->{print}->( @_ );
41    }
42    
43    sub request {
44            my ( $self, $url, $params ) = @_;
45    
46  #       $req->send_headers("X-Frey-VERSION: $Frey::VERSION");          if ( my $ref = ref($url) ) {
47                    die "url not URI but ", dump( $url ) unless $ref =~ m{^URI};
48                    $url = URI->new($url);
49            }
50    
51          my $path = $req->request->url->path;          my $path = $url->path;
52    
53  #       eval {  #       eval {
54          {          {
# Line 79  sub main { Line 57  sub main {
57    
58                          $ENV{FREY_NO_LOG} = 1;                          $ENV{FREY_NO_LOG} = 1;
59                          my $cmd = "perl -c $0";                          my $cmd = "perl -c $0";
60                          warn "# check config with $cmd";                          warn "# check syntax with $cmd";
61                          if ( system($cmd) == 0 ) {                          if ( system($cmd) == 0 ) {
                                 $req->print( "\r\n" );  
62                                  my $server = Frey::Server->new;                                  my $server = Frey::Server->new;
63                                  $server->load_config;                                  $self->load_config;
                                 $req->print( "\r\n" );  
64                                  Module::Reload->check;                                  Module::Reload->check;
                                 $req->print( "\r\n" );  
                                 $req->print( refresh( $1, 1 ) );  
                                 $req->print( "\r\n" );  
65                                  warn "# reload done";                                  warn "# reload done";
66                                    $self->print( refresh( $1, 1 ) );
67                                  return;                                  return;
68                          } else {                          } else {
69                                  warn "ERROR: $?";                                  warn "ERROR: $?";
# Line 99  sub main { Line 73  sub main {
73                  } elsif ( $path =~ m{/exit(.*)} ) {                  } elsif ( $path =~ m{/exit(.*)} ) {
74                          # FIXME do we need some kind of check here for production? :-)                          # FIXME do we need some kind of check here for production? :-)
75                          # ./bin/dev.sh will restart us during development                          # ./bin/dev.sh will restart us during development
76                          $req->print( refresh( $1, 2 ) );                          $self->print( refresh( $1, 2 ) );
                         $req->print( "\r\n" );  
77                          exit;                          exit;
78                  }                  }
79    
 #               warn $req->request->header('User_Agent');  
   
                 my %params = $req->params;  
80                  my $html;                  my $html;
81    
82                  sub rest2class {                  sub rest2class {
# Line 120  sub main { Line 90  sub main {
90    
91                  # shared run params                  # shared run params
92                  my $run = {                  my $run = {
93                          request_url => $req->request->url,                          request_url => $url,
94  #                       debug => 1,  #                       debug => 1,
95                  };                  };
96    
97                  if (                  if (
98                          $path =~ m{/Frey[:-]+ObjectBrowser}                          $path =~ m{/Frey[:-]+ObjectBrowser}
99                  ) {                  ) {
100                          $f = Frey::ObjectBrowser->new( fey_class => $params{class} );                          $f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
101                          $f->request( $req );  #                       $f->request( $req );
102                  } elsif (                  } elsif (
103                          $path =~ m{/Frey[:-]+ObjectDesigner}                          $path =~ m{/Frey[:-]+ObjectDesigner}
104                  ) {                  ) {
105                          $f = Frey::ObjectDesigner->new( fey_class => $params{class} );                          $f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
106                          $f->request( $req );  #                       $f->request( $req );
107                  } elsif ( $path =~ $editor->url_regex ) {                  } elsif ( $path =~ $self->editor->url_regex ) {
108                          $req->print( $editor->command( $path ) );                          $self->print( $self->editor->command( $path ) );
109                          return;                          return;
110                  } elsif (                  } elsif (
111                          $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}                          $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
# Line 143  sub main { Line 113  sub main {
113                          my $class = rest2class $1;                          my $class = rest2class $1;
114                          warn "# run $path -> $class $2";                          warn "# run $path -> $class $2";
115                          $run->{format} = $3 if $3;                          $run->{format} = $3 if $3;
116                          $params{request_url} = $req->request->url;                          $params->{request_url} = $url,
117                          $req->print( "\r\n\r\n" ); # send something to browser so we don't time-out                          $run->{$_} = $params->{$_} foreach keys %$params;
118                          $run->{$_} = $params{$_} foreach keys %params;                          $f = Frey::Run->new( class => $class, params => $run, run => $2, request_url => $url );
                         $f = Frey::Run->new( class => $class, params => $run, run => $2, request_url => $req->request->url );  
119                  } elsif (                  } elsif (
120                          $path =~ m{/([^/]+)/?$}                          $path =~ m{/([^/]+)/?$}
121                  ) {                  ) {
122                          my $class = rest2class $1;                          my $class = rest2class $1;
123                          warn "# introspect $class";                          warn "# introspect $class";
124                          $run->{class} ||= $class;                          $run->{class} ||= $class;
125                          $f = Frey::Run->new( class => 'Frey::Introspect', params => $run, request_url => $req->request->url );                          $f = Frey::Run->new( class => 'Frey::Introspect', params => $run, request_url => $url );
126                  } else {                  } else {
127                          $f = Frey::Run->new( class => 'Frey::ClassBrowser', params => $run, request_url => $req->request->url );                          $f = Frey::Run->new( class => 'Frey::ClassBrowser', params => $run, request_url => $url );
128                  }                  }
129    
130                  if ( $f ) {                  if ( $f ) {
131                          $f->clean_status;                          $f->clean_status;
132                          $f->add_status( { request => $req } );  #                       $f->add_status( { request => $req } );
133                          $f->status_parts;                          $f->status_parts;
134                          if ( my $html = $f->html ) {                          if ( my $html = $f->html ) {
135                                  warn "## html ",length($html)," bytes";                                  warn "## html ",length($html)," bytes";
136                                  $req->print( $html );                                  $self->print( $html );
137                          } else {                          } else {
138                                  confess "no output from $f";                                  confess "no output from $f";
139                          }                          }
# Line 177  sub main { Line 146  sub main {
146          if ( $@ ) {          if ( $@ ) {
147                  warn "SERVER ERROR: $@";                  warn "SERVER ERROR: $@";
148  #               $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
149                  $req->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );                  $self->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
150  #               Carp::REPL::repl;  #               Carp::REPL::repl;
151          }          }
152    
         # If this is a request for the pushtream, then give them that  
         if($path =~ /pushstream/) {  
                 pushstream($req);  
         }  
   
         # If they are sending us a message, we give them a thread for that too  
         if($path =~ /sendmessage/) {  
                 send_message($req);  
         }  
   
         if ( $req->conn ) {  
                 $req->print( "\r\n" ); # flush  
                 $req->conn->close;  
                 warn "## close connection: $@";  
         }  
 }  
   
 # Here we accept a connection to the browser, and keep it open. Meanwhile we  
 # watch the global $got_message variable, and when it gets touched we send off  
 # the list of messages through the held-open connection. Then we let the  
 # browser open a new connection and begin again.  
 sub pushstream {  
   my ($req) = @_;  
   # Set up watch event -- this will be triggered when $got_message is written  
   my $w = Coro::Event->var(var => \$got_message, poll => 'w');  
   while(1) {  
     print STDERR "**** GOT MESSAGE, SENDING ****\n";  
     my $log = join "<br>", @messages;  
     $req->print($log);  
     $req->next;  
     print STDERR "**** Waiting for got_message indicator ****\n";  
     $w->next;  
   }  
 }  
   
   
 # Watch for the user to send us a message. As soon as we get it, we add it to  
 # our list of messages and touch the $got_message flag to let all the  
 # pushstreams know.  
 sub send_message {  
   my ($req) = @_;  
   while(1) {  
     my $msg = $req->param('message');  
     my $name = $req->param('username');  
     if($msg) {  
       unshift @messages, "$name: $msg";  
       pop @messages if $#messages > 15; # Only keep the recent 15 messages  
     }  
     $got_message = 1;  
     $req->print("Got it!");  
     $req->next;  
   }  
153  }  }
154    
155  sub refresh {  sub refresh {
Legend:
Removed from v.626  
changed lines
  Added in v.627
  ViewVC Help
Powered by ViewVC 1.1.26