ICQ process_message must also call escapeHTML.

[thrasher.git] / perl / lib / Thrasher / XML.pm

package Thrasher::XML;
use strict;
use warnings;

use base 'Exporter';

BEGIN {
    our @EXPORT_OK = qw(iq_reply error_tag iq_error feature
                        has_subtags no_match strip_resource
                        same_name normalize_name get_attr
                        extract multi_extract save save_match save_sub
                        spec_is_optional take text_extractor
                        extract_disco_items extract_disco_info
                        recursive_extract);
    our %EXPORT_TAGS = (all => \@EXPORT_OK);
}

use Thrasher::Constants qw(:all);
use Thrasher::Log qw(:all);
use Carp qw(confess);
use Data::Dumper;

my %namespaces = (stream => 'http://etherx.jabber.org/streams',
                  '' => 'jabber:client', # 'default" namespace
                  );

=pod

=head1 NAME

Thrasher::XML - a collection of functions for manipulating XML

=cut

=head1 CONVENIENCE FUNCTIONS

Several convenience functions for working with namespaced tag names
are provided.

=over 4

=item *

C<same_name>($l, $r): Given two names, returns true if they are
the same name, false otherwise. This function calls C<normalize_name>
on both arguments for you.

=cut

# Compare two names, as represented in this code, to see if they are
# the same. If the first element exists in %namespaces, the full
# namespace will be substituted. If the value is a string, it will
# be in the default namespace, which for streams is 'jabber:client'.
sub same_name {
    my $left = shift;
    my $right = shift;

    $left = normalize_name($left);
    $right = normalize_name($right);

    return $left->[0] eq $right->[0] && $left->[1] eq $right->[1];
}

=pod

=item *

C<normalize_name>($name): Normalizes the given name according to the
following rules:

=over 4

=item *

If the name is a "Clark-style" URI+name {uri}name, breaks out
the uri and the name separately.

=item *

If the name is a simple string, the name is returned as being in
the default namespace ("jabber:client").

=item *

If the name is a two-element array, and the namespace has an entry
in the internal %namespaces hash, the entry in the hash will
replace the namespaces. This is why you can so ofter refer to 
['stream', 'stream'] instead of ['http://etherx.jabber.org/streams',
'stream']. 

=item *

If the name is a two-element array that didn't meet the prior
condition, the array is returned.

=item *

If the name makes it this far, the function dies with a descriptive
error message showing what you passed in.

=back

You shouldn't really need to call this function, everything in this
module tends to call it at every opportunity.

Also note that this is only legit because the shortcuts are
hard-coded, not pulled from the XML itself. Using actual
prefixes in the XML would be wrong.

=cut

sub normalize_name {
    my $name = shift;
    
    if (!ref($name)) {
        if ($name =~ /^\{([^}]+)\}(.*)$/) { 
            return [$1, $2];
        }
        return [$namespaces{''}, $name];
    }

    if (ref($name) eq 'ARRAY') {
        my ($namespace, $tag) = @$name;
        if (exists($namespaces{$namespace})) {
            $namespace = $namespaces{$namespace};
        }
        return [$namespace, $tag];
    }

    confess "Invalid parameter passed to normalize_name:\n"
        . Dumper($name);
}

=pod

=item *

C<get_attr>($attr_name, $attrs_hash): Get the value of an attribute
from an attribute list, using the correct attribute name. $attr_name
is passed through normalize name.

=cut

sub get_attr {
    my $name = shift;
    my $atts = shift;

    $name = normalize_name($name);
    $name = '{' . $name->[0] . '}' . $name->[1];
    return $atts->{$name};
}

=pod

C<extract>($xml_pattern, $xml): Extracts values from processed XML
into a hash for your consumption, or dies if the xml_pattern doesn't
match, using a pattern matching syntax.

The XML pattern is a structure that looks like the structure
we use for XML, and matches in the following way:

=over 4

=item * If a field is undef, the field must exist, but may
be anything.

=item * If the field is a placeholder, the field must exist,
but may be anything.

=item * If the field is a constant value, it must exactly match
the given constant value.

=item * If the field is a variable specification, as described below,
the field must match the match specification passed in as a parameter
to C<extract>.

=item * Fields not defined in the match clause at all are ignored.

=back

As a special case, for children specifications, the match will
succeed if I<any> of the children match, and for placeholders
with conditions, any matching children will be extracted.

If the match is successful, a hashref will be returned with the
result of all the placeholders, according to the names given. 
If you had no placeholders (pure matching), then the hashref
will be empty. Otherwise, the placeholders will receive whatever

This is a powerful method, but I'm going to wave at the other code
and say to look at the examples for usage; if you need more docs,
ask for them.

As a special exeption, if the $xml_pattern is undef, the function
simply returns $xml, implementing a "match everything" clause
that is useful for error cases.

The variables and placeholders that you can use:

=over 

=item C<save>($name): The basic placeholder that will
simply return the contents with no further processing.

=item C<save_match>([$name,] $match): Recursively calls
match. If this fails (returns undef), the entire match
fails; if it succeeds, the values in the matched hash
are merged into the final returned hash.

If used in a children match, this will return only the
first such matching result, useful for extracting subelements.

If no name is given, it will only be used to match, it
won't save the match specifically. (This can be used to 
recursively match and save inner elements.)

=item C<save_sub>($name, $sub): Calls the sub with
the result, returns the result of the I<sub> as the result
of the match. 

If used in the children match spec, where this will collect 
all sub runs that don't return "undef" into the resulting
arrayref, and fail if no children match the spec.

=item C<take>($name): This requires that you pass in a
value for taking to the "extract" hash, which will be
treated exactly as if it were in the original specification,
right down to allowing you to return values. This allows
us to factor out constant or repeating patterns and avoid
constructing and garbage collecting them over and over.

=back

=cut

sub extract {
    my $xml_pattern = shift;
    my $xml = shift;
    my $provided_vars = shift || {};

    # undefined $xml_pattern matches everything
    if (!defined($xml_pattern)) {
        return $xml;
    }

    if (!ref($xml)) {
        return undef;
    }

    if (!defined($xml_pattern)) {
        return $xml;
    }

    my $final_hash = {};

    my ($pat_element, $pat_atts, $pats_children) = @$xml_pattern;
    my ($element, $atts, $children) = @$xml;

    my $string_equal = sub { $_[0] eq $_[1] };

    my $extract_fail_reason = '';
    my $returned;

    my $compare;
    $compare = sub {
        my $match_spec = shift;
        my $match_target = shift;
        my $comparator = shift || $string_equal;
        
        if (!defined($match_spec)) {
            return $match_target;
        } elsif (ref($match_spec) eq 
                 'Thrasher::XMPPStreamIn::Placeholder') {
            $final_hash->{$match_spec->{name}} = $match_target;
            return $match_target || $match_spec->{optional};
        } elsif (ref($match_spec) eq
                 'Thrasher::XMPPStreamIn::Variable') {
            return $compare->($provided_vars->{$$match_spec},
                              $match_target,
                              $comparator);
        } elsif(ref($match_spec) eq
                'Thrasher::XMPPStreamIn::Placeholder::Match') {
            my $match = $match_spec->{match};
            my $result = extract($match, $match_target, $provided_vars);

            if (!defined($result) && !$result->{optional}) {
                $extract_fail_reason = "Matching XML against a string.";
                return undef;
            } else {
                # failure automatically propogates as a die.
                while (my ($key, $value) = each %$result) {
                    $final_hash->{$key} = $value;
                }
                return $match_target;
            }
        } elsif (ref($match_spec) eq
                 'Thrasher::XMPPStreamIn::Placeholder::Sub') {
            my $name = $match_spec->{name};
            my $subref = $match_spec->{subref};
            my $result = $subref->($match_target);
            if (!defined($result)) {
                $extract_fail_reason = 'Subroutine returned an undef.';
                return undef;
            }
            if (defined($name)) {
                $final_hash->{$name} = $result;
            }
            return $result;
        } else {
            return $comparator->($match_spec, $match_target) ?
                $match_target : undef;
        }
    };

    # Clean up after the closure, which tends to confuse perl
    # GC
    my $cleanup;
    $cleanup = sub { undef $compare; undef $cleanup; undef $string_equal; };

    ELEMENT_NAME: {
        my $element_compare = sub {
            my ($pat_namespace, $pat_element_name) = @{shift()};
            my ($namespace, $element_name) = @{shift()};

            if (defined($pat_namespace) &&
                $pat_namespace ne $namespace) {
                $extract_fail_reason =
                    "Namespace mismatch: $pat_namespace ne $namespace";
                return 0; # fail
            }
            
            if (defined($pat_element_name) &&
                $pat_element_name ne $element_name) {
                $extract_fail_reason =
                    "Element name mismatch: $pat_element_name ne $element_name";
                return 0;
            }
            
            return 1;
        };

        $element = normalize_name($element);
        my $result = $compare->($pat_element, $element,
                                $element_compare);
        undef $element_compare;

        # Upgrade undefs to a die
        if (!$result) {
            $cleanup->();
            confess "In element name: $extract_fail_reason";
        }
    }

    ATTRIBUTES: {
        if (!defined($pat_atts)) {
            # deliberately blank; no action
        } else {
            while (my ($key, $value) = each %$pat_atts) {
                # verify existence in the target atts
                # before passing off to $compare
                if (substr($key, 0, 1) ne '{') {
                    $key = '{}' . $key;
                }

                if (!exists($atts->{$key})) {
                    if (spec_is_optional($value)) {
                        next;
                    }
                    $cleanup->();
                    confess "Attribute $key unexpectedly didn't exist.";
                }
                if (!$compare->($value, $atts->{$key})) {
                    $cleanup->();
                    confess "In attribute: $extract_fail_reason";
                }
            }
        }
    }

    my $match_children1 = sub {
        my ($pat_children) = @_;

        my $final_children = [];
        for my $child (@$children) {
            my $match_result = eval {
                $compare->($pat_children,
                           $child);
            };
            if (!$@ && defined($match_result)) {
                if (ref($pat_children) eq
                      'Thrasher::XMPPStreamIn::Placeholder::Match' &&
                        $pat_children->{name}) {
                    return $match_result;
                }
                push @$final_children, $match_result;
            }
        }

        if (!@$final_children && !spec_is_optional($pat_children)) {
            $cleanup->();
            confess "In attempting to match children, none matched.";
        }
        # Transfer the matching results into the name for the sub if needed
        if (ref($pat_children) eq 'Thrasher::XMPPStreamIn::Placeholder::Sub') {
            return $final_children;
        }
        elsif (ref($pat_children) eq 'Thrasher::XMPPStreamIn::Placeholder') {
            return $final_children;
        }
        else {
            return;
        }
    };

    CHILDREN: {
          if (defined($pats_children)) {
              if (ref($pats_children) ne 'ARRAY') {
                  $pats_children = [ $pats_children ];
              }
              elsif (scalar(@{$pats_children}) == 0) {
                  # Special case: [] means "no children"
                  if (scalar(@{$children}) != 0) {
                      $cleanup->();
                      confess('Match wanted no children.');
                  }
                  last CHILDREN;
              }
              for my $pat_children (@{$pats_children}) {
                  my $to_save = $match_children1->($pat_children);
                  if ($to_save) {
                      $final_hash->{$pat_children->{name}} = $to_save;
                  }
              }
          }
      }

    $cleanup->();
    return $final_hash;
}

# Taking in pairs of extract_specifications and sub actions,
# try multiple matches at a time, dying only if they all fail.
# Put the most likely success stanza up front.
sub multi_extract {
    # assumes none of the matches will change $xml_message
    my $xml_message = shift;

    while (@_) {
        my $match = shift @_;
        my $action = shift @_;
        if (!defined($action)) {
            confess "Match rule given without action for multi_extract.";
        }
        my $result;
        {
            local $@;
            eval {
                $result = extract($match, $xml_message);
            };
        }
        if (defined($result)) {
            return $action->($result);
        }
    }

    confess("In multi-extract, no matches found. Message: ".
            Dumper($xml_message));
}

sub save ($;$) { 
    my $name = shift;
    my $optional = shift;
    my $self = {name => $name,
                optional => $optional};
    return bless $self, 'Thrasher::XMPPStreamIn::Placeholder';
}

sub save_match ($;$$) {
    my $match;
    my $name;
    my $optional;
    if (@_ >= 2) {
        $name = shift;
        $match = shift;
        $optional = shift;
    } else {
        $match = shift;
        $name = '';
    }
    my $self = {match => $match, name => $name, optional => $optional};
    bless $self, 'Thrasher::XMPPStreamIn::Placeholder::Match';
}

sub save_sub ($$;$) {
    my $name = shift;
    my $subref = shift;
    my $optional = shift;
    my $var_spec = {name => $name, subref => $subref, optional => $optional};
    bless $var_spec, 'Thrasher::XMPPStreamIn::Placeholder::Sub';
}

sub spec_is_optional {
    my $spec = shift;
    return (ref($spec) eq 'Thrasher::XMPPStreamIn::Placeholder::Match'
            ||
            ref($spec) eq 'Thrasher::XMPPStreamIn::Placeholder'
            ||
            ref($spec) eq 'Thrasher::XMPPStreamIn::Placeholder::Sub')
        && $spec->{optional};
}
    

sub take ($) {
    my $name = shift;
    return bless \$name, 'Thrasher::XMPPStreamIn::Variable';
}

# This does not descend into subtags, by design
sub text_extractor {
    if (!ref($_[0])) { return $_[0] }
    return undef;
}

=pod

Some shortcuts for common specification patterns:

=over 

=back

=back

=cut


# NOTE NOTE NOTE: You pass back the *original* to and from to
# this function, with centralizes the reversing of those
# two parameters!
sub iq_reply {
    my $self = shift;
    my $iq_params = shift;
    my $response = shift;

    # Reconstruct an IQ response
    my $iq = [[$NS_COMPONENT, 'iq'], 
              {from => $iq_params->{to},
               to => $iq_params->{from},
               id => $iq_params->{id},
               type => 'result'},
              ($response ? [$response] : [])];
    $self->xml_out($iq);
}

sub error_tag {
    my $error = shift;

    if (!exists($IQ_ERRORS{$error})) {
        confess "Undefined error code $error used.";
    }

    my ($error_code, $error_type, $error_tag) =
        @{$IQ_ERRORS{$error}};

    return [[$NS_COMPONENT, 'error'],
            {code => $error_code,
             type => $error_type},
            [[[$NS_ERROR, $error_tag], {}, []]]
            ]
}

sub iq_error {
    my $self = shift;
    my $iq_params = shift;
    my $error_id = shift;

    my $query = $iq_params->{query};
    my $children = [$query];

    push @$children, error_tag($error_id);

    my $iq = [[$NS_COMPONENT, 'iq'],
              {from => $iq_params->{to},
               to => $iq_params->{from},
               id => $iq_params->{id},
               type => 'error'},
              $children];
    $self->xml_out($iq);
}

sub feature { [[$NS_DISCO_INFO, 'feature'], {var => $_[0]}, []] }

# Pass the children list;
sub has_subtags {
    my $children = shift;
    return !!(grep { ref($_) } @$children);
}

# Returns a multi_extract clause that matches everything, and 
# prints off an useful error logging event. This in effect turns
# multi_extract into a function that dies when unexpected stuff
# occurs, into printing something out on STDERR.
# This requires the children to be 
sub no_match {
    my $self = shift;
    my $message = shift;
    my $iq_params = shift;
    my @other_params = @_;
    return undef, sub {
        log $message . "\n";
        log Dumper(\@other_params) if @other_params;
        $self->iq_error($iq_params, 'bad_request');
    };
}

sub strip_resource {
    my $jid = shift;
    if (!defined($jid)) {
        confess "stripping the resource from an undefined JID";
    }
    $jid =~ s/\/.*$//;
    return $jid;
}

# Tear apart a disco result, returning an array of identities
# [type, category, name], followed by an array of features. Give this
# the perl data corresponding to the <query> tag.
sub extract_disco_info {
    my $query = shift;

    my $disco = extract([undef, undef, 
                              save_sub('disco', 
                                       sub {( ref($_[0]) && 
                                                 (($_[0]->[0]->[1] eq 'identity') ||
                                                 ($_[0]->[0]->[1] eq 'feature'))) ?
                                                 $_[0] : undef},
                                       # Don't require children; empty
                                       # results may be e.g. an
                                       # incompletely started service.
                                       1)],
                        $query);
    my @identities;
    my @features;

    for my $feature_or_identity (@{$disco->{disco}}) {
        my $atts = $feature_or_identity->[1];
        if ($feature_or_identity->[0]->[1] eq 'identity') {
            my $identity = $feature_or_identity;
            my @identity_data = 
                ($atts->{'{}type'}, $atts->{'{}category'}, 
                 $atts->{'{}name'});
            push @identities, \@identity_data;
        } else {
            my $feature = $feature_or_identity;
            push @features, $atts->{'{}var'};
        }
    }

    return \@identities, \@features;
}

sub extract_disco_items {
    my $query = shift;

    my $disco = extract([undef, undef, 
                              save_sub('disco', 
                                       sub {( ref($_[0]) && 
                                                 (($_[0]->[0]->[1] eq 'item'))) ?
                                                 $_[0] : undef})],
                        $query);
    my @items = map { $_->[1]->{'{}jid'} } @{$disco->{disco}};

    return \@items;
}

# Given a list of &extract specifications, recurse down the
# list and return the whole chunk of extract results in one
# convenient array. Indicate what XML to recurse on by saving the 
# target XML in the "rec" field of the extract result.
sub recursive_extract {
    my $xml = shift;

    my $results = {};
    my $recursion = $xml;

    while ($recursion && @_) {
        my $extract_spec = shift @_;

        my $extract_results;
        {
            local $@;
            eval {
                $extract_results = extract($extract_spec,
                                           $recursion);
            };

            # If there was an error, return what we got.
            if ($@) {
                print "Error: $@\n";
                return $results;
            }

            if ($extract_results && 
                @_ &&
                !exists($extract_results->{rec})) {
                warn "Further recursive extractions are specified, "
                    ."but no 'rec' element resulted. Did you forget "
                    ."to specify a 'rec'?";
            }
        }
        $recursion = $extract_results->{rec};
        
        if ($extract_results) {
            while (my ($key, $val) = each %$extract_results) {
                $results->{$key} = $val;
            }
        }
    }

    return $results;
}

1;