package POE::Filter::Tor::TC1;					# -*- CPerl -*-

use strict;
use warnings;

use POE::Filter::Line;
use vars qw($VERSION @ISA);
$VERSION = '0.001';
@ISA = qw(POE::Filter::Line);

use constant CRLF => "\015\012";

use constant LINE_BUFFER	=> POE::Filter::Line::FIRST_UNUSED + 0;
use constant LINE_STATE		=> POE::Filter::Line::FIRST_UNUSED + 1;
use constant FIRST_UNUSED	=> POE::Filter::Line::FIRST_UNUSED + 2;

use constant ST_IDLE	=> 0;	# after a final response line is received
use constant ST_CONT	=> 1;	# after a continuation line is received
use constant ST_DATA	=> 2;	# collecting to terminating "." on its own line

sub new {
  my $class = shift;
  # TC1 is a line-oriented protocol, with "network" CRLF line endings.
  $class->SUPER::new(Literal => CRLF);
}

# sub get_one_start inherited from POE::Filter::Line

sub get_pending {
  my $self = shift;
  my @data = ();

  @data = map {$_.CRLF} @{$self->[LINE_BUFFER]} if $self->[LINE_BUFFER];

  my $loose = $self->SUPER::get_pending;
  push @data, @$loose if $loose;

  return \@data if @data;
  return undef;
}

sub get_one {
  my $self = shift;
  my $lines = $self->[LINE_BUFFER] || [];
  my $state = $self->[LINE_STATE] || ST_IDLE;

  my $line = $self->SUPER::get_one;	# get one line

  # first pass to accumulate a complete response in the buffer
  while (@$line) {
    for (@$line) {	# (alias $_ to the element in @$line)
      if ($state == ST_IDLE || $state == ST_CONT) {
	# starting or continuing a reply message
	unless (m/^[[:digit:]]{3}([- +])/)
	  { die "invalid response received: $_" }
	#  $1 -- response continuation flag
	if ($1 eq '-')		# further lines follow in same reply
	  { $state = ST_CONT }
	elsif ($1 eq '+')	# begin multiline data block
	  { $state = ST_DATA }
	else # $1 eq ' '	# last line in reply
	  { $state = ST_IDLE }
      } elsif ($state == ST_DATA) {
	# collecting data
	$state = ST_CONT if m/^[.]$/;
      } else
	{ die "invalid internal state $state" }
      push @$lines, $_;
    }
  } continue { $line = ($state == ST_IDLE) ? [] : $self->SUPER::get_one }


  if ($state == ST_IDLE && @$lines) { # the buffer contains a complete response
    # reset object buffers
    $self->[LINE_BUFFER] = [];
    $self->[LINE_STATE] = ST_IDLE;
    # check, collect and return data
    return [_parse_reply(_check_reply($lines))];
  }

  $self->[LINE_BUFFER] = $lines;
  $self->[LINE_STATE] = $state;

  return [];	# waiting for more data to arrive
}

# helper for sub get_one
sub _check_reply {
  my $lines = shift;

  # check buffered response
  $lines->[0] =~ m/^([[:digit:]]{3})/
    or die "invalid first line: ".$lines->[0];
  my $first_code = $1;
  my $async_message = (6 eq substr $1,0,1); my $mixed_async = 0;
  my $all_codes_match = 1;
  my $state = ST_CONT;
  foreach (@$lines) {
    if ($state == ST_CONT) {
      m/^([[:digit:]]{3})([- +])/; # will always match
      # state tracking
      if ($2 eq '-') { $state = ST_CONT }
      elsif ($2 eq '+') { $state = ST_DATA }
      else { $state = ST_IDLE }
      # message validation
      $all_codes_match = 0 unless $first_code eq $1;
      if ($async_message)	{ $mixed_async = 1 unless m/^6/ }
      else			{ $mixed_async = 1 if m/^6/     }
    } elsif ($state == ST_DATA) {
      if (m/^[.]$/) { $state = ST_CONT }
    } else {			# idle state reached but more data follows
      die "returned to idle state with more lines pending\n".
	"at \"$_\" in\n".
	  join("\n", @$lines);
    }
  }
  unless ($state == ST_IDLE)
    { die "incomplete response processed:\n".join("\n", @$lines) }
  if ($mixed_async)		# explicitly disallowed in protocol spec
    { die "async/sync responses conflated:\n".join("\n", @$lines) }

  return ($lines, $all_codes_match)
}

# helper for sub get_one
sub _parse_reply {
  my $lines = shift;
  my $all_codes_match = shift;

  if ($all_codes_match) {
    # decode general response
    #
    #  In general responses, the first line is always parsed as a series of
    #  positional fields followed by an optional series of keyword fields.
    #  Subsequent lines can additionally be parsed as bi-level keyword
    #  fields, if they begin with a single space-delmited token, followed
    #  by keyword fields.  This bi-level syntax is used by PROTOCOLINFO.
    #
    my @result = (substr $lines->[0],0,3);
    my %attrs = ();
    my $target = undef;
    my $state = ST_IDLE;
    my $is_error = ($result[0] =~ m/^[45]/);

    foreach (@$lines) {
      if ($state == ST_CONT || $state == ST_IDLE) {
	substr $_,0,3,'';		# remove status code
	my $flag = substr $_,0,1,'';	# extract continuation flag
	if ($is_error) {
	  push @result, $_;		# copy message for errors
	} elsif ($flag ne '+' && m/^([^"=\s]+)=(.+)$/) {
	  # lines beginning with a keyword carry one field to end-of-line
	  $attrs{$1} = $2;
	} elsif ($state == ST_CONT && m/^([^"=\s]+)(?=\s[^"=\s]+=)/g) {
	  # lines beginning with a space-delmited keyword carry bi-level fields
	  my $tag = $1;
	  $attrs{$tag}{$1} = $2
	    while m/\G\s*([^"=\s]+)=([^"\s]+|"(?:[^"\\]+|\\"?)+")/g;
	} else {
	  # other lines may contain keyword fields after positional fields
	  push @result, m/\G\s*([^"=\s]+|"(?:[^"\\]+|\\"?)+")(?=\s|$)/gc;
	  $attrs{$1} = $2
	    while m/\G\s*([^"=\s]+)=([^"\s]+|"(?:[^"\\]+|\\"?)+")/g;
	}
	if ($flag eq '+') {
	  $state = ST_DATA;
	  if (m/\G\s*([^"=\s]+)=$/)
	    { $attrs{$1}  = ''; $target = \$attrs{$1}  }
	  else
	    { push @result, ''; $target = \$result[-1] }
	}
	$state = ST_CONT if $state == ST_IDLE;
      } else {	# ($state == ST_DATA)	# collect data line
	if (m/^[.]$/) { $state = ST_CONT; $target = undef; next }
	$$target .= $_."\n";
      }
    }

    # process backslash escapes in double-quoted values
    s/^"(.*)"$/$1/ && s/\G([^\\]*)\\(.)/$1$2/g
      for @result, values %attrs;
    foreach (grep ref, values %attrs)
      { s/^"(.*)"$/$1/ && s/\G([^\\]*)\\(.)/$1$2/g for %$_ }

    push @result, \%attrs if scalar keys %attrs;
    return \@result
  } else {
    # return special result structure indicating varying response codes
    my @result = (undef);
    my $state = ST_CONT;
    my $target = undef;

    foreach (@$lines) {
      if ($state == ST_CONT) {
	my @row = (substr $_,0,3,'');	# extract status code
	my $flag = substr $_,0,1,'';	# extract continuation flag
	push @row, $_;			# omit line-splitting in this mode
	if ($flag eq '+') {
	  $state = ST_DATA;
	  $target = \$row[-1];
	}
	push @result, \@row;
      } else {	# ($state == ST_DATA)	# collect data line
	if (m/^[.]$/) { $state = ST_CONT; $target = undef; next }
	$$target .= $_."\n";
      }
    }

    return \@result;
  }
}

# sub put inherited from POE::Filter::Line for now

1;
__END__

=head1 NAME

POE::Filter::Tor::TC1 - Tor Control Protocol 1 filter for POE

=head1 SYNOPSIS

  use Data::Dumper;
  use POE qw(Filter::Tor::TC1 Component::Client::TCP);

  POE::Component::Client::TCP->new(
    RemoteAddress => 'localhost',
    RemotePort => 9051,
    Filter => 'POE::Filter::Tor::TC1',
    Connected => sub {
      $_[HEAP]{server}->put("protocolinfo")
    },
    ServerInput => sub {
      my $input = $_[ARG0];
      print Data::Dumper->Dump([$input],[qw(ProtocolInfo)]);
      $_[HEAP]{server}->put("quit");
      $_[KERNEL]->yield("shutdown");
    },
  );

  POE::Kernel->run();

=head1 DESCRIPTION

POE::Filter::Tor::TC1 is a L<POE::Filter> for sending commands to and
parsing replies from a Tor node on its control interface.

=head1 METHODS

POE::Filter::Tor::TC1 implements the interface defined in
L<POE::Filter/PUBLIC INTERFACE>.

=head1 AUTHOR

Jacob Bachmeyer, E<lt>jcb@cpan.orgE<gt>

=head1 SEE ALSO

L<POE::Filter>

L<https://www.torproject.org/>
L<https://gitweb.torproject.org/torspec.git/tree/control-spec.txt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2021 by Jacob Bachmeyer

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=cut