# ==========================================================================
#
# ZoneMinder ONVIF Module, $Date$, $Revision$
# Copyright (C) 2001-2008  Philip Coombes
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
#
# ==========================================================================
#
# This module contains the common definitions and functions used by the rest
# of the ZoneMinder scripts
#
package ZoneMinder::ONVIF;

use 5.006;
use strict;
use warnings;

require Exporter;
require ZoneMinder::Base;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = (
    functions => [ qw(
      ) ]
    );
push( @{$EXPORT_TAGS{all}}, @{$EXPORT_TAGS{$_}} ) foreach keys %EXPORT_TAGS;

our @EXPORT_OK = ( @{ $EXPORT_TAGS{all} } );

our @EXPORT = qw();

use Data::UUID;

use vars qw( $verbose $soap_version );

require ONVIF::Client;

require WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort;
require WSDiscovery10::Elements::Header;
require WSDiscovery10::Elements::Types;
require WSDiscovery10::Elements::Scopes;

require WSDiscovery::TransportUDP;

sub deserialize_message {
  my ($wsdl_client, $response) = @_;
  if ( ! $response ) {
    return;
  }

# copied and adapted from SOAP::WSDL::Client

# get deserializer 
  my $deserializer = $wsdl_client->get_deserializer();
  
  if ( !$deserializer ) {
    $deserializer = SOAP::WSDL::Factory::Deserializer->get_deserializer({
        soap_version => $wsdl_client->get_soap_version(),
        %{ $wsdl_client->get_deserializer_args() },
        });
  }
# set class resolver if serializer supports it
  $deserializer->set_class_resolver( $wsdl_client->get_class_resolver() )
    if $deserializer->can('set_class_resolver');

# Try deserializing response - there may be some,
# even if transport did not succeed (got a 500 response) 
# as our faults are false, returning a success marker is the only
# reliable way of determining whether the deserializer succeeded.
# Custom deserializers may return an empty list, or undef,
# and $@ is not guaranteed to be undefined.
  my ($success, $result_body, $result_header) = eval {
    (1, $deserializer->deserialize($response));
  }; 
  if ( defined $success ) {
    return wantarray
    ? ($result_body, $result_header)
    : $result_body;
  } elsif (blessed $@) { #}&& $@->isa('SOAP::WSDL::SOAP::Typelib::Fault11')) {
    return $@;
  } 

  return $deserializer->generate_fault({
      code => 'soap:Server',
      role => 'urn:localhost',
      message => "Error deserializing message: $@. \n"
      . "Message was: \n$response"
    });
} # end sub deserialize_message

sub interpret_messages {
  my ( $svc_discover, $services, @responses ) = @_;

  my @results;
  foreach my $response ( @responses ) {
		print "Received message:\n" . $response . "\n" if $verbose;

    my $result = deserialize_message($svc_discover, $response);
    if ( not $result ) {
      print "Error deserializing message. No message returned from deserializer.\n" if $verbose;
      next;
    }

    my $xaddr;
    my $probe_match = $result->get_ProbeMatch();
    next if ! $probe_match;
    foreach my $l_xaddr (split ' ', $probe_match->get_XAddrs()) {
#   find IPv4 address
      print "l_xaddr = $l_xaddr\n" if $verbose;
      if ( $l_xaddr =~ m|//[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+[:/]| ) {
        $xaddr = $l_xaddr;
        last;
      } else {
        print STDERR "Unable to find IPv4 address from xaddr $l_xaddr\n";
      }
    }

# No usable address found
    next if not $xaddr;

# ignore multiple responses from one service
    next if defined $services->{$xaddr};
    $services->{$xaddr} = 1;

    print $xaddr.', '.$svc_discover->get_soap_version().', ';

    print '(';
    my $scopes = $result->get_ProbeMatch()->get_Scopes();
    my $count = 0;
    my %scopes;
    foreach my $scope (split ' ', $scopes) {
      if ( $scope =~ m|onvif://www\.onvif\.org/(.+)/(.*)| ) {
        my ($attr, $value) = ($1,$2);
			print ', ' if 0 < $count ++;
        print $attr . '=\'' . $value . '\'';
        $scopes{$attr} = $value;
      }
    }
    print ")\n";
    push @results, {
			xaddr					=> $xaddr,
      soap_version  => $svc_discover->get_soap_version(),
      scopes 				=> \%scopes,
    };
  }
  return @results;
} # end sub interpret_messages

# functions

sub discover {
  my ($soap_versions, $net_interface) = @_;
  my @results;

## collect all responses
  my @responses = ();

  no warnings 'redefine';

  *WSDiscovery::TransportUDP::_notify_response = sub {
    my ($transport, $response) = @_;
    push @responses, $response;
  };

  my $uuid_gen = Data::UUID->new();

  foreach my $version ( $soap_versions ? ( split(',',$soap_versions) ) : ( '1.1', '1.2') ) {
		my %services;

    print "Probing for SOAP $version\n" if $verbose;
    my $svc_discover = WSDiscovery10::Interfaces::WSDiscovery::WSDiscoveryPort->new({
#    no_dispatch => '1',
        });
    $svc_discover->set_soap_version($version);
		if ( $net_interface ) {
			my $transport = $svc_discover->get_transport();
			print "Setting net interface for $transport to $net_interface\n" if $verbose;
			$transport->set_net_interface($net_interface);
		}

    my $uuid = $uuid_gen->create_str();

    my $result = $svc_discover->ProbeOp(
				{ # WSDiscovery::Types::ProbeType
				(
				 ($version eq '1.1') ?
				   (
						 Types => 'http://www.onvif.org/ver10/network/wsdl:NetworkVideoTransmitter http://www.onvif.org/ver10/device/wsdl:Device', # QNameListType
					 ) : (
						 xmlattr => { 'xmlns:dn'  => 'http://www.onvif.org/ver10/network/wsdl', },
					 )
				),
						 Types => 'dn:NetworkVideoTransmitter', # QNameListType
				Scopes =>  { value => '' },
        },
        WSDiscovery10::Elements::Header->new({
          Action => { value => 'http://schemas.xmlsoap.org/ws/2005/04/discovery/Probe' },
          MessageID => { value => "urn:uuid:$uuid" },
          To => { value => 'urn:schemas-xmlsoap-org:ws:2005:04:discovery' },
          })
        );
    print $result."\n" if $verbose;

    push @results, interpret_messages($svc_discover, \%services, @responses);
		@responses = ();
  } # end foreach version

  return @results;
} # end sub discover

sub profiles {
  my ($client) = @_;

  my $media = $client->get_endpoint('media');
  if ( !$media ) {
    print "No media endpoint for client.\n";
    return;
  }

  my $result = $media->GetProfiles( { } ,, );
  if ( !$result ) {
    print "No result from GetProfiles.\n";
    return;
  }
  if ( $verbose ) {
    use XML::LibXML;
    my $dom = XML::LibXML->load_xml(string=>$result);
    print "Received message:\n" . $dom->toString(1) . "\n";
  }
  my @Profiles = @{ $result->get_Profiles() };
  if ( !@Profiles ) {
    print "No profiles returned from get_Profiles\n";
    return;
  }
  print 'Number of profiles found: ' .(scalar @Profiles)."\n" if $verbose;
  my @profiles;

  foreach my $profile ( @Profiles ) {
    my $token = $profile->attr()->get_token() ;
    my $Name = $profile->get_Name();

    my $VideoEncoderConfiguration = $profile->get_VideoEncoderConfiguration();
    if ( ! $VideoEncoderConfiguration ) {
      print "No VideoEncoderConfiguration in profile $token $Name.\n";
      next;
    }

# Specification gives conflicting values for unicast stream types, try both.
# http://www.onvif.org/onvif/ver10/media/wsdl/media.wsdl#op.GetStreamUri
    foreach my $streamtype ( 'RTP_unicast', 'RTP-Unicast', 'RTP-multicast', 'RTP-Multicast' ) {
      my $StreamUri = $media->GetStreamUri( {
          StreamSetup =>  { # ONVIF::Media::Types::StreamSetup
            Stream => $streamtype, # StreamType
            Transport =>  { # ONVIF::Media::Types::Transport
              Protocol => 'RTSP', # TransportProtocol
            },
          },
          ProfileToken => $token, # ReferenceToken
        } );
      if ( ! ( $StreamUri and $StreamUri->can('get_MediaUri') ) ) {
        print "No StreamUri or no MediaUri on profile $Name of type $streamtype\n" if $verbose;
        next;
      }
      if ( $verbose ) {
        eval {
          use XML::LibXML;
          my $dom = XML::LibXML->load_xml(string=>$StreamUri);
          print "Received message:\n" . $dom->toString(1) . "\n";
        };
      }
      my $MediaUri = $StreamUri->get_MediaUri();
      if ( !$MediaUri ) {
        print "No MediaUri in profile $Name of type $streamtype\n";
        next;
      }
      if ( $verbose ) {
        eval {
          use XML::LibXML;
          my $dom = XML::LibXML->load_xml(string=>$MediaUri);
          print "Received message:\n" . $dom->toString(1) . "\n";
        };
      }
      my $Uri = $MediaUri->get_Uri();
      if ( ! $Uri ) {
        print "No Uri in profile $Name of type $streamtype\n";
        next;
      }
      if ( $verbose ) {
        eval {
          use XML::LibXML;
          my $dom = XML::LibXML->load_xml(string=>$Uri);
          print "Received message:\n" . $dom->toString(1) . "\n";
        };
      }
      my $Resolution = $VideoEncoderConfiguration->get_Resolution();
      my $Width = $Resolution ? $Resolution->get_Width() : 0;
      my $Height = $Resolution ? $Resolution->get_Height() : 0;
      my $RateControl = $VideoEncoderConfiguration->get_RateControl();
      my $FrameRateLimit = $RateControl ? $RateControl->get_FrameRateLimit() : 0;

      push @profiles, [
        $token,
        $Name,
        $VideoEncoderConfiguration->get_Encoding(),
        $Width,
        $Height,
        $FrameRateLimit,
        $streamtype,
        $Uri,
      ];
    } # end foreach streamtype

  } # end foreach profile

#
# use message parser without schema validation ???
#
  return @profiles;

} # end sub profiles

sub move {
  my ($client, $dir) = @_;

  my $result = $client->get_endpoint('ptz')->GetNodes( { } ,, );

  die $result if not $result;
  print $result . "\n";
} # end sub move

sub metadata {
  my ($client) = @_;
  my $media = $client->get_endpoint('media');
  die 'No media endpoint.' if !$media;

  my $result = $media->GetMetadataConfigurations( { } ,, );
  if ( !$result ) {
    print "No MetaDataConfigurations\n" if $verbose;
  } else {
    print $result . "\n";
  }

  $result = $media->GetVideoAnalyticsConfigurations( { } ,, );
  if ( ! $result ) {
    print "No VideoAnalyticsConfigurations\n" if $verbose;
  } else {
    print $result . "\n";
  }

#  $result = $client->get_endpoint('analytics')->GetServiceCapabilities( { } ,, );
#  die $result if not $result;
#  print $result . "\n";

}

1;
__END__

=head1 NAME

ZoneMinder::ONVIF - perl module to access onvif functions for ZoneMinder

=head1 SYNOPSIS

use ZoneMinder::ONVIF;

=head1 DESCRIPTION

This is a module to contain useful functions and import all the other modules 
required for ONVIF to work.

=head2 EXPORT

None by default.

=head1 SEE ALSO

http://www.zoneminder.com

=head1 AUTHOR

Philip Coombes, E<lt>philip.coombes@zoneminder.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2001-2008  Philip Coombes

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.3 or,
at your option, any later version of Perl 5 you may have available.


=cut
