lib/Frey/Server.pm

package Frey::Server;

use strict;
use warnings;

use Continuity;
#use Continuity::REPL;
use Data::Dump qw/dump/;

use base 'Frey';
use Frey::HTML;

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;
$server = Continuity->new(
        port => 16001,
        path_session => 1,
        cookie_session => 'sid',
        callback => \&main,
);
$server->debug_level( 2 );

sub run {
        $server->loop;
}

my @callbacks;
my $callback_count;

sub gen_link {
        my ($text, $code) = @_;
        $callbacks[$callback_count] = $code;
        my $out = qq{<a href="?cb=$callback_count">$text</a>};
        $callback_count++;
        return $out;
}

sub process_links {
        my $request = shift;
        my $cb = $request->param('cb');
        if (exists $callbacks[$cb]) {
                $callbacks[$cb]->($request);
#               delete $callbacks[$cb];
        }
}

# This is the main entrypoint. We are looking for one of three things -- a
# pushstream, a sent message, or a request for the main HTML. We delegate each
# of these cases, none of which will return (they all loop forever).
sub main {
        my ($req) = @_;
  
        my $path = $req->request->url->path;
        warn "REQUEST: $path\n";

        warn $req->request->header('User_Agent');
#warn dump( $req );

        # 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 ( $path =~ m/test/ ) {
                use Data::Dumper;
                $Data::Dumper::Deparse = 1;

                my $x = 0;
                my $continue = 1;
                my $link1 = gen_link('+' => sub { $x++ });
                my $link2 = gen_link('-' => sub { $x-- });
                my $out = gen_link('X' => sub { $continue = 0 });
                while ( $continue ) {
                        warn "## x = $x ",dump( $req->params );
                        $req->print("\$x is now: $x");
                        $req->print($link1, ' ', $link2, ' ', $out);
                        $req->print('<pre>'.Dumper( @callbacks ).'</pre>');
                        $req->next;
                        process_links($req);
                }
        }

        # Otherwise, lets give them page
        send_page($req);
}

# 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;
  }
}

# This isn't a pushstream, nor a new message. It is just the main page. We loop
# in case they ask for it multiple times :)
sub send_page {
        my ($req) = @_;
        my $templates = Template::Declare->templates;
        while(1) {
                warn "param = ",dump($req->param);
                my $path = $req->request->url->path;

                my $html;

                if ( $path =~ m/::/ ) {
                        my ( undef, $module, $method ) = split(m!/!, $path, 3);

                        if ( ! defined( $templates->{$module} ) ) {
                                $req->conn->send_status_line( 404, "$module" );
                                $html = "Package $module not found";
                        } elsif ( ! $method ) {
                                $html = Frey::HTML->page( 'package-methods', $req, $module );
                        } elsif ( grep(/^\Q$method\E$/, @{ $templates->{$module} }) ) {
                                $html = Frey::HTML->page( $method, $req );
                        } else {
                                $req->conn->send_status_line( 404, "$module $method" );
                                $html = "Package $module doesn't have $method";
                        }
                } else {
                        warn "fallback to status page\n";
                        $html = Frey::HTML->page( 'status' );
                }

                $req->print( $html );
                warn ">> ",length( $html ), " bytes\n";
                $req->next;
        }
}

1;
1	dpavlin	19	package Frey::Server;
2	dpavlin	2
3	dpavlin	19	use strict;
4	dpavlin	10	use warnings;
5
6	dpavlin	2	use Continuity;
7	dpavlin	36	#use Continuity::REPL;
8	dpavlin	2	use Data::Dump qw/dump/;
9
10	dpavlin	23	use base 'Frey';
11			use Frey::HTML;
12
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			$server = Continuity->new(
20	dpavlin	37	port => 16001,
21			path_session => 1,
22			cookie_session => 'sid',
23			callback => \&main,
24	dpavlin	34	);
25			$server->debug_level( 2 );
26	dpavlin	37
27	dpavlin	25	sub run {
28			$server->loop;
29			}
30	dpavlin	2
31	dpavlin	34	my @callbacks;
32			my $callback_count;
33
34			sub gen_link {
35			my ($text, $code) = @_;
36	dpavlin	37	$callbacks[$callback_count] = $code;
37			my $out = qq{<a href="?cb=$callback_count">$text</a>};
38			$callback_count++;
39			return $out;
40	dpavlin	34	}
41
42			sub process_links {
43			my $request = shift;
44			my $cb = $request->param('cb');
45			if (exists $callbacks[$cb]) {
46			$callbacks[$cb]->($request);
47	dpavlin	37	# delete $callbacks[$cb];
48	dpavlin	34	}
49			}
50
51	dpavlin	2	# This is the main entrypoint. We are looking for one of three things -- a
52			# pushstream, a sent message, or a request for the main HTML. We delegate each
53			# of these cases, none of which will return (they all loop forever).
54			sub main {
55	dpavlin	37	my ($req) = @_;
56	dpavlin	2
57	dpavlin	37	my $path = $req->request->url->path;
58			warn "REQUEST: $path\n";
59	dpavlin	2
60			warn $req->request->header('User_Agent');
61			#warn dump( $req );
62
63	dpavlin	37	# If this is a request for the pushtream, then give them that
64			if($path =~ /pushstream/) {
65			pushstream($req);
66			}
67	dpavlin	2
68	dpavlin	37	# If they are sending us a message, we give them a thread for that too
69			if($path =~ /sendmessage/) {
70			send_message($req);
71			}
72	dpavlin	2
73	dpavlin	37	if ( $path =~ m/test/ ) {
74			use Data::Dumper;
75			$Data::Dumper::Deparse = 1;
76
77			my $x = 0;
78			my $continue = 1;
79			my $link1 = gen_link('+' => sub { $x++ });
80			my $link2 = gen_link('-' => sub { $x-- });
81			my $out = gen_link('X' => sub { $continue = 0 });
82			while ( $continue ) {
83			warn "## x = $x ",dump( $req->params );
84			$req->print("\$x is now: $x");
85			$req->print($link1, ' ', $link2, ' ', $out);
86			$req->print('<pre>'.Dumper( @callbacks ).'</pre>');
87			$req->next;
88			process_links($req);
89			}
90			}
91
92			# Otherwise, lets give them page
93			send_page($req);
94	dpavlin	2	}
95
96			# Here we accept a connection to the browser, and keep it open. Meanwhile we
97			# watch the global $got_message variable, and when it gets touched we send off
98			# the list of messages through the held-open connection. Then we let the
99			# browser open a new connection and begin again.
100			sub pushstream {
101			my ($req) = @_;
102			# Set up watch event -- this will be triggered when $got_message is written
103			my $w = Coro::Event->var(var => \$got_message, poll => 'w');
104			while(1) {
105			print STDERR "** GOT MESSAGE, SENDING **\n";
106			my $log = join "<br>", @messages;
107			$req->print($log);
108			$req->next;
109			print STDERR "** Waiting for got_message indicator **\n";
110			$w->next;
111			}
112			}
113
114
115			# Watch for the user to send us a message. As soon as we get it, we add it to
116			# our list of messages and touch the $got_message flag to let all the
117			# pushstreams know.
118			sub send_message {
119			my ($req) = @_;
120			while(1) {
121			my $msg = $req->param('message');
122			my $name = $req->param('username');
123			if($msg) {
124			unshift @messages, "$name: $msg";
125			pop @messages if $#messages > 15; # Only keep the recent 15 messages
126			}
127			$got_message = 1;
128			$req->print("Got it!");
129			$req->next;
130			}
131			}
132
133			# This isn't a pushstream, nor a new message. It is just the main page. We loop
134			# in case they ask for it multiple times :)
135	dpavlin	19	sub send_page {
136	dpavlin	23	my ($req) = @_;
137			my $templates = Template::Declare->templates;
138			while(1) {
139			warn "param = ",dump($req->param);
140			my $path = $req->request->url->path;
141
142	dpavlin	30	my $html;
143
144	dpavlin	23	if ( $path =~ m/::/ ) {
145			my ( undef, $module, $method ) = split(m!/!, $path, 3);
146
147			if ( ! defined( $templates->{$module} ) ) {
148			$req->conn->send_status_line( 404, "$module" );
149	dpavlin	30	$html = "Package $module not found";
150	dpavlin	28	} elsif ( ! $method ) {
151	dpavlin	30	$html = Frey::HTML->page( 'package-methods', $req, $module );
152	dpavlin	23	} elsif ( grep(/^\Q$method\E$/, @{ $templates->{$module} }) ) {
153	dpavlin	30	$html = Frey::HTML->page( $method, $req );
154	dpavlin	23	} else {
155			$req->conn->send_status_line( 404, "$module $method" );
156	dpavlin	30	$html = "Package $module doesn't have $method";
157	dpavlin	23	}
158			} else {
159	dpavlin	30	warn "fallback to status page\n";
160			$html = Frey::HTML->page( 'status' );
161	dpavlin	23	}
162	dpavlin	30
163			$req->print( $html );
164			warn ">> ",length( $html ), " bytes\n";
165	dpavlin	23	$req->next;
166			}
167	dpavlin	2	}
168
169	dpavlin	25	1;