view release on metacpan or  search on metacpan

lib/App/Phoebe/Gopher.pm  view on Meta::CPAN

=cut

package App::Phoebe::Gopher;
use App::Phoebe qw(get_ip_numbers $log $server @extensions port space pages blog_pages
		   space_regex reserved_regex run_extensions text search);
use Modern::Perl;
use URI::Escape;
use List::Util qw(min);
use Encode qw(encode_utf8 decode_utf8);
use Text::Wrapper;
use utf8;

our $gopher_header = "iPhlog:\n"; # must start with 'i'
our $gopher_port ||= 70;
our $gophers_port = [];
our $gopher_host;
our $gopher_main_page;
our ($server, $log, @main_menu);

use Mojo::IOLoop;

# start the loop after configuration (so that the user can change $gopher_port)
Mojo::IOLoop->next_tick(\&gopher_startup);

sub gopher_startup {
  $gopher_host ||= (keys %{$server->{host}})[0];
  for my $address (get_ip_numbers($gopher_host)) {
    my @ports = ref $gopher_port ? @$gopher_port : ($gopher_port);
    my %tls = map { push(@ports, $_); $_ => 1 } ref $gophers_port ? @$gophers_port : ($gophers_port);
    for my $port (@ports) {
      $log->info("$gopher_host: listening on $address:$port (Gopher)");
      Mojo::IOLoop->server({
	address => $address,
	port => $port,
	tls => $tls{$port},
	tls_cert => $server->{cert_file},
	tls_key  => $server->{key_file},
      } => sub {
	my ($loop, $stream) = @_;
	my $buffer;
	$stream->on(read => sub {
	  my ($stream, $bytes) = @_;
	  $log->debug("Received " . length($bytes) . " bytes via Gopher");
	  $buffer .= $bytes;
	  if ($buffer =~ /^(.*)\r\n/) {
	    $log->debug("Looking at " . ($1 || "an empty selector"));
	    serve_gopher($stream, $1);
	  } else {
	    $log->debug("Waiting for more bytes...");
	  }
	});
      });
    }
  }
}

sub serve_gopher {
  my ($stream, $selector) = @_;
  eval {
    local $SIG{'ALRM'} = sub {
      $log->error("Timeout processing $selector via Gopher");
    };
    alarm(10); # timeout
    my $port = port($stream);
    my $host = $gopher_host;
    my $spaces = space_regex();
    my $reserved = reserved_regex($stream);
    my $query;
    $log->debug("Serving Gopher on $host for spaces $spaces");
    $log->info("Looking at " . ($selector || "an empty selector"));
    my ($space, $id, $n, $style, $filter);
    if (run_extensions($stream, $selector)) {
      # config file goes first
    } elsif (($space) = $selector =~ m!^($spaces)?(?:/page)?/?$!) {
      # "up" from page/Alex gives us page or page/ → show main menu
      gopher_main_menu($stream, $host, space($stream, $host, $space));
    } elsif (($space, $n) = $selector =~ m!^(?:($spaces)/)?do/more(?:/(\d+))?$!) {
      gopher_serve_blog($stream, $host, space($stream, $host, $space), $n);
    } elsif (($space) = $selector =~ m!^(?:($spaces)/)?do/index$!) {
      gopher_serve_index($stream, $host, space($stream, $host, $space));
    } elsif ($selector =~ m!^do/source$!) {
      seek DATA, 0, 0;
      local $/ = undef; # slurp
      $stream->write(encode_utf8 <DATA>);
    } elsif (($space, $query) = $selector =~ m!^(?:($spaces)/)?do/match\t(.+)!) {
      gopher_serve_match($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($query)));
    } elsif (($space, $query) = $selector =~ m!^(?:($spaces)/)?do/search\t(.+)!) {
      gopher_serve_search($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($query)));
    } elsif (($space, $id, $n) = $selector =~ m!^(?:($spaces)/)?(?:page/)?([^/]+)(?:/(\d+))?$!) {
      # the /page is optional: makes finger possible
      gopher_serve_page($stream, $host, space($stream, $host, $space), decode_utf8(uri_unescape($id)), $n);
    } else {
      $log->info("No handler for $selector via gopher");
      $stream->write("Don't know how to handle $selector\r\n");
    }
    $log->debug("Done");
  };
  $log->error("Error: $@") if $@;
  alarm(0);
  $stream->close_gracefully();
}

sub gopher_link {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $title = shift;
  my $id = shift || "page/$title";
  my $type = shift || 0;
  my $port = port($stream);
  $stream->write(encode_utf8 join("\t", $type . $title, $id, $host, $port) . "\n");
}

sub gopher_menu_link {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $title = shift;
  my $selector = shift;
  my $port = port($stream);
  $stream->write(encode_utf8 join("\t", "1" . $title, $selector, $host, $port) . "\n");