/[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 341 by dpavlin, Sun Nov 9 09:58:13 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    
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  sub run {  sub run {
38          my ( $self, $port ) = @_;          my ( $self, $port ) = @_;
39          $server = Continuity->new(          $server = Continuity->new(
40                  port => $port || 16001,                  port => $port || $self->config->{port} || 16001,
41                  path_session => 1,                  path_session => 1,
42                  cookie_session => 'sid',                  cookie_session => 'sid',
43                  callback => \&main,                  callback => \&main,
44                  debug_level => 1,                  debug_level => 2,
45                  staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$/ },                  staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?|xml|json|ya?ml)(\?.*)?$/ },
46          );          );
47          $Module::Reload::Debug = 1;          $Module::Reload::Debug = 1; # auto if debug_level > 1
48          Frey::ClassLoader->new->load_all_classes();          Frey::ClassLoader->new->load_all_classes();
49          $server->loop;          $server->loop;
50  }  }
51    
52  # This is the main entrypoint. We are looking for one of three things -- a  =head2 main
53  # pushstream, a sent message, or a request for the main HTML. We delegate each  
54  # 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
55    documented only in source code.
56    
57    =cut
58    
59  sub main {  sub main {
60          my ($req) = @_;          my ($req) = @_;
61      
62          my $path = $req->request->url->path;          my $path = $req->request->url->path;
63          warn "REQUEST: $path ",dump( $req->params ),"\n";          #warn "REQUEST: $path ",dump( $req->params );
64    
65          Module::Reload->check if $path =~ m!reload! || $req->param('reload');          Module::Reload->check if $path =~ m!reload! || $req->param('reload');
66    
67  #       warn $req->request->header('User_Agent');  #       warn $req->request->header('User_Agent');
68    
69          sub run_markup {          my %params = $req->params;
70                  my ( $req, $class ) = @_;          my $html;
71    
72                  my %params = $req->params;          sub rest2class {
73                    my $class = shift;
74                  my @required =                  $class =~ s/-/::/; # sigh!
75                          grep {                  return $class;
                                 defined $_ && !defined( $params{$_} )  
                         }  
                         map {  
                                 my $attr = $class->meta->get_attribute($_);  
                                 $attr->is_required && $_  
                         } $class->meta->get_attribute_list;  
   
                 warn "## required = ",dump( @required );  
                 warn "## params = ",dump( %params );  
   
                 my $html;  
   
                 if ( @required ) {  
                         $html = qq|<form method="post">|;  
                         $html .= qq|<input type="text" name="$_">| foreach @required;  
                         $html .= qq|<input type="submit" value="Run $class"></form>|;  
                 } else {  
                         my $o = $class->new( %params );  
                         $o->depends if $o->can('depends');  
                         $html = $o->markup;  
                 }  
   
                 warn ">>> markup $class ",length( $html ), " bytes\n";  
                 return $html;  
76          }          }
77    
78    
79  #       eval {          eval {
         {  
80    
81                  my $f;                  my $f;
82    
83                  if ( $path =~ m!/~/([^/]+)(.*)! ) {                  my $run_regexp = join('|', Frey::Run->runnable );
84                          $f = Frey::Introspect->new( package => $1 );  
85                  } elsif ( $path =~ m!/ob/([^/]+)(.*)! ) {                  if (
86                          $f = Frey::ObjectBrowser->new( fey_class => $1 );                          $path =~ m{/Frey[:-]+ObjectBrowser}
87                  } elsif ( $path =~ m!/od/([^/]+)(.*)! ) {                  ) {
88                          $f = Frey::ObjectDesigner->new( fey_class => $1 );                          $f = Frey::ObjectBrowser->new( fey_class => $params{class} );
89                  } elsif ( $path =~ m!/markup/([^/]+)(.*)! ) {                          $f->request( $req );
90                          $req->print( run_markup( $req, $1 )  );                  } elsif (
91                            $path =~ m{/Frey[:-]+ObjectDesigner}
92                    ) {
93                            $f = Frey::ObjectDesigner->new( fey_class => $params{class} );
94                            $f->request( $req );
95                    } elsif (
96                            $path =~ m{/([^/]+)/($run_regexp)}
97                    ) {
98                            my $class = rest2class $1;
99                            warn "# run $class $2\n";
100                            $f = Frey::Run->new( class => $class, params => \%params );
101                    } elsif (
102                            $path =~ m{/([^/]+)/?$}
103                    ) {
104                            my $class = rest2class $1;
105                            warn "# introspect $class";
106                            $f = Frey::Run->new( class => 'Frey::Introspect', params => { class => $class } );
107                  } else {                  } else {
108                          $f = Frey::ClassBrowser->new;                          $f = Frey::Run->new( class => 'Frey::ClassBrowser' );
109                    }
110    
111                    if ( $f ) {
112                            $req->print( $f->html );
113                    } else {
114                            warn "# can't call request on nothing!";
115                  }                  }
                 $f->html( $req ) if $f;  
116    
117          };          };
118    
119            my $self = $req;
120    
121          if ( $@ ) {          if ( $@ ) {
122                  warn $@;                  warn $@;
123                  #$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
124                  $req->print( qq{<pre class="error">$@<pre>} );                  $req->print( qq{<pre class="error">$@<pre>} );
125                  Carp::REPL::repl;       # FIXME if $self->debug  #               Carp::REPL::repl;
126    
127          }          }
128    
# Line 113  sub main { Line 131  sub main {
131                  pushstream($req);                  pushstream($req);
132          }          }
133    
         if ( $path =~ m/die/ ) {  
                 Carp::REPL::repl;       # FIXME if $self->debug  
         }  
   
134          # 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
135          if($path =~ /sendmessage/) {          if($path =~ /sendmessage/) {
136                  send_message($req);                  send_message($req);
Legend:
Removed from v.179  
changed lines
  Added in v.341
  ViewVC Help
Powered by ViewVC 1.1.26