App-Phoebe
19 results

 view release on metacpan or  search on metacpan

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

      $revision = 1;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      result($stream, "59", "Unable to write index");
      return;
    } else {
      say $fh $id;
      close($fh);
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    result($stream, "59", "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    result($stream, "30", to_url($stream, $host, $space, "page/$id"));

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

    my @pages = grep { $_ ne $id } split /\n/, read_text $index;
    write_text($index, join("\n", @pages, ""));
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖹", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted page $id");
  result($stream, "30", to_url($stream, $host, $space, "page/$id"));
}

sub handle_gemini {
  my $stream = shift;
  my $data = shift;
  $log->debug("Handle Gemini request");

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

# header for the date (one argument). $change is a code reference that prints
# the time and code of the person making the change (two arguments). $link is a
# code reference that prints a link (four arguments). $nolink is a code reference
# that prints a name that isn't linked (one argument). $next is a code reference
# that returns the list of attributes for the next change, these attributes
# being: the timestamp (as returned by time); the page or file name; the page
# revision or zero if a file; the code to represent the person that made the
# change, represented as a string of octal digits that will be fed to the
# colourize sub; the host, and the spaces, if any; and a boolean if space and
# page or file name should both be shown (up to seven arguments). Finally, the
# optional argument $kept is a code reference to say whether an old revision
# actually exists. If not, there's no point in showing a diff link. The default
# implementation checks for the existence of the keep file. $filter describes
# how changes are to be filtered: 'latest' means that only the latest change
# will be shown, i.e. a link to current revision. The default is to show all
# changes. $style is "coloured" or "fancy" or undefined to indicate what sort of
# changes we are looking at.
sub changes {
  my $stream = shift;
  my $n = shift;
  my $header = shift;

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

      return;
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, 0, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/file" unless -d "$dir/file";
  eval { write_binary($file, $data) };
  if ($@) {
    result($stream, "59", "Unable to save $id");
    return;
  }
  mkdir "$dir/meta" unless -d "$dir/meta";
  eval { write_text($meta, "content-type: $type\n") };

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

  $log->info("Deleting file $id");
  my $dir = wiki_dir($host, $space);
  unlink("$dir/file/$id", "$dir/meta/$id");
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    result($stream, "59", "Unable to write log");
    return;
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖻", bogus_hash($peerhost));
    close($fh);
  }
  success($stream);
  $stream->write("# $id\n");
  $stream->write("The file was deleted.\n");
}

sub allow_deny_hook {
  my $stream = shift;
  my $client = shift;

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

sub capsule_name {
  my $stream = shift;
  # $stream can be a fingerprint string
  my $fingerprint = ref $stream ? $stream->handle->get_fingerprint() : $stream;
  return unless $fingerprint;
  $fingerprint = $capsule_equivalent{$fingerprint} if $capsule_equivalent{$fingerprint};
  my @stack = map { hex } substr($fingerprint, 7, 12) =~ /(....)/g;
  my $digraphs = "..lexegezacebisousesarmaindirea.eratenberalavetiedorquanteisrion";
  my $longname = $stack[0] & 0x40;
  my $name;
  # say "@stack";
  for my $n (1 .. 4) {
    my $d = (($stack[2] >> 8) & 0x1f) << 1;
    push(@stack, sum(@stack) % 0x10000);
    shift(@stack);
    $name .= substr($digraphs, $d, 2)
	if $n <= 3 or $longname;
  }
  $name =~ s/\.//g;
  return $name;
}

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


=head1 NAME

App::Phoebe::Chat - add a Gemini-based chat room for every Phoebe wiki space

=head1 DESCRIPTION

For every wiki space, this creates a Gemini-based chat room. Every chat client
needs two URLs, the "listen" and the "say" URL.

The I<Listen URL> is where you need to I<stream>: as people say things in the
room, these messages get streamed in one endless Gemini document. You might have
to set an appropriate timeout period for your connection for this to work. 1h,
perhaps?

The URL will look something like this:
C<gemini://localhost/do/chat/listen> or
C<gemini://localhost/space/do/chat/listen>

The I<Say URL> is where you post things you want to say: point your client at
the URL, it prompts your for something to say, and once you do, it redirects you

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

    $_->{stream}->write(encode_utf8 "$name joined\n");
  }
  # and get a welcome message
  success($stream);
  $stream->write(encode_utf8 "# Welcome to $host" . ($space ? "/$space" : "") . "\n");
  if (@names) {
    $stream->write(encode_utf8 "Other chat members: @names\n");
  } else {
    $stream->write("You are the only one.\n");
  }
  $stream->write("Open the following link in order to say something:\n");
  $stream->write("=> gemini://$host:$port" . ($space ? "/$space" : "") . "/do/chat/say\n");
  my @lines = grep { $host eq $_->{host} and $space eq $_->{space} } reverse @chat_lines;
  if (@lines) {
    $stream->write("Replaying some recent messages:\n");
    $stream->write(encode_utf8 "$_->{name}: $_->{text}\n") for @lines;
    $stream->write(encode_utf8 "Welcome! 🥳🚀🚀\n");
  }
  $log->debug("Added $name to the chat");
}

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

push(@extensions, \&handle_chat_say);

sub handle_chat_say {
  my $stream = shift;
  my $url = shift;
  my $hosts = host_regex();
  my $spaces = space_regex();
  my $port = port($stream);
  my ($host, $space, $text);
  if (($host, $space, $text) =
      $url =~ m!^gemini://($hosts)(?::$port)?(?:/($spaces))?/do/chat/say(?:\?([^#]*))?$!) {
    process_chat_say($stream, $host, $port, $space || "", $text);
    return 1;
  } elsif ($url =~ m!^gemini://(?:$hosts)(?::$port)?(?:/$spaces)?/do/chat$!) {
    serve_chat_explanation($stream, $url);
    return 1;
  }
  return 0;
}

sub serve_chat_explanation {

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

  my $port = shift;
  my $space = shift;
  my $text = shift;
  my $name = $stream->handle->peer_certificate('cn');
  if (not $name) {
    result($stream, "60", "You need a client certificate with a common name to talk on this chat");
    return;
  }
  my @found = grep { $host eq $_->{host} and $space eq $_->{space} and $name eq $_->{name} } @chat_members;
  if (not @found) {
    result($stream, "40", "You need to join the chat before you can say anything");
    return;
  }
  if (not $text) {
    result($stream, "10", encode_utf8 "Post to the channel as $name");
    return;
  }
  $text = decode_utf8(uri_unescape($text));
  unshift(@chat_lines, { host => $host, space => $space, name => $name, text => $text });
  splice(@chat_lines, $chat_line_limit); # trim length of history
  # send message

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

  $log->info("Serving Ijirait on $host") });

# global commands
our $commands = {
  help     => \&help,
  look     => \&look,
  type     => \&type,
  save     => \&save,
  backup   => \&backup,
  export   => \&export,
  say      => \&speak, # can't use say!
  who      => \&who,
  go       => \&go,
  examine  => \&examine,
  describe => \&describe,
  name     => \&name,
  create   => \&create,
  delete   => \&delete,
  rooms    => \&rooms,
  connect  => \&connect,
  emote    => \&emote,

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

  return sprintf("%d days ago", int($seconds/86400)) if abs($seconds) > 172800; # 2d
  return sprintf("%d hours ago", int($seconds/3600)) if abs($seconds) > 7200; # 2h
  return sprintf("%d minutes ago", int($seconds/60)) if abs($seconds) > 120; # 2min
  return sprintf("%d seconds ago", $seconds);
}

sub menu {
  my $stream = shift;
  $stream->write("## Commands\n");
  $stream->write("=> /play/ijirait/look look\n");
  $stream->write("=> /play/ijirait/say say\n");
  $stream->write("=> /play/ijirait/emote emote\n");
  $stream->write("=> /play/ijirait/help help\n");
  $stream->write("=> /play/ijirait/type type\n");
}

sub help {
  my ($stream, $p) = @_;
  success($stream);
  $stream->write("## Help\n");
  my $dir = $server->{wiki_dir};

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

      mkdir "$dir/keep/$id";
      $revision = 1;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      return http_error($stream, "Unable to write index");
    } else {
      say $fh $id;
      close($fh);
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return http_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return http_error($stream, "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    my $message = to_url($stream, $host, $space, "page/$id", "https");

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

      mkdir "$dir/keep/$id";
      $revision = 1;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      return webdav_error($stream, "Unable to write index");
    } else {
      say $fh $id;
      close($fh);
    }
    $new = 1;
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return webdav_error($stream, "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    if ($new) {

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

      return;
    }
    $new = 1;
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, 0, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/file" unless -d "$dir/file";
  eval { write_binary($file, $data) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return webdav_error($stream, "Unable to save $id");
  }
  mkdir "$dir/meta" unless -d "$dir/meta";
  eval { write_text($meta, "content-type: $type\n") };

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

    # remove $id from the index
    my @pages = grep { $_ ne $id } split /\n/, read_text $index;
    write_text($index, join("\n", @pages, ""));
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖹", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted page $id");
  $stream->write("HTTP/1.1 204 No Content\r\n");
  $stream->write("\r\n");
}

sub delete_file {
  my $stream = shift;
  my $host = shift;
  my $space = shift;
  my $id = shift;
  my $dir = wiki_dir($host, $space);
  unlink("$dir/file/$id", "$dir/meta/$id");
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return webdav_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, "🖻", bogus_hash($peerhost));
    close($fh);
  }
  $log->info("Deleted file $id");
  $stream->write("HTTP/1.1 204 No Content\r\n");
  $stream->write("\r\n");
}

sub copy {
  my ($stream, $host, $space, $path, $id, $headers) = @_;
  return unless authorize($stream, $host, $space, $headers);

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

      mkdir "$dir/keep/$id";
      $revision = 1;
    }
    rename $file, "$dir/keep/$id/$revision.gmi";
  } else {
    my $index = "$dir/index";
    if (not open(my $fh, ">>:encoding(UTF-8)", $index)) {
      $log->error("Cannot write index $index: $!");
      return http_error($stream, "Unable to write index");
    } else {
      say $fh $id;
      close($fh);
    }
  }
  my $changes = "$dir/changes.log";
  if (not open(my $fh, ">>:encoding(UTF-8)", $changes)) {
    $log->error("Cannot write log $changes: $!");
    return http_error($stream, "Unable to write log");
  } else {
    my $peerhost = $stream->handle->peerhost;
    say $fh join("\x1f", scalar(time), $id, $revision + 1, bogus_hash($peerhost));
    close($fh);
  }
  mkdir "$dir/page" unless -d "$dir/page";
  eval { write_text($file, $text) };
  if ($@) {
    $log->error("Unable to save $id: $@");
    return http_error($stream, "Unable to save $id");
  } else {
    $log->info("Wrote $id");
    my $message = to_url($stream, $host, $space, "page/$id", "https");

script/ijirait  view on Meta::CPAN 

my ($host, $port) = split(/:/, $authority, 2);
$port //= 1965;

if ($stream) {
  stream();
} else {
  play();
}

sub stream {
  say "Use 'Ctrl+C' to quit.";
  # Start client for listening
  Mojo::IOLoop->client({
    address => $host,
    port => $port,
    tls => 1,
    tls_cert => $cert,
    tls_key => $key,
    tls_options => { SSL_verify_mode => 0x00 }} => sub {
      my ($loop, $err, $stream) = @_;
      # 1h timeout (for chat)
      $stream->timeout(3600);
      $stream->on(read => sub {
	my ($stream, $bytes) = @_;
	my $text = to_text(decode_utf8($bytes));
	print encode(locale => $text) });
      $stream->on(close => sub {
	say "Connection closed";
	exit });
      # Write request to the server
      $stream->write("$url\r\n")});
  # Start event loop if necessary
  Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
}

sub play {
  say "Use 'quit' to leave the game. Use '\\' to send a newline.";

  my @queue = qw(look);

  # start read loop for saying stuff
  my $term = Term::ReadLine->new("Ijirait");
  my $prompt = "> ";
  my $OUT = $term->OUT || \*STDOUT;
  while (defined ($_ = shift(@queue) || $term->readline($prompt))) {
    exit if $_ eq "quit";
    # Handle <
    my $command = decode(locale => $_);
    if ($command =~ /^(.*?)\s*<\s*([^|<>]+?)\s*$/s) {
      if (-f $2) {
	$command = $1 . " " . decode_utf8(read_text($2));
      } else {
	say "Cannot read $2";
	next;
      }
    }
    # Handle | >
    my $shell_command;
    if ($command =~ /^([^<>]*?)(\|[^<]+)/s
	or $command =~ /^([^<|]*?)(>[^|<>]+)/s) {
      # matches if we're in a pipe such as look|tail>test, or just a redirect to
      # a file like look>test; constructs like look>test|tail save the complete
      # output of look into test and tail nothing

script/ijirait  view on Meta::CPAN 

    }
    # create client
    Mojo::IOLoop->client({
      address => $host,
      port => $port,
      tls => 1,
      tls_cert => $cert,
      tls_key => $key,
      tls_options => { SSL_verify_mode => 0x00 }, } => sub {
	my ($loop, $err, $stream) = @_;
	return say $err unless $stream;
	$stream->on(read => sub {
	  my ($stream, $bytes) = @_;
	  if ($shell_command) {
	    open(my $fh, $shell_command)
		or die "Can't run $shell_command: $!";
	    $bytes =~ s/^2.*\n//; # skip header
	    print $fh $bytes;
	  } else {
	    my $text = to_text(decode_utf8($bytes));
	    print encode(locale => $text);
	  }
	  if ($bytes =~ m!^30 /play/ijirait(?:/([a-z]+))?(?:\?(.*))?!) {
	    my $command = ($1 || "look") . ($2 ? " " . decode_utf8 uri_unescape($2) : "");
	    $command =~ s/[[:cntrl:]]+//g;
	    push(@queue, $command);
	  }});
	# Write request to the server
	say "$talk_url?$command" if $verbose;
	$command =~ s/\\\\/\n/g;
	my $bytes = uri_escape(encode_utf8($command));
	$stream->write("$talk_url?$bytes\r\n")});
    # Start event loop if necessary
    Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
    # Add to history
    $term->addhistory($_) if /\S/;
  }
}

script/phoebe  view on Meta::CPAN 


  # if the certs don't exist, generate them
  if ($default_certs
      and (not -f 'cert.pem'
	   or not -f 'key.pem')) {
    generate_certificates();
  }
}

sub generate_certificates {
  say "The default certificate (and key) files are missing.";
  say "Do you want to create them right now?";
  say "The certificate uses eliptic curves and is valid for five years.";
  say "If so, please provide your hostname (e.g. localhost).";
  say "If not, just press Enter.";
  local $SIG{'ALRM'} = sub {
    die "Timed out!\n";
  };
  alarm(30); # timeout for the following prompt
  my $hostname = <STDIN>;
  alarm(0);  # done, no more alarm
  chomp $hostname;
  die "The hostname may not contain any whitespace\n" if $hostname =~ /\s/;
  my $cmd = qq(openssl req -new -x509 -newkey ec -subj "/CN=$hostname" )
      . qq(-pkeyopt ec_paramgen_curve:prime256v1 -days 1825 -nodes -out cert.pem -keyout key.pem);
  if ($hostname) {
    say $cmd;
    system($cmd) == 0
      or die "openssl failed: $?";
  }
}

sub help {
  my $parser = Pod::Text->new();
  $parser->parse_file($0);
  exit;
}

script/phoebe-ctl  view on Meta::CPAN 

}

$subcommand->(@ARGV);

exit;

sub update_changes {
  my %pages;
  my $now = time;
  $pages{decode_utf8($_)} = modified("$dir/page/$_.gmi") for map { s/\.gmi$//; $_ } grep /\.gmi$/, read_dir("$dir/page");
  say "Read " . scalar(keys %pages) . " pages" if $log >= 3;
  say join("\n", map { $_ . "\t" . $pages{$_} } sort keys %pages) if $log >= 4;
  my %files;
  $files{decode_utf8($_)} = modified("$dir/file/$_") for read_dir("$dir/file");
  say "Read " . scalar(keys %files) . " files" if $log >= 3;
  say join("\n", map { $_ . "\t" . $files{$_} } sort keys %files) if $log >= 4;
  my %revisions;
  my %changes;
  for (split /\n/, read_text "$dir/changes.log") {
    my ($ts, $id, $revision) = split(/\x1f/);
    $revisions{$id} = $revision;
    if ($revision) {
      $changes{$id} = $ts;
    } else {
      $changes{$id . "\x1c"} = $ts;
    }
  };
  say "Read " . scalar(keys %changes) . " changes" if $log >= 3;
  say join("\n", map { $_ . "\t" . $changes{$_} } sort keys %changes) if $log >= 4;
  open(my $fh, ">>:encoding(UTF-8)", "$dir/changes.log") or die "Cannot write $dir/changes.log: $!";
  for (keys %pages) {
    if (not $changes{$_} or $pages{$_} > $changes{$_}) {
      say "Page $_ is added to changes" if $log >= 4;
      my $revision = $revisions{$_} || 0;
      say $fh join("\x1f", $now, $_, 1 + $revision, "0000");
      utime($now, $now, "$dir/page/$_.gmi") or warn "Could not set utime for $dir/page/$_.gmi\n";
    }
  }
  for (keys %files) {
    if (not $changes{$_ . "\x1c"} or $files{$_} > $changes{$_ . "\x1c"}) {
      say "File $_ is added to changes" if $log >= 4;
      say $fh join("\x1f", $now, $_, 0, "0000");
      utime($now, $now, "$dir/file/$_") or warn "Could not set utime for $dir/file/$_\n";
    }
  }
  close($fh);
}

sub modified {
  my $ts = (stat(shift))[9];
  return $ts;
}

script/phoebe-ctl  view on Meta::CPAN 

  die "You need to provide a target directory for the HTML files using --target=directory\n" unless $target;
  for my $source (@sources) {
    my $source_dir = "$dir$source";
    die "Source directory $source_dir does not exist\n" unless -d $source_dir;
    my $target_dir = "$target$source";
    mkdir $target_dir or die "Cannot create target directory $target_dir: $!\n"
	unless -d $target_dir;
    for my $page (map { s/\.gmi$//; $_ } grep /\.gmi$/, read_dir("$source_dir/page")) {
      my $id = decode_utf8 $page;
      my $text = read_text "$source_dir/page/$page.gmi"; # fatal if it does not exist
      say "Converting $id";
      my $filename = "$target_dir/$page";
      $filename .= ".html" unless $no_extension;
      open(my $fh, ">:utf8", $filename)
	  or die "Cannot write $filename: $!\n";
      say $fh "<!DOCTYPE html>";
      say $fh "<html>";
      say $fh "<head>";
      say $fh "<meta charset=\"utf-8\">";
      say $fh "<title>" . quote_html($id) . "</title>";
      say $fh "<link type=\"text/css\" rel=\"stylesheet\" href=\"/default.css\"/>";
      say $fh "<meta name=\"viewport\" content=\"width=device-width, initial-scale=1\">";
      say $fh "</head>";
      say $fh "<body>";
      say $fh "<h1>" . quote_html($id) . "</h1>";
      say $fh to_html($text);
      # skipping footers
      say $fh "</body>";
      say $fh "</html>";
    }
  }
}

sub quote_html {
  my $html = shift;
  $html =~ s/&/&amp;/g;
  $html =~ s/</&lt;/g;
  $html =~ s/>/&gt;/g;
  $html =~ s/[\x00-\x08\x0b\x0c\x0e-\x1f]/ /g; # legal xml: #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]

script/phoebe-ctl  view on Meta::CPAN 

    } elsif ((not $filter or $ip and $filter eq $ip) and /\[info\] Looking at (.*)/) {
      $request{$1}++;
      $n++;
      $ip //= "anon";
    } elsif ($ip and (not $filter or $filter eq $ip) and /\[info\] (Net range (\S+) is blocked|IP is blocked)/) {
      $block{$ip}++;
      $blocks++;
    }
  }
  die("No hits (you must run the server on --log_level=info or --log_level=debug\n") unless $n;
  say("Total hits:   $n");
  say("Total blocks: $blocks");
  say("Bot level:    " . round($blocks / $n * 100) . "%") if $blocks;
  say("-" x length("Total blocks: $blocks"));
  if ($type eq "hits") {
    printf("%5s %4s%% %5s %s\n", "Hits", "Hits", "Block", "IP Number");
    for (sort { $ip{$b} <=> $ip{$a} } keys %ip) {
      printf("%5d %4d%% %4d%% %s\n", $ip{$_}, int(100*$ip{$_}/$n), exists $block{$_} ? int(100*$block{$_}/$n) : 0, $_);
    }
  } elsif ($type eq "requests") {
    printf("%5s %4s%% %s\n", "Hits", "Hits", "Request");
    for (sort { $request{$b} <=> $request{$a} } keys %request) {
      printf("%5d %4d%% %s\n", $request{$_}, int(100*$request{$_}/$n), $_);
    }

script/spartan  view on Meta::CPAN 

      print encode(locale => $bytes);
    } else {
      ($header) = $bytes =~ /^(.*?)\r\n/;
      warn "$header\n";
      if ($header =~ /^2\d* (?:text\/\S+)?(?:; *charset=(\S+))?$/g) {
	# empty, or text without charset defaults to UTF-8
	$encoding = $1 || 'UTF-8';
      }
      $bytes =~ s/^(.*?)\r\n//; # remove header
      if ($encoding) {
	say encode(locale => decode($encoding, $bytes));
      } else {
	print encode(locale => $bytes);
      }
    }});
  # Write request
  my $size = length($data);
  warn "Requesting $host $path $size\n" if $verbose;
  $stream->write("$host $path $size\r\n$data")});

# Start event loop if necessary

script/titan  view on Meta::CPAN 

  die "âš  The URL '$url' must have a path that ends in a slash\n" if $path !~ /\/$/;
} elsif (not @files) {
  die "âš  The URL '$url' must have a path that does not end in a slash\n" if $path =~ /\/$/;
}

for my $file (@files) {
  die "âš  The file '$file' does not exist\n" unless -e $file;
  die "âš  The file '$file' cannot be read\n" unless -r $file;
}
warn "Without a token chances are slim… 😅\n" unless $token;
say "Start typing and end your input with Ctrl-D… 😁" if -t and not @files;
say "Reading from the pipe… 😁" if not -t and not @files;

my ($host, $port) = split(/:/, $authority, 2);
$port //= 1965;

undef $/;
my $temp_fh;

unless (@files) {
  my $data = <STDIN>;
  my $file;

t/00_tls_check.t  view on Meta::CPAN 

} else {
  sleep 1;
  use Test::More;
  query1("Hello1");
  query2("Hello2");
  Mojo::IOLoop->stop();
  done_testing();
}

sub start_server {
  say "This is the server listening on port $port...";
  Mojo::IOLoop->server({
    address => $address,
    port => $port,
    tls => 1,
    tls_cert => 't/cert.pem',
    tls_key  => 't/key.pem',
    # do ask for the client certificate, but don't verify it
    tls_options => {
      SSL_verify_mode => 1,
      SSL_verify_callback => sub { 1 },

t/Ijirait.t  view on Meta::CPAN 

require './t/test.pl';

my $page = query_gemini("$base/play/ijirait");
like($page, qr(^20), "Ijirait");
like($page, qr(Ijiraq said “Welcome!”), "Welcome");

$page = query_gemini("$base/play/ijirait/examine?Ijiraq");
like($page, qr(^# Ijiraq)m, "Heading");
like($page, qr(^A shape-shifter with red eyes\.)m, "Description");

like(query_gemini("$base/play/ijirait/type?say Hello"),
     qr(said “Hello”), "Hello");

like(query_gemini("$base/play/ijirait/go?out"),
     qr(^30), "Redirect after a move");

like(query_gemini("$base/play/ijirait/look"),
     qr(^# Outside The Tent)m, "Outside");

like(query_gemini("$base/play/ijirait/go?tent"),
     qr(^30), "Redirect after a move");

t/Oddmuse.t  view on Meta::CPAN 

END {
  # kill server
  if ($oddmuse_pid) {
    kill 'KILL', $oddmuse_pid or warn "Could not kill server $oddmuse_pid";
  }
}

if (!defined $oddmuse_pid) {
  die "Cannot fork Oddmuse: $!";
} elsif ($oddmuse_pid == 0) {
  say "This is the Oddmuse server listening on port $oddmuse_port...";
  $ENV{WikiDataDir} = $oddmuse_dir;
  no warnings "once";
  $OddMuse::RunCGI = 0;
  @ARGV = ("daemon", "-m", "production", "-l", "http://*:$oddmuse_port");
  # oddmuse-wiki.pl is a copy of Oddmuse's wiki.pl
  # oddmuse-server.pl is similar to Oddmuse's server.pl
  for my $file (qw(./t/oddmuse-wiki.pl ./t/oddmuse-server.pl)) {
    unless (my $return = do $file) {
      warn "couldn't parse $file: $@" if $@;
      warn "couldn't do $file: $!"    unless defined $return;
      warn "couldn't run $file"       unless $return;
    }
  }
  say "Oddmuse server done";
  exit;
}

my $ua = Mojo::UserAgent->new;
my $res;
my $total = 0;
my $ok = 0;

# What I'm seeing is that $@ is the empty string and $! is "Connection refused"
# even though I thought $@ would be set. Oh well.
say "This is the client waiting for the Oddmuse server to start on port $oddmuse_port...";
for (qw(1 1 1 1 2 2 3 4 5)) {
  if (not $total or not $res) {
    diag "$!: waiting ${_}s..." if $total > 0;
    $total += $_;
    sleep $_;
    $res = $ua->get("http://localhost:$oddmuse_port/wiki")->result;
  } else {
    $ok = 1;
    last;
  }

t/gemini-diagnostics.t  view on Meta::CPAN 

if (not $ENV{TEST_AUTHOR} or $ENV{TEST_AUTHOR} < 2) {
  $msg = 'Diagnostics are an author test that cannot succeed, unfortunately. Set $ENV{TEST_AUTHOR} to "2" to run it anyway.';
}
plan skip_all => $msg if $msg;

our $host = 'localhost';
our $port;

require './t/test.pl';

say "Running gemini-diagnostics $host $port";
open(my $fh, "-|:utf8", "gemini-diagnostics $host $port")
    or plan skip_all => "Cannot run gemini-diagnostics";
diag "A lot of errors at the beginning are OK!";

my $test;
while (<$fh>) {
  $test = $1 if /\[(\w+)\]/;
  next unless m/^ *(x|✓)/;
  ok($1 eq "✓", $test);
}

t/oddmuse-gopher.t  view on Meta::CPAN 

END {
  # kill server
  if ($oddmuse_pid) {
    kill 'KILL', $oddmuse_pid or warn "Could not kill server $oddmuse_pid";
  }
}

if (!defined $oddmuse_pid) {
  die "Cannot fork Oddmuse: $!";
} elsif ($oddmuse_pid == 0) {
  say "This is the Oddmuse server listening on port $oddmuse_port...";
  $ENV{WikiDataDir} = $oddmuse_dir;
  no warnings "once";
  $OddMuse::RunCGI = 0;
  @ARGV = ("daemon", "-m", "production", "-l", "http://*:$oddmuse_port");
  # oddmuse-wiki.pl is a copy of Oddmuse's wiki.pl
  # oddmuse-server.pl is similar to Oddmuse's server.pl
  for my $file (qw(./t/oddmuse-wiki.pl ./t/oddmuse-server.pl)) {
    unless (my $return = do $file) {
      warn "couldn't parse $file: $@" if $@;
      warn "couldn't do $file: $!"    unless defined $return;
      warn "couldn't run $file"       unless $return;
    }
  }
  say "Oddmuse server done";
  exit;
}

my $ua = Mojo::UserAgent->new;
my $res;
my $total = 0;
my $ok = 0;

# What I'm seeing is that $@ is the empty string and $! is "Connection refused"
# even though I thought $@ would be set. Oh well.
say "This is the client waiting for the Oddmuse server to start on port $oddmuse_port...";
for (qw(1 1 1 1 2 2 3 4 5)) {
  if (not $total or not $res) {
    diag "$!: waiting ${_}s..." if $total > 0;
    $total += $_;
    sleep $_;
    $res = $ua->get("http://localhost:$oddmuse_port/wiki")->result;
  } else {
    $ok = 1;
    last;
  }

t/spaces.t  view on Meta::CPAN 

$page = query_gemini("$base/do/all/changes");
like($page, qr/^=> $base\/page\/Alex Alex/m, "Alex found in unified changes");
like($page, qr/^=> $base\/alex\/page\/Haiku/m, "Haiku found in unified changes");

$page = query_gemini("$base/do/spaces");
like($page, qr/^=> $base\/alex\/ alex/m, "Space alex found");

# add a special token to the alex space via config file

open(my $config, ">", "$dir/config"); # overwrite
say $config 'package App::Phoebe;';
say $config 'use Modern::Perl;';
say $config 'our ($server);';
say $config '$server->{wiki_space_token}->{alex} = ["*secret*"];';
say $config '$server->{wiki_token} = [];';
close($config);
is(kill('HUP', $pid), 1, "Restarted server");
sleep 1;

$haiku = <<EOT;
Rattling keys and quiet
Fingers hover in the air
Outside, a full moon
EOT

t/test.pl  view on Meta::CPAN 

END {
  # kill server
  if ($pid) {
    kill 'KILL', $pid or warn "Could not kill server $pid";
  }
}

if (!defined $pid) {
  die "Cannot fork: $!";
} elsif ($pid == 0) {
  say "This is the Phoebe server listening on port $port...";
  use Config;
  my $secure_perl_path = $Config{perlpath};
  my @args = ("blib/script/phoebe",
	      # The test files containing hostnames are UTF-8 encoded, thus
	      # $host and @host are unicode strings. Command line parsing
	      # expects them encoded in the current locale, however.
	      (map { "--host=" . encode(locale => $_) } @hosts),
	      "--port=$port",
	      "--log_level=warn", # set to debug if you are bug hunting?
	      "--cert_file=t/cert.pem",

t/test.pl  view on Meta::CPAN 

	. decode($encoding, substr($response, $header_end + 4));
  }
  return $response;
}

my $total = 0;
my $ok = 0;

# What I'm seeing is that $@ is the empty string and $! is "Connection refused"
# even though I thought $@ would be set. Oh well.
say "This is the Phoebe client waiting for the server to start on port $port...";
# In order to avoid "skipped: Giving up after 5s" by CPAN tester gregor herrmann,
# make sure to wait more than that!
for (qw(1 1 1 1 1 2 3 5)) {
  if (not $total or $!) {
    $total += $_;
    sleep $_;
    eval { query_gemini("gemini://$host:$port/") };
  } else {
    $ok = 1;
    last;



( run in 3.005 seconds using v1.01-cache-2.11-cpan-d7a12ab2c7f )