EV-WebKit
view release on metacpan or search on metacpan
t/45-auth-popup-viewport.t view on Meta::CPAN
Listen => 5, ReuseAddr => 1)
or plan skip_all => "cannot bind a test server socket: $!";
my $port = $srv->sockport;
my %conns;
my $accept = EV::io($srv, EV::READ, sub {
my $c = $srv->accept or return;
$c->blocking(0);
my $buf = '';
my $rw; $rw = EV::io($c, EV::READ, sub {
my $n = sysread($c, my $chunk, 4096);
if (!defined $n) { return if $!{EAGAIN} || $!{EWOULDBLOCK}; delete $conns{$c}; return }
return delete $conns{$c} unless $n;
$buf .= $chunk;
return unless $buf =~ /\r?\n\r?\n/;
delete $conns{$c};
my ($path) = $buf =~ m{^\S+\s+(\S+)};
$path //= '/';
my ($code, $extra, $title) = (200, '', 'POPUP');
if ($path =~ m{/secret}) {
if ($buf =~ /Authorization:\s*Basic\s+(\S+)/i) { $title = 'AUTHED' }
else { ($code, $extra, $title) = (401, "WWW-Authenticate: Basic realm=\"probe\"\r\n", 'DENIED') }
}
my $body = "<html><head><title>$title</title></head><body>b</body></html>";
$c->blocking(1);
print $c "HTTP/1.1 $code X\r\nContent-Type: text/html\r\n$extra"
. 'Content-Length: ' . length($body) . "\r\nConnection: close\r\n\r\n$body";
$c->flush;
close $c;
});
$conns{$c} = $rw;
});
# --- on_authenticate --------------------------------------------------------
# Nothing answered a challenge before: WebKit simply waited, so a 401 resolved
# 'timeout' after the full instance timeout with status undef -- a private site
# was indistinguishable from an unreachable one.
{
my $b = EV::WebKit->new(window => [300,200], timeout => 8);
my ($err, $secs);
my $t0 = EV::time;
$b->go("http://127.0.0.1:$port/secret", sub { $err = $_[1]; $secs = EV::time - $t0; EV::break });
TWK::run_with_timeout(30);
ok(defined $err, 'with no handler a challenge fails rather than hanging');
like($err // '', qr/authentication/i, '...with a message that names authentication as the cause');
cmp_ok($secs // 99, '<', 5, '...promptly, not after the instance timeout');
$b->quit;
}
{
my @info;
my $b = EV::WebKit->new(window => [300,200], timeout => 10,
on_authenticate => sub {
my ($a) = @_;
push @info, { host => $a->host, port => $a->port, realm => $a->realm,
scheme => $a->scheme, proxy => $a->for_proxy, retry => $a->is_retry };
$a->login('u', 'p');
});
my ($err, $title, $status);
$b->go("http://127.0.0.1:$port/secret", sub {
$err = $_[1]; $title = $b->title; $status = $b->status; EV::break });
TWK::run_with_timeout(30);
is($err, undef, 'a handler that supplies credentials lets the load through') or diag $err;
is($title, 'AUTHED', '...and the server accepted them');
is($status, 200, '...reporting a 200, not the 401');
is(scalar @info, 1, 'the handler ran once');
is($info[0]{host}, '127.0.0.1', 'host is reported');
is($info[0]{port}, $port, 'port is reported');
is($info[0]{realm}, 'probe', 'realm is reported');
is($info[0]{scheme}, 'http-basic','scheme is reported');
is($info[0]{proxy}, 0, 'for_proxy is false for an origin challenge');
is($info[0]{retry}, 0, 'is_retry is false on the first ask');
$b->quit;
}
{
# credentials in the URI are WebKit's own business and must not reach us
my $fired = 0;
my $b = EV::WebKit->new(window => [300,200], timeout => 10,
on_authenticate => sub { $fired++; $_[0]->cancel });
my ($err, $title);
$b->go("http://u:p\@127.0.0.1:$port/secret", sub { $err = $_[1]; $title = $b->title; EV::break });
TWK::run_with_timeout(30);
is($err, undef, 'credentials in the URI still work') or diag $err;
is($title, 'AUTHED', '...reaching the protected page');
is($fired, 0, '...without the handler being consulted');
$b->quit;
}
# Fail-closed, and the three unanswered routes each name themselves. Without
# the cancel these still resolve -- with 'timeout', after the full instance
# timeout -- so the elapsed time is what actually pins "failed closed".
for my $case ([die => sub { die "handler exploded\n" }, qr/handler died/],
[undecided => sub { return }, qr/answered nothing/],
[cancel => sub { $_[0]->cancel }, qr/handler cancelled it/]) {
my ($name, $handler, $want) = @$case;
my $b = EV::WebKit->new(window => [300,200], timeout => 10, on_authenticate => $handler);
my ($err, $secs);
my $t0 = EV::time;
$b->go("http://127.0.0.1:$port/secret", sub { $err = $_[1]; $secs = EV::time - $t0; EV::break });
TWK::run_with_timeout(30);
ok(defined $err, "on_authenticate that $name: the navigation fails");
cmp_ok($secs // 99, '<', 5, "on_authenticate that $name: ...promptly, not at the instance timeout");
like($err // '', $want, "on_authenticate that $name: ...saying which route it took");
$b->quit;
}
# --- window.open ------------------------------------------------------------
# window.open is NOT a policy decision in WebKitGTK: decide-policy never fires
# for it, so the popups option had to be honoured on 'create' as well. Before
# that it did nothing at all -- no navigation, no error, no event.
for my $case ([follow => 'POPUP'], [block => undef]) {
my ($mode, $want) = @$case;
my $b = EV::WebKit->new(window => [400,300], timeout => 15, popups => $mode);
# window.open's return value is recorded in a page global, so the 'block'
# case can assert the call was actually MADE -- otherwise "the title is not
# POPUP" is equally true of a page where the click never happened.
$b->load_html('<html><body><button id=x onclick=\'window.opened = window.open('
. '"http://127.0.0.1:' . $port . '/pop","_blank") ? "won" : "null"\'>go</button></body></html>', sub {
$b->find('#x', sub {
$_[0]->click(sub { my $t; $t = EV::timer(2.5, 0, sub { undef $t; EV::break }) });
});
});
TWK::run_with_timeout(30);
if (defined $want) {
is($b->title, $want, "popups => $mode follows window.open in this view");
like($b->uri // '', qr{/pop$}, "...landing on the requested uri");
}
else {
my $opened;
$b->script('return String(window.opened);', sub { $opened = $_[0]; EV::break });
TWK::run_with_timeout(20);
is($opened, 'null', "popups => $mode: window.open was called and returned null");
isnt($b->title // '', 'POPUP', "popups => $mode drops window.open");
}
$b->quit;
}
# --- resize / zoom ----------------------------------------------------------
{
my $b = EV::WebKit->new(window => [800,600], timeout => 15);
my (%g, @steps);
my $nxt; $nxt = sub { my $s = shift @steps or return EV::break; $s->() };
@steps = (
sub { $b->script('return [innerWidth, innerHeight];', sub { $g{before} = $_[0]; $nxt->() }) },
( run in 0.720 second using v1.01-cache-2.11-cpan-007c89162af )