File Coverage

blib/lib/App/EvalServerAdvanced/Protocol.pm
Criterion Covered Total %
statement 12 14 85.7
branch n/a
condition n/a
subroutine 5 5 100.0
pod n/a
total 17 19 89.4


line stmt bran cond sub pod time code
1             package App::EvalServerAdvanced::Protocol;
2 1     1   24577 use strict;
  1         2  
  1         26  
3 1     1   5 use warnings;
  1         1  
  1         36  
4              
5             our $VERSION = '0.103';
6             # ABSTRACT: Protocol abstraction for App::EvalServerAdvanced
7             my $protocol_version = 1;
8              
9 1     1   10 use v5.24.0;
  1         4  
10 1     1   5 no warnings 'experimental';
  1         2  
  1         24  
11              
12 1     1   717 use Google::ProtocolBuffers::Dynamic;
  0            
  0            
13             use Path::Tiny qw/path/;
14             use Function::Parameters;
15             use Encode qw/encode decode/;
16              
17             use Exporter 'import';
18             our @EXPORT = qw/decode_message encode_message/;
19              
20             my $path = path(__FILE__)->parent->child("protocol.proto");
21              
22             # load_file tries to allocate >100TB of ram. Not sure why, so we'll just read it ourselves
23             my $proto = $path->slurp_utf8;
24              
25             my $gpb = Google::ProtocolBuffers::Dynamic->new();
26              
27             $gpb->load_string("protocol.proto", $proto);
28              
29             $gpb->map({ pb_prefix => "messages", prefix => "App::EvalServerAdvanced::Protocol", options => {accessor_style => 'single_accessor'} });
30              
31             fun handle_decoding($obj) {
32             my $type = ref($obj);
33             $type =~ s/^App::EvalServerAdvanced::Protocol:://;
34             given($type) {
35             when("Eval") {
36             # I can't decide if I should decode these or not. Keeping them as raw bytes seems safer
37             # for my $file ($obj->files->@*) {
38             # my $f_encoding = $file->encoding;
39              
40             # if ($f_encoding ne "raw" && $f_encoding ne "") {
41             # $file->contents(decode($f_encoding, $file->contents));
42             # }
43             # }
44             }
45             when("Warning") {
46             if ($obj->encoding) {
47             $obj->message(decode($obj->encoding, $obj->message));
48             }
49             }
50             when("EvalResponse") {
51             if ($obj->encoding) {
52             $obj->contents(decode($obj->encoding, $obj->contents));
53             }
54             }
55             }
56             }
57              
58             fun handle_encoding($type, $obj) {
59             given($type) {
60             when("eval") {
61             for my $file ($obj->{files}->@*) {
62             my $f_encoding = $file->{encoding};
63              
64             if (defined $f_encoding && $f_encoding ne "raw" && $f_encoding ne "") {
65             $file->{contents} = encode($f_encoding, $file->{contents});
66             }
67             }
68             }
69             when("warning") {
70             if ($obj->{encoding}) {
71             $obj->{message} = encode($obj->{encoding}, $obj->{message});
72             }
73             }
74             when("response") {
75             if ($obj->{encoding}) {
76             $obj->{contents} = encode($obj->{encoding}, $obj->{contents});
77             }
78             }
79             }
80             }
81              
82             fun encode_message($type, $obj) {
83             handle_encoding($type, $obj);
84             my $message = App::EvalServerAdvanced::Protocol::Packet->encode({$type => $obj});
85              
86             # 8 byte header, 0x0000_0001 0x1234_5678
87             # first 4 bytes are the protocol version, last 4 are length of the message in octets
88             my $header = pack "NN", $protocol_version, length($message);
89             return ($header . $message);
90             };
91              
92             fun decode_message($buffer) {
93             return (0, undef, undef) if length $buffer < 8; # can't have a message without a header
94              
95             my $header = substr($buffer, 0, 8); # grab the header
96             my ($reserved, $length) = unpack("NN", $header);
97              
98             die "Undecodable header" if ($reserved != $protocol_version);
99            
100             # Packet isn't ready yet
101             return (0, undef, undef) if (length($buffer) - 8 < $length);
102              
103             my $message_bytes = substr($buffer, 8, $length);
104             substr($buffer, 0, $length+8, "");
105              
106             my $message = App::EvalServerAdvanced::Protocol::Packet->decode($message_bytes);
107             my ($k) = keys %$message;
108              
109             die "Undecodable message" unless ($k);
110             my $real_message = $message->$k;
111             handle_decoding($real_message);
112              
113             return (1, $real_message, $buffer);
114             };
115              
116             1;