/[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 184 by dpavlin, Tue Sep 9 23:15:46 2008 UTC revision 793 by dpavlin, Wed Dec 10 17:51:29 2008 UTC
# Line 1  Line 1 
1  package Frey::Server;  package Frey::Server;
2    
3  use Moose;  use Moose;
4    extends 'Frey::Editor';
5    with 'Frey::Config';
6    
 with 'Frey::Web';  
   
 use Continuity;  
 #use Continuity::REPL;  
7  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
8    
9  use Carp::REPL;  use lib 'lib';
10  use Frey::ClassLoader;  use Frey::Run;
   
 my @messages;    # Global (shared) list of messages  
 my $got_message; # Flag to indicate that there is a new message to display  
   
 use vars qw( $repl $server );  
   
 #$repl = Continuity::REPL->new;  
11    
12  =head1 NAME  has 'port' => (
13            documentation => 'port on which server listen',
14            is => 'ro',
15            isa => 'Int',
16            default => sub {
17                    my $self = shift;
18                    $ENV{FREY_PORT} || $self->config->{port} || 16001
19            },
20    );
21    
22    has 'editor' => (
23            is => 'ro',
24            isa => 'Frey::Editor',
25            lazy => 1,
26            default => sub {
27                    Frey::Editor->new;
28            },
29    );
30    
31  Frey::Server - Continuity based server for Frey  =head2 request
32    
33  =head2 DESCRIPTION  This is simple dispatcher for our server. Currently it's in flux and
34    documented only in source code.
 This is one of pissible server implementations for Frey. In it's current stage, it's also most complete one.  
   
 =head2 run  
35    
36    $o->run( $optional_port );    my $content_type = $self->request( $url, $params );
37    
38  =cut  =cut
39    
40  sub run {  sub print {
41          my ( $self, $port ) = @_;          my $self = shift;
42          $server = Continuity->new(          warn "# print ", join(' ', map { length $_ } @_ );
43                  port => $port || 16001,          $self->{_print}->( @_ );
                 path_session => 1,  
                 cookie_session => 'sid',  
                 callback => \&main,  
                 debug_level => 1,  
                 staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$/ },  
         );  
         $Module::Reload::Debug = 1;  
         Frey::ClassLoader->new->load_all_classes();  
         $server->loop;  
44  }  }
45    
46  =head2 main  sub request {
47            my ( $self, $url, $params ) = @_;
48    
49  This is simple dispatcher for our server. Currently it's in flux and          if ( my $ref = ref($url) ) {
50  documented only in source code.                  die "url not URI but ", dump( $url ) unless $ref =~ m{^URI};
51            } else {
52                    $url = URI->new($url);
53            }
54    
55  =cut          my $path = $url->path;
56            my $content_type = 'text/plain';
57    
58            eval {
59    #       {
60    
61  sub main {                  if ( $path =~ m{/reload(.*)} ) {
         my ($req) = @_;  
     
         my $path = $req->request->url->path;  
         warn "REQUEST: $path ",dump( $req->params ),"\n";  
62    
63          Module::Reload->check if $path =~ m!reload! || $req->param('reload');                          $ENV{FREY_NO_LOG} = 1;
64                            my $cmd = "perl -c $0";
65                            warn "# check syntax with $cmd";
66                            if ( system($cmd) == 0 ) {
67                                    my $server = Frey::Server->new;
68                                    $self->load_config;
69    #                               Module::Reload->check;
70                                    warn "# reload done";
71                                    $self->print( refresh( $1, 0 ) );
72                                    return;
73                            } else {
74                                    warn "ERROR: $?";
75                            }
76                            $ENV{FREY_NO_LOG} = 0;
77            
78                    } elsif ( $path =~ m{/exit(.*)} ) {
79                            # FIXME do we need some kind of check here for production? :-)
80                            # ./bin/dev.sh will restart us during development
81                            $self->print( refresh( $1, 2 ) );
82                            exit;
83                    }
84    
85  #       warn $req->request->header('User_Agent');                  my $html;
86    
87  #       eval {                  sub rest2class {
88          {                          my $class = shift;
89                            $class =~ s/-/::/; # sigh!
90                            return $class;
91                    }
92    
93                  my $f;                  my $f;
94    
95                  if ( $path =~ m!/~/([^/]+)(.*)! ) {                  # shared run params
96                          $f = Frey::Introspect->new( package => $1 );                  my $run = {
97                  } elsif ( $path =~ m!/ob/([^/]+)(.*)! ) {                          request_url => $url,
98                          $f = Frey::ObjectBrowser->new( fey_class => $1 );  #                       debug => 1,
99                  } elsif ( $path =~ m!/od/([^/]+)(.*)! ) {                  };
100                          $f = Frey::ObjectDesigner->new( fey_class => $1 );  
101                  } elsif ( $path =~ m!/(markup|html)/([^/]+)(.*)! ) {                  if (
102                          $f = Frey::Run->new( class => $2 );                          $path =~ m{/Frey[:-]+ObjectBrowser}
103                    ) {
104                            $f = Frey::ObjectBrowser->new( fey_class => $params->{class} );
105    #                       $f->request( $req );
106                    } elsif (
107                            $path =~ m{/Frey[:-]+ObjectDesigner}
108                    ) {
109                            $f = Frey::ObjectDesigner->new( fey_class => $params->{class} );
110    #                       $f->request( $req );
111                    } elsif ( $path =~ $self->editor->url_regex ) {
112                            $self->print( $self->editor->command( $path ) );
113                            return;
114                    } elsif (
115                            $path =~ m{/([^/]+)/(\w*as_\w+)/?([^/]+)?}
116                    ) {
117                            my $class = rest2class $1;
118                            warn "# run $path -> $class $2";
119                            $run->{format} = $3 if $3;
120                            $run->{$_} = $params->{$_} foreach keys %$params;
121                            $f = Frey::Run->new( class => $class, params => $run, run => $2 );
122                    } elsif (
123                            $path =~ m{/([^/]+)/?$}
124                    ) {
125                            my $class = rest2class $1;
126                            warn "# introspect $class";
127                            $run->{class} ||= $class;
128                            $f = Frey::Run->new( class => 'Frey::Introspect', params => $run );
129                    } else {
130                            $f = Frey::Run->new( class => 'Frey::Class::Browser', params => $run );
131                    }
132    
133                    if ( $f ) {
134                            $f->clean_status;
135    #                       $f->add_status( { request => $req } );
136                            $f->status_parts;
137                            if ( my $html = $f->html ) {
138                                    warn "## html ",length($html)," bytes";
139                                    $self->print( $html );
140                            } else {
141                                    confess "no output from $f";
142                            }
143                  } else {                  } else {
144                          $f = Frey::ClassBrowser->new;                          confess "# can't call request on nothing!";
145                  }                  }
                 $f->html( $req ) if $f;  
146    
147                    $content_type = $f->content_type;
148          };          };
149    
150          if ( $@ ) {          if ( $@ ) {
151                  warn $@;                  warn "SERVER ERROR: $@";
152                  #$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
153                  $req->print( qq{<pre class="error">$@<pre>} );                  $self->print( qq{<pre class="frey-error">$@<pre>\r\n\r\n} );
154                  Carp::REPL::repl;       # FIXME if $self->debug  #               Carp::REPL::repl;
   
         }  
   
         # If this is a request for the pushtream, then give them that  
         if($path =~ /pushstream/) {  
                 pushstream($req);  
         }  
   
         if ( $path =~ m/die/ ) {  
                 Carp::REPL::repl;       # FIXME if $self->debug  
         }  
   
         # If they are sending us a message, we give them a thread for that too  
         if($path =~ /sendmessage/) {  
                 send_message($req);  
155          }          }
156    
157            return $content_type;
158  }  }
159    
160  # Here we accept a connection to the browser, and keep it open. Meanwhile we  sub refresh {
161  # watch the global $got_message variable, and when it gets touched we send off          my ( $url, $time ) = @_;
162  # the list of messages through the held-open connection. Then we let the          $url  ||= '/';
163  # browser open a new connection and begin again.          $time ||= 0;
164  sub pushstream {          warn "# refresh $url";
165    my ($req) = @_;          qq|
166    # Set up watch event -- this will be triggered when $got_message is written                  <html>
167    my $w = Coro::Event->var(var => \$got_message, poll => 'w');                  <head>
168    while(1) {                          <META HTTP-EQUIV="Refresh" CONTENT="$time; URL=$url"></META>
169      print STDERR "**** GOT MESSAGE, SENDING ****\n";                  </head>
170      my $log = join "<br>", @messages;                  <body>
171      $req->print($log);                          Refresh <a href="$url"><tt>$url</tt></a> in $time sec
172      $req->next;                  </body>
173      print STDERR "**** Waiting for got_message indicator ****\n";                  </html>
174      $w->next;                  \n\r\n\r
175    }          |; # XXX newlines at end are important to flush content to browser
 }  
   
   
 # 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;  
   }  
176  }  }
177    
178  1;  1;
Legend:
Removed from v.184  
changed lines
  Added in v.793
  ViewVC Help
Powered by ViewVC 1.1.26