view release on metacpan or  search on metacpan

script/phoebe  view on Meta::CPAN

    $default_certs = 1;
    $server->{host}->{$host} = 1;
    push(@{$server->{port}->{$host}}, @port);
    for my $port (@port) {
      $server->{cert_file}->{"$host:$port"} = 'cert.pem';
      $server->{key_file}->{"$host:$port"} = 'key.pem';
    }
  }

  # if, at the end, we had no hosts at all, the default still needs cert and key
  if (not keys %{$server->{host}}) {
    $default_certs = 1;
    $server->{host}->{localhost} = 1;
    push(@{$server->{port}->{localhost}}, @port);
    for my $port (@port) {
      $server->{cert_file}->{"localhost:$port"} = 'cert.pem';
      $server->{key_file}->{"localhost:$port"} = 'key.pem';
    }
  }

  # use Data::Dumper;
  # warn Dumper($server);

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

sub verify_fingerprint {
  my ($ok, $ctx_store, $certname, $error, $cert, $depth) = @_;
  return 1;
}

# defaults
$server->{wiki_token} ||= ['hello'];
$server->{wiki_space} ||= [];
$server->{wiki_mime_type} ||= [];
$server->{wiki_dir} ||= $ENV{PHOEBE_DATA_DIR} || './wiki';
$server->{wiki_page} ||= [];
$server->{wiki_main_page} ||= '';
$server->{wiki_page_size_limit} ||= 100000;

configure();

# Reconfigure if we get SIGHUP (via kill -s SIGHUP $pid, for example)
$SIG{HUP} = sub { Mojo::IOLoop->next_tick(\&configure) };

start_servers();

sub configure {
  # config file with extra code; restart server if you change it
  my $dir = $server->{wiki_dir};
  my @config;
  push(@config, map { "$dir/conf.d/$_" } grep(/\.p[lm]$/, read_dir("$dir/conf.d"))) if -d "$dir/conf.d";
  # allow override of config files in conf.d
  push(@config, "$dir/config") if -f "$dir/config";
  for my $config (@config) {
    $log->info("Running $config");
    $log->error("$config cannot be read") unless -r $config;
    $log->warn("$config did not return a true value") unless do $config;
    $log->error("$@") if $@;
    $log->error("$!") if $!;
  }
  # summarize config results
  $log->info("PID: $$");
  $log->info("Space: @{$server->{wiki_space}}");
  if (keys %{$server->{host}} > 1) {
    my $hosts = host_regex();
    for (grep(!/^$hosts\//, @{$server->{wiki_space}})) {
      $log->warn("Space $_ is not prefixed with a known host");
    }
  } else {
    for (grep(/\//, @{$server->{wiki_space}})) {
      $log->warn("Space $_ is prefixed with a host but we serve just one");
    }
  }
  $log->info("Token: @{$server->{wiki_token}}");
  $log->info("Main page: $server->{wiki_main_page}");
  $log->info("Pages: @{$server->{wiki_page}}");
  $log->info("MIME types: @{$server->{wiki_mime_type}}");
  $log->info("Wiki data directory: $server->{wiki_dir}");
}

sub start_servers {
  # Figure out what IP numbers we need to listen to because we need to start
  # servers for both IPv4 and IPv6. Only do this if phoebe is actually executing.
  # If it is called under a different name, it's probably just being loaded as a
  # library, in which case we don't want to start the servers.
  if ($0 eq __FILE__) {
    # On every address, on every port, figure out what hosts to listen to.
    for my $host (keys %{$server->{host}}) {
      for my $address (get_ip_numbers($host)) {
	$server->{address}->{$address} //= {};
	for my $port (@{$server->{port}->{$host}}) {
	  $server->{address}->{$address}->{$port} //= [];
	  push(@{$server->{address}->{$address}->{$port}}, $host);
	  $log->debug("planning to listen for $host on $address:$port");
	}
      }
    }
    for my $address (keys %{$server->{address}}) {
      for my $port (keys %{$server->{address}->{$address}}) {
	my @hosts = @{$server->{address}->{$address}->{$port}};
	my %args = (address => $address, port => $port);
	my $msg = "@hosts: listening on $address:$port";
	$args{tls} = 1;
	$args{tls_cert} = {};
	$args{tls_key} = {};
	my @hosts_without_cert;
	for my $host (@hosts) {
	  $args{tls_cert}->{$host} = $server->{cert_file}->{"$host:$port"};
	  $args{tls_key}->{$host} = $server->{key_file}->{"$host:$port"};
	  if ($args{tls_cert}->{$host} and $args{tls_key}->{$host}) {
	    $log->debug("$host uses $args{tls_cert}->{$host} and $args{tls_key}->{$host}");
	  } else {
	    push(@hosts_without_cert, $host);
	  }
	}
	if (@hosts_without_cert == 0) {
	  $msg .= " (TLS)";
	  $args{tls_options} = {
	    # request client certificates and accept them
	    SSL_verify_mode => SSL_VERIFY_PEER,
	    SSL_verify_callback => \&verify_fingerprint,
	    SSL_create_ctx_callback => sub {
	      my $ctx = shift;
	      Net::SSLeay::CTX_sess_set_cache_size($ctx, 64);
	    }
	  };
	} elsif (@hosts_without_cert == @hosts) {
	  $msg .= " (no TLS)";
	  $args{tls} = 0;
	} else {
	  die "Cannot mix with and without TLS on $address:$port (no cert: @hosts_without_cert)\n";
	}
	eval {
	  Mojo::IOLoop->server(\%args => sub {
	    my ($loop, $stream) = @_;
	    my $data = { buffer => '', handler => \&handle_request };
	    $stream->on(read => sub {
	      my ($stream, $bytes) = @_;
	      $log->debug("Received " . length($bytes) . " bytes");
	      $data->{buffer} .= $bytes;
	      $data->{handler}->($stream, $data)})});
	  # report success after the fact!
	  $log->info($msg);
	};
	$log->error("@hosts: unable to listen on $address:$port: $@") if $@;
      }
    }

    # Start event loop if necessary
    Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
  }
}

1;

__DATA__