Developer-Dashboard
view release on metacpan or search on metacpan
t/08-web-update-coverage.t view on Meta::CPAN
my $fake_bin = File::Spec->catdir( $home, 'fake-win-bin' );
make_path($fake_bin);
my $ipconfig = File::Spec->catfile( $fake_bin, 'ipconfig' );
open my $ipconfig_fh, '>', $ipconfig or die $!;
print {$ipconfig_fh} <<'BAT';
#!/bin/sh
cat <<'EOF'
Ethernet adapter Ethernet:
IPv4 Address. . . . . . . . . . . : 10.20.30.40
Wireless LAN adapter Loopback:
IPv4 Address. . . . . . . . . . . : 127.0.0.1
EOF
BAT
close $ipconfig_fh;
chmod 0755, $ipconfig or die $!;
no warnings 'redefine';
local $ENV{PATH} = $fake_bin . ':' . $ENV{PATH};
local *Developer::Dashboard::Web::App::_ip_pairs_from_ip = sub { return (); };
local *Developer::Dashboard::Web::App::_ip_pairs_from_ifconfig = sub { return (); };
is_deeply(
[ $app->_ip_interface_pairs ],
[ { iface => 'Ethernet', ip => '10.20.30.40' } ],
'_ip_interface_pairs falls back to ipconfig parsing when Windows ipconfig output is available',
);
}
{
no warnings 'redefine';
local *Developer::Dashboard::Web::App::_ip_pairs_from_ip = sub { return (); };
local *Developer::Dashboard::Web::App::_ip_pairs_from_ifconfig = sub { return (); };
ok( !defined $app->_machine_ip, '_machine_ip returns undef when neither ip nor ifconfig yields a usable address' );
}
my ( $ajax_missing_code, $ajax_missing_type, $ajax_missing_body ) = @{ $app->handle( path => '/ajax', query => '', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
is( $ajax_missing_code, 400, 'legacy ajax route rejects requests without token or saved file parameters' );
like( $ajax_missing_type, qr/text\/plain/, 'legacy ajax missing-parameter route returns plain text' );
like( $ajax_missing_body, qr/missing token/, 'legacy ajax missing-parameter route explains the missing token' );
{
local $ENV{DEVELOPER_DASHBOARD_ALLOW_TRANSIENT_URLS} = 1;
no warnings 'redefine';
local *Developer::Dashboard::Web::App::decode_payload = sub { die "forced decode failure\n" };
my ( $ajax_bad_token_code, $ajax_bad_token_type, $ajax_bad_token_body ) = @{ $app->handle( path => '/ajax', query => 'token=known-good-token&type=json', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
is( $ajax_bad_token_code, 400, 'legacy ajax route rejects decode failures cleanly' );
like( $ajax_bad_token_type, qr/text\/plain/, 'legacy ajax decode-failure route returns plain text' );
like( $ajax_bad_token_body, qr/forced decode failure/, 'legacy ajax decode-failure route returns the decode error text' );
}
{
my ( $ajax_bad_file_code, $ajax_bad_file_type, $ajax_bad_file_body ) = @{ $app->handle( path => '/ajax', query => 'file=..%2Fbad&type=json', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
is( $ajax_bad_file_code, 400, 'legacy ajax route rejects invalid saved bookmark ajax file names cleanly' );
like( $ajax_bad_file_type, qr/text\/plain/, 'legacy ajax invalid saved-file route returns plain text' );
like( $ajax_bad_file_body, qr/invalid parent traversal/, 'legacy ajax invalid saved-file route returns the validation error text' );
}
{
my $streaming_page = Developer::Dashboard::PageDocument->from_instruction(<<'PAGE');
BOOKMARK: ajax-stream
:--------------------------------------------------------------------------------:
HTML: <script>var configs = {};</script>
:--------------------------------------------------------------------------------:
CODE1: Ajax jvar => 'configs.demo.endpoint', type => 'text', file => 'stream.txt', code => q{
print "first\n";
print "second\n";
};
PAGE
$store->save_page($streaming_page);
my ( undef, undef, undef ) = @{ $app->handle( path => '/app/ajax-stream', query => '', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my ( $ajax_stream_code, $ajax_stream_type, $ajax_stream_body ) = @{ $app->handle( path => '/ajax/stream.txt', query => 'type=text', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
is( $ajax_stream_code, 200, 'legacy ajax saved-file route responds successfully for streaming output' );
like( $ajax_stream_type, qr/text\/plain/, 'legacy ajax saved-file route keeps the requested content type for streaming output' );
is( drain_stream_body($ajax_stream_body), "first\nsecond\n", 'legacy ajax saved-file route streams raw printed output without page buffering' );
}
{
my $process_page = Developer::Dashboard::PageDocument->from_instruction(<<'PAGE');
BOOKMARK: ajax-process
:--------------------------------------------------------------------------------:
HTML: <script>var configs = {};</script>
:--------------------------------------------------------------------------------:
CODE1: Ajax jvar => 'configs.demo.endpoint', type => 'text', file => 'process-endpoint.json', code => q{
print "perl-start\n";
warn "perl-warn\n";
system 'sh', '-c', 'printf "child-out\n"; printf "child-err\n" >&2';
die "perl-die\n";
};
PAGE
$store->save_page($process_page);
my ( undef, undef, undef ) = @{ $app->handle( path => '/app/ajax-process', query => '', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my ( $ajax_process_code, $ajax_process_type, $ajax_process_body ) = @{ $app->handle( path => '/ajax/process-endpoint.json', query => 'type=text', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my $ajax_process_output = drain_stream_body($ajax_process_body);
is( $ajax_process_code, 200, 'legacy ajax saved-file process route responds successfully for mixed stdout and stderr output' );
like( $ajax_process_type, qr/text\/plain/, 'legacy ajax saved-file process route keeps the requested content type' );
like( $ajax_process_output, qr/perl-start/, 'legacy ajax saved-file process route streams direct perl stdout' );
like( $ajax_process_output, qr/perl-warn/, 'legacy ajax saved-file process route streams perl stderr warnings' );
like( $ajax_process_output, qr/child-out/, 'legacy ajax saved-file process route streams child process stdout' );
like( $ajax_process_output, qr/child-err/, 'legacy ajax saved-file process route streams child process stderr' );
like( $ajax_process_output, qr/perl-die/, 'legacy ajax saved-file process route streams uncaught perl die output' );
}
{
my $singleton_page = Developer::Dashboard::PageDocument->from_instruction(<<'PAGE');
BOOKMARK: ajax-singleton
:--------------------------------------------------------------------------------:
HTML: <script>var configs = {};</script>
:--------------------------------------------------------------------------------:
CODE1: Ajax jvar => 'configs.demo.endpoint', type => 'text', singleton => 'FOOBAR', file => 'singleton-endpoint.txt', code => q{
print "$0\n";
};
PAGE
$store->save_page($singleton_page);
my ( undef, undef, $singleton_page_body ) = @{ $app->handle( path => '/app/ajax-singleton', query => '', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
like( $singleton_page_body, qr{/ajax/singleton-endpoint\.txt\?type=text&singleton=FOOBAR}, 'saved bookmark Ajax page emits the singleton query parameter in the generated ajax url' );
like( $singleton_page_body, qr/dashboard_ajax_singleton_cleanup\('FOOBAR'\)/, 'saved bookmark Ajax page registers browser lifecycle cleanup for singleton-managed workers' );
my ( $ajax_singleton_code, undef, $ajax_singleton_body ) = @{ $app->handle( path => '/ajax/singleton-endpoint.txt', query => 'type=text&singleton=FOOBAR', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my $ajax_singleton_output = drain_stream_body($ajax_singleton_body);
is( $ajax_singleton_code, 200, 'legacy ajax saved-file route responds successfully for singleton-managed requests' );
like( $ajax_singleton_output, qr/^dashboard ajax: FOOBAR$/m, 'legacy ajax saved-file route renames singleton-managed Perl workers before streaming output' );
}
{
my @patterns;
{
no warnings 'redefine';
local *Developer::Dashboard::RuntimeManager::_pkill_perl = sub {
my ( $self, $pattern ) = @_;
push @patterns, $pattern;
return 1;
};
my ( $stop_code, undef, $stop_body ) = @{ $app->handle( path => '/ajax/singleton/stop', query => 'singleton=BROWSER-STOP', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
is( $stop_code, 204, 'singleton stop route returns no content after lifecycle cleanup' );
is( $stop_body, '', 'singleton stop route keeps the response body empty' );
}
is_deeply( \@patterns, ['^dashboard ajax: BROWSER-STOP$'], 'singleton stop route targets the matching saved ajax worker process title' );
}
{
my $shebang_page = Developer::Dashboard::PageDocument->from_instruction(<<'PAGE');
BOOKMARK: ajax-shebang
:--------------------------------------------------------------------------------:
HTML: <script>var configs = {};</script>
:--------------------------------------------------------------------------------:
CODE1: Ajax jvar => 'configs.demo.endpoint', type => 'text', file => 'script-runner', code => qq{#!/bin/sh\nprintf 'shell-out\\n'\nprintf 'shell-err\\n' >&2\n};
PAGE
$store->save_page($shebang_page);
my ( undef, undef, undef ) = @{ $app->handle( path => '/app/ajax-shebang', query => '', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my ( $ajax_shebang_code, undef, $ajax_shebang_body ) = @{ $app->handle( path => '/ajax/script-runner', query => 'type=text', remote_addr => '127.0.0.1', headers => { host => '127.0.0.1' } ) };
my $ajax_shebang_output = drain_stream_body($ajax_shebang_body);
is( $ajax_shebang_code, 200, 'legacy ajax saved-file route executes shebang scripts directly' );
like( $ajax_shebang_output, qr/shell-out/, 'legacy ajax saved-file route streams direct executable stdout' );
like( $ajax_shebang_output, qr/shell-err/, 'legacy ajax saved-file route streams direct executable stderr' );
}
is( $auth->trust_tier( remote_addr => '127.0.0.1', host => '127.0.0.1:7890' ), 'admin', 'exact loopback with numeric host is admin' );
is( $auth->trust_tier( remote_addr => '127.0.0.1', host => 'localhost:7890' ), 'admin', 'localhost is trusted as admin when it resolves only to loopback' );
is( $auth->trust_tier( remote_addr => '10.0.0.8', host => '127.0.0.1:7890' ), 'helper', 'non-loopback client is helper' );
my @initial_users = $auth->list_users;
is( scalar @initial_users, 0, 'auth store starts empty' );
ok( !$auth->verify_user( username => 'helper', password => 'nope' ), 'missing user does not verify' );
like( $auth->login_page( message => '<unsafe>' ), qr/<unsafe>/, 'login page escapes message content' );
my $helper_host = 'dashboard-helper.example:7890';
my ( $login_required_code, undef, $login_required_body ) = @{ $app->handle( path => '/', query => '', remote_addr => '127.0.0.1', headers => { host => $helper_host } ) };
is( $login_required_code, 401, 'non-loopback helper-host requests are unauthorized when no helper user exists' );
is( $login_required_body, '', 'outsider requests return an empty body before helper users exist' );
unlike( $login_required_body, qr/<form method="post" action="\/login">/, 'outsider requests without helper users do not receive a login form' );
my ( $saved_login_required_code, undef, $saved_login_required_body ) = @{ $app->handle(
path => '/app/index',
query => 'from=helper',
remote_addr => '127.0.0.1',
headers => { host => $helper_host },
) };
is( $saved_login_required_code, 401, 'outsider access to a saved page is unauthorized when no helper user exists' );
is( $saved_login_required_body, '', 'forbidden outsider access to a saved page stays silent before helper users exist' );
unlike( $saved_login_required_body, qr{<input[^>]*name="redirect_to"}, 'forbidden outsider requests do not expose a login redirect target before helper users exist' );
my ( $disabled_login_code, undef, $disabled_login_body ) = @{ $app->handle(
t/08-web-update-coverage.t view on Meta::CPAN
) };
is( $logout_code, 302, 'logout redirects' );
is( $logout_headers->{Location}, '/login', 'logout redirects to login page' );
like( $logout_headers->{'Set-Cookie'}, qr/Max-Age=0/, 'logout expires the session cookie' );
ok( !$sessions->from_cookie( $login_headers->{'Set-Cookie'} ), 'logout deletes the stored session' );
dies_like( sub { Developer::Dashboard::Web::Server->new }, qr/Missing web app/, 'web server requires an app' );
my $default_server = Developer::Dashboard::Web::Server->new( app => $app );
is( $default_server->{host}, '0.0.0.0', 'web server defaults to all interfaces' );
is( $default_server->{port}, 7890, 'web server keeps default port 7890' );
my $server = Developer::Dashboard::Web::Server->new(
app => $app,
host => '127.0.0.1',
port => 0,
);
my $daemon = $server->start_daemon;
is( $daemon->sockhost, '127.0.0.1', 'start_daemon preserves the requested host' );
ok( $daemon->sockport > 0, 'start_daemon resolves a listen port' );
is( $server->listening_url($daemon), 'http://127.0.0.1:' . $daemon->sockport . '/', 'listening_url builds the daemon URL from the descriptor' );
{
my $res;
test_psgi $server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( GET 'http://127.0.0.1/app/sample/source' );
};
is( $res->code, 200, 'server PSGI app returns successful status code from app handle' );
like( $res->header('Content-Type'), qr/text\/plain/, 'server PSGI app keeps the instruction source content type' );
is( $res->header('X-Frame-Options'), 'DENY', 'server PSGI app sets frame-deny header' );
like( $res->header('Content-Security-Policy'), qr/frame-ancestors 'none'/, 'server PSGI app sets CSP header' );
is( $res->header('Cache-Control'), 'no-store', 'server PSGI app disables response caching' );
}
my $header_app = bless {}, 'Local::HeaderApp';
{
no warnings 'once';
*Local::HeaderApp::handle = sub {
return [
302,
'text/plain; charset=utf-8',
"Redirecting\n",
{
Location => '/login',
'Set-Cookie' => 'dashboard_session=abc',
},
];
};
}
my $header_server = Developer::Dashboard::Web::Server->new( app => $header_app );
{
my $res;
test_psgi $header_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( POST 'http://127.0.0.1/login', [ username => 'helper', password => 'helper-pass-123' ] );
};
is( $res->header('Location'), '/login', 'server forwards custom Location headers from the app' );
is( $res->header('Set-Cookie'), 'dashboard_session=abc', 'server forwards custom Set-Cookie headers from the app' );
}
my $streaming_app = bless {}, 'Local::StreamingApp';
{
no warnings 'once';
*Local::StreamingApp::handle = sub {
return [
200,
'text/plain; charset=utf-8',
{
stream => sub {
my ($writer) = @_;
$writer->("alpha\n");
$writer->("beta\n");
},
},
{ 'X-Test' => 'streaming' },
];
};
}
my $streaming_server = Developer::Dashboard::Web::Server->new( app => $streaming_app );
{
my $res;
test_psgi $streaming_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( GET 'http://127.0.0.1/ajax' );
};
is( $res->code, 200, 'streaming response path returns success' );
like( $res->header('Content-Type'), qr/text\/plain/, 'streaming response keeps the content type header' );
is( $res->header('X-Test'), 'streaming', 'streaming response keeps custom headers' );
is( $res->content, "alpha\nbeta\n", 'streaming response writes streamed body chunks into the final response body' );
}
my $failing_stream_app = bless {}, 'Local::FailingStreamApp';
{
no warnings 'once';
*Local::FailingStreamApp::handle = sub {
return [
200,
'text/plain; charset=utf-8',
{
stream => sub {
my ($writer) = @_;
$writer->("alpha\n");
die "stream exploded\n";
},
},
];
};
}
my $failing_stream_server = Developer::Dashboard::Web::Server->new( app => $failing_stream_app );
{
my $res;
test_psgi $failing_stream_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( GET 'http://127.0.0.1/ajax' );
};
is( $res->code, 200, 'streaming error responses keep the original success status' );
like( $res->content, qr/alpha/, 'streaming error responses keep chunks written before the failure' );
like( $res->content, qr/stream exploded/, 'streaming error responses append the streaming exception text' );
}
{
no warnings 'redefine';
my @chunks;
local *Developer::Dashboard::Web::DancerApp::delayed = sub (&) { $_[0]->(); return 'delayed-ok' };
local $Dancer2::Core::Route::RESPONDER = sub {
my ($response) = @_;
is( $response->[0], 200, 'disconnect coverage responder receives the original status code' );
like( join( "\n", @{ $response->[1] || [] } ), qr/Content-Type\ntext\/plain/, 'disconnect coverage responder receives the content type header' );
return bless {}, 'Local::DisconnectWriter';
};
{
no warnings 'once';
*Local::DisconnectWriter::write = sub {
my ( $self, $chunk ) = @_;
push @chunks, $chunk;
die "Broken pipe\n" if @chunks > 1;
return 1;
};
*Local::DisconnectWriter::close = sub { return 1 };
}
local $Developer::Dashboard::Web::DancerApp::BACKEND_APP = { app => bless( {}, 'Local::DisconnectBackend' ), default_headers => {} };
my $result = Developer::Dashboard::Web::DancerApp::_response_from_result(
[
200,
'text/plain; charset=utf-8',
{
stream => sub {
my ($writer) = @_;
is( $writer->("alpha\n"), 1, 'stream writer reports success before the client disconnects' );
is( $writer->("beta\n"), 0, 'stream writer reports a disconnect when Dancer content writes fail with broken pipe' );
},
},
{},
]
);
is( $result, 'delayed-ok', '_response_from_result still completes the delayed wrapper when the client disconnects mid-stream' );
is_deeply( \@chunks, [ "alpha\n", "beta\n" ], '_response_from_result stops treating broken-pipe writes as fatal backend exceptions' );
}
my $failing_app = bless {}, 'Local::FailingApp';
{
no warnings 'once';
*Local::FailingApp::handle = sub { die "exploded\n" };
}
my $failing_server = Developer::Dashboard::Web::Server->new( app => $failing_app );
{
my $res;
test_psgi $failing_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( GET 'http://127.0.0.1/' );
};
is( $res->code, 500, 'server converts app exceptions into 500 responses' );
like( $res->content, qr/exploded/, 'server includes error body for exceptions' );
}
{
no warnings 'redefine';
local *Developer::Dashboard::Web::DancerApp::splat = sub { return ['alpha', 'beta']; };
is( Developer::Dashboard::Web::DancerApp::_capture(1), 'beta', '_capture unwraps arrayref-style splat payloads from Dancer route state' );
}
my $missing_route_app = bless {}, 'Local::MissingRouteApp';
my $missing_route_server = Developer::Dashboard::Web::Server->new( app => $missing_route_app );
{
my $res;
test_psgi $missing_route_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( POST 'http://127.0.0.1/login', [ username => 'helper', password => 'helper-pass-123' ] );
};
is( $res->code, 500, 'server returns a backend failure when the login route backend implements neither login_response nor handle' );
like( $res->content, qr/does not implement login_response or handle/, 'missing login route backend failures are exposed directly' );
}
{
my $res;
test_psgi $missing_route_server->psgi_app, sub {
my ($cb) = @_;
$res = $cb->( GET 'http://127.0.0.1/' );
};
is( $res->code, 500, 'server returns a backend failure when an authorized route backend implements neither a route method nor handle' );
like( $res->content, qr/does not implement root_response or handle/, 'missing authorized route backend failures are exposed directly' );
}
{
my $res = HTTP::Response->from_psgi(
$server->psgi_app->(
{
REQUEST_METHOD => 'GET',
PATH_INFO => '/',
SCRIPT_NAME => '',
SERVER_NAME => '127.0.0.1',
SERVER_PORT => 7890,
'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => 'http',
'psgi.input' => do { open my $fh, '<', \q{} or die $!; $fh },
'psgi.errors' => *STDERR,
'psgi.multithread' => 0,
'psgi.multiprocess' => 0,
'psgi.run_once' => 0,
'psgi.streaming' => 1,
'psgi.nonblocking' => 0,
}
)
);
is( $res->code, 200, 'server treats missing URI queries as empty strings' );
}
{
no warnings 'redefine';
local *IO::Socket::INET::new = sub { return };
local $! = 98;
dies_like( sub { $server->run }, qr/Unable to start server/, 'server dies when daemon startup fails' );
}
{
package Local::FakeRunner;
our @parse_options;
our $run_arg;
sub new { bless {}, $_[0] }
sub parse_options { @parse_options = @_[ 1 .. $#_ ]; return 1 }
sub run { $run_arg = $_[1]; return 1 }
}
{
no warnings 'redefine';
local *Plack::Runner::new = sub { return Local::FakeRunner->new };
my $fake_daemon = Developer::Dashboard::Web::Server::Daemon->new(
host => '127.0.0.1',
port => 5999,
);
ok( $server->serve_daemon($fake_daemon), 'serve_daemon delegates to the Plack runner successfully' );
is_deeply(
\@Local::FakeRunner::parse_options,
[ '--server', 'Starman', '--host', '127.0.0.1', '--port', 5999, '--env', 'deployment', '--workers', '1' ],
'serve_daemon configures Starman through Plack::Runner',
);
ok( ref( $Local::FakeRunner::run_arg ) eq 'CODE', 'serve_daemon hands a PSGI app coderef to the Plack runner' );
}
{
no warnings 'redefine';
local *Plack::Runner::new = sub { return Local::FakeRunner->new };
my $worker_server = Developer::Dashboard::Web::Server->new(
app => $app,
host => '127.0.0.1',
port => 5998,
workers => 4,
);
my $fake_daemon = Developer::Dashboard::Web::Server::Daemon->new(
host => '127.0.0.1',
port => 5998,
);
ok( $worker_server->serve_daemon($fake_daemon), 'serve_daemon accepts an explicit worker count' );
is_deeply(
\@Local::FakeRunner::parse_options,
[ '--server', 'Starman', '--host', '127.0.0.1', '--port', 5998, '--env', 'deployment', '--workers', '4' ],
'serve_daemon forwards the configured worker count to Starman',
);
}
( run in 0.745 second using v1.01-cache-2.11-cpan-39bf76dae61 )