view release on metacpan or  search on metacpan

t/22_webbrowser.t  view on Meta::CPAN

   my ($peer, $packet) = @_;
   print {$peer->{socket}} Protocol::WebSocket::Frame->new (
      type => "text", masked => 1, buffer => JSON::XS::encode_json ($packet),
   )->to_bytes or die $!;
}
sub read_ws {
   my ($peer) = @_;
   my $deadline = Time::HiRes::time () + 5;

   while (Time::HiRes::time () < $deadline) {
      while (defined (my $bytes = $peer->{parser}->next_bytes)) {
         my $opcode = $peer->{parser}->opcode;
         return [$opcode, $opcode == 1 ? JSON::XS::decode_json ($bytes) : $bytes] unless $opcode == 10;
      }

      next unless IO::Select->new ($peer->{socket})->can_read (.1);
      my $n = sysread $peer->{socket}, my $bytes, 8192;
      defined $n && $n or die "Unexpected WebSocket EOF\n";
      $peer->{parser}->append ($bytes);
   }

   die "WebSocket reply timed out\n";
}
sub connect_page {
   my ($target, $instance) = @_;
   my ($peer, $header) = upgrade "secondary", $target;
   $header =~ /101/ or die "WebSocket upgrade failed: $header";
   send_ws $peer, ["mcp-webbrowser", 1, 1, $instance, { url => "https://page.example/", origin => "https://page.example", title => "Page" }];
   my $welcome = read_ws ($peer)->[1];
   ($peer, $welcome)
}

my ($bad, $header) = upgrade "wrong", "bad";
unlike $header, qr/101/, "bad token cannot upgrade";
close $bad->{socket};
my ($invalid_target, $invalid_header) = upgrade "primary", "%ZZ";
unlike $invalid_header, qr/101/, "invalid target cannot upgrade";
close $invalid_target->{socket};
my ($early) = upgrade "primary", "early";
send_ws $early, ["state", { url => "https://page.example/", title => "early" }];
my $closed = read_ws $early;
is $closed->[0], 8, "commands before hello close the connection";
is unpack ("n", $closed->[1]), 1002, "protocol rejection uses status 1002";
like substr ($closed->[1], 2), qr/Invalid browser hello/, "protocol rejection carries its reason";
close $early->{socket};
my ($wrong_version) = upgrade "primary", "wrong-version";
send_ws $wrong_version, ["mcp-webbrowser", 2, 0, "wrong-version",
   { url => "https://page.example/", title => "Page" }];
my $rejected = read_ws $wrong_version;
is $rejected->[0], 8, "incompatible browser protocol closes the connection";
is unpack ("n", $rejected->[1]), 1002, "incompatible protocol uses status 1002";
like substr ($rejected->[1], 2), qr/Unsupported browser protocol 2\.0 \(server 1\.1\)/,
   "close frame explains the version mismatch";
close $wrong_version->{socket};

my ($old_client) = upgrade "primary", "old-client";
send_ws $old_client, ["mcp-webbrowser", 1, 0, "old-document",
   { url => 'https://user:pass@page.example/path?query', title => "Old client" }];
is_deeply read_ws ($old_client)->[1], ["welcome", "old-client", "old-document", 1],
   "compatible old browser protocol 1.0 connects";
is +(tabs ())->[0]{origin}, "https://page.example", "broker derives origin from URL without credentials";
my $old_id = ++$serial;
send_rpc $old_id, "tools/call", { name => "execute", arguments => { target => "old-client", code => "1+1" } };
my $old_call = read_ws ($old_client)->[1];
is $old_call->[3]{code}, "1+1", "old browser client retains JavaScript execution";
send_ws $old_client, ["reply", $old_call->[1], JSON::XS::true, 2];
is read_rpc ($old_id)->{result}{structuredContent}{value}, 2, "old client execution completes";
is_deeply tool ("list-tab-operations", { target => "old-client" })->{result}{structuredContent}{operations},
   [], "unsupported tab operations discover as empty for old client";
like tool ("call-tab-operation", { target => "old-client", operation => "test" })
   ->{result}{content}[0]{text}, qr/require protocol 1\.1/,
   "calling unsupported old-client operation fails without disconnect";
send_ws $old_client, ["quit"];
is read_ws ($old_client)->[0], 8, "old browser client quits normally";
close $old_client->{socket};

my ($newer_client) = upgrade "primary", "newer-client";
send_ws $newer_client, ["mcp-webbrowser", 1, 2, "newer-document",
   { url => "https://page.example/", title => "Newer client" }];
is_deeply read_ws ($newer_client)->[1], ["welcome", "newer-client", "newer-document", 1],
   "compatible newer minor protocol connects";
send_ws $newer_client, ["quit"];
is read_ws ($newer_client)->[0], 8, "newer client quits normally";
close $newer_client->{socket};

my ($one, $welcome) = connect_page "tab", "document-one";
is_deeply $welcome, ["welcome", "tab", "document-one", 1], "authenticated page is registered";
is $welcome->[3], 1, "first document starts at revision 1";
like JSON::XS::encode_json ($welcome), qr/\A\["welcome","tab","document-one",1\]\z/,
   "welcome revision is a JSON number";
my ($two, $second) = connect_page "other", "document-two";
is_deeply $second, ["welcome", "other", "document-two", 1], "different tabs have their own revisions";
my ($again, $replacement) = connect_page "other", "document-two";
is_deeply $replacement, ["welcome", "other", "document-two", 1], "same document reconnect retains revision";
like JSON::XS::encode_json ($replacement), qr/\A\["welcome","other","document-two",1\]\z/,
   "reconnect welcome still uses numeric revision";
is read_ws ($two)->[0], 8, "reconnect closes old connection";
close $two->{socket};
my $registered = tabs;
is_deeply [map $_->{target}, @$registered], ["other", "tab"], "tabs enumerates registered tabs";

send_ws $one, ["state", { url => "https://page.example/next?secret=not-for-logs#fragment", origin => "https://page.example", title => "Updated" }];
for (1 .. 100) {
   $registered = tabs;
   last if $registered->[1]{title} eq "Updated";
   Time::HiRes::sleep (.01);
}
is $registered->[1]{title}, "Updated", "state updates replace reported metadata";
is $registered->[1]{revision}, 1, "tabs expose the document revision";
like JSON::XS::encode_json ({revision => $registered->[1]{revision}}),
   qr/"revision":1/, "tabs serializes document revision as a JSON number";

policy "allow", "https://page.example";
my $origin_id = ++$serial;
send_rpc $origin_id, "tools/call", { name => "execute", arguments => { target => "tab", code => "allowed_origin()" } };
my $origin_call = read_ws ($one)->[1];
is $origin_call->[3]{code}, "allowed_origin()", "exact origin allows execution";
send_ws $one, ["reply", $origin_call->[1], JSON::XS::true, "yes"];
is read_rpc ($origin_id)->{result}{structuredContent}{value}, "yes", "origin-scoped permission dispatch succeeded";
send_ws $one, ["state", { url => "https://other.example/", origin => "https://other.example", title => "Cross-origin" }];
for (1 .. 100) {