/[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

Annotation of /trunk/lib/Frey/Server.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 106 - (hide annotations)
Sun Jul 13 12:22:14 2008 UTC (15 years, 8 months ago) by dpavlin
File size: 3379 byte(s)
added Frey::Collection role to database models
1 dpavlin 19 package Frey::Server;
2 dpavlin 2
3 dpavlin 55 use Moose;
4 dpavlin 10
5 dpavlin 100 with 'Frey::Web';
6    
7 dpavlin 2 use Continuity;
8 dpavlin 36 #use Continuity::REPL;
9 dpavlin 2 use Data::Dump qw/dump/;
10    
11 dpavlin 101 use Frey::ClassLoader;
12 dpavlin 23
13 dpavlin 2 my @messages; # Global (shared) list of messages
14     my $got_message; # Flag to indicate that there is a new message to display
15    
16 dpavlin 10 use vars qw( $repl $server );
17 dpavlin 2
18 dpavlin 34 #$repl = Continuity::REPL->new;
19 dpavlin 37
20 dpavlin 25 sub run {
21 dpavlin 103 my ( $self, $port ) = @_;
22 dpavlin 64 $server = Continuity->new(
23 dpavlin 103 port => $port || 16001,
24 dpavlin 64 path_session => 1,
25     cookie_session => 'sid',
26     callback => \&main,
27     debug_level => 1,
28     staticp => sub { $_[0]->url =~ m/\.(jpg|jpeg|gif|png|css|ico|js|html?)$/ },
29     );
30 dpavlin 101 Frey::ClassLoader->new->load_all_classes();
31 dpavlin 25 $server->loop;
32     }
33 dpavlin 2
34     # This is the main entrypoint. We are looking for one of three things -- a
35     # pushstream, a sent message, or a request for the main HTML. We delegate each
36     # of these cases, none of which will return (they all loop forever).
37     sub main {
38 dpavlin 37 my ($req) = @_;
39 dpavlin 2
40 dpavlin 37 my $path = $req->request->url->path;
41     warn "REQUEST: $path\n";
42 dpavlin 2
43     warn $req->request->header('User_Agent');
44     #warn dump( $req );
45    
46 dpavlin 66 eval {
47    
48     if ( $path =~ m!/~/([^/]+)(?:/([^/]*))?! ) {
49     my $f = Frey::Introspect->new( package => $1 );
50     $f->html( $req );
51     }
52    
53     if ( $path =~ m!/ob/([^/]+)(?:/([^/]*))?! ) {
54 dpavlin 101 my $f = Frey::ObjectBrowser->new( fey_class => $1 );
55 dpavlin 66 $f->html( $req );
56     }
57    
58     };
59    
60     if ( $@ ) {
61     warn $@;
62     #$req->conn->send_error( 404 ); # FIXME this should probably be 500, but we can't ship page with it
63     $req->print( qq{<pre class="error">$@<pre>} );
64 dpavlin 67
65     } else {
66    
67 dpavlin 100 my $f = Frey::ClassLoader->new;
68     my $classes = dom2html(
69 dpavlin 67 ul => [
70     map {
71     warn dump( $_ );
72 dpavlin 101 my $package = $_;
73 dpavlin 67 ( li => [
74     a => { href => '/~/' . $package . '/' } => [ $package ],
75 dpavlin 101 ' <tt>', $f->package_path( $package ), '</tt> ',
76 dpavlin 106 $package->can('collection') ?
77     ( a => { href => '/ob/' . $package } => [ 'collection' ] ) : '',
78 dpavlin 67 ] )
79 dpavlin 101 } $f->classes
80 dpavlin 67 ],
81 dpavlin 100 );
82 dpavlin 67 $req->print( $classes );
83    
84 dpavlin 53 }
85    
86 dpavlin 37 # If this is a request for the pushtream, then give them that
87     if($path =~ /pushstream/) {
88     pushstream($req);
89     }
90 dpavlin 2
91 dpavlin 37 # If they are sending us a message, we give them a thread for that too
92     if($path =~ /sendmessage/) {
93     send_message($req);
94     }
95 dpavlin 2
96     }
97    
98     # Here we accept a connection to the browser, and keep it open. Meanwhile we
99     # watch the global $got_message variable, and when it gets touched we send off
100     # the list of messages through the held-open connection. Then we let the
101     # browser open a new connection and begin again.
102     sub pushstream {
103     my ($req) = @_;
104     # Set up watch event -- this will be triggered when $got_message is written
105     my $w = Coro::Event->var(var => \$got_message, poll => 'w');
106     while(1) {
107     print STDERR "**** GOT MESSAGE, SENDING ****\n";
108     my $log = join "<br>", @messages;
109     $req->print($log);
110     $req->next;
111     print STDERR "**** Waiting for got_message indicator ****\n";
112     $w->next;
113     }
114     }
115    
116    
117     # Watch for the user to send us a message. As soon as we get it, we add it to
118     # our list of messages and touch the $got_message flag to let all the
119     # pushstreams know.
120     sub send_message {
121     my ($req) = @_;
122     while(1) {
123     my $msg = $req->param('message');
124     my $name = $req->param('username');
125     if($msg) {
126     unshift @messages, "$name: $msg";
127     pop @messages if $#messages > 15; # Only keep the recent 15 messages
128     }
129     $got_message = 1;
130     $req->print("Got it!");
131     $req->next;
132     }
133     }
134    
135 dpavlin 25 1;

  ViewVC Help
Powered by ViewVC 1.1.26