#!/usr/bin/perl # # THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESSED OR IMPLIED # WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL NETMESH INC. BE LIABLE FOR ANY DIRECT, # INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR # SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) # HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED # OF THE POSSIBILITY OF SUCH DAMAGE. # # The use of this software is governed by a license agreement that # is contained in the package that you downloaded. package main; use strict; use CGI; use XML::Xerces; use XML::XPath; use LWP; my $CAPABILITIES_MIME = 'application/xrds+xml'; my $HTML_MIME = 'text/html'; my $YADISYADIS_HTTP_HEADER = 'X-XRDS-Location'; my $q = new CGI(); my $url = $q->param( 'url' ); my $content = < NetMesh script: Given a URL, determine its Yadis capabilities

NetMesh script: Given a URL, determine its Yadis capabilities

HTML if( $url ) { $content .= <Capability test result for URL: $url
HTML $content .= determineResult( $url ); $content .= < HTML } $content .= <New test:

Enter the URL whose Yadis capabilities you would like to determine:

Go back

HTML if( $ENV{'HTTP_HOST'} ) { return( $content, 'text/html'); } else { print $content; exit; } ##### sub determineResult { my $url = shift; my $ret; ## First try a direct query with $CAPABILITIES_MIME only $ret .= "

Direct query, asking for MIME type $CAPABILITIES_MIME

\n"; $ret .= "

Querying URL $url.

\n"; my $ua = LWP::UserAgent->new( parse_head => 0 ); my $headers = HTTP::Headers->new; $headers->header( 'Accept', $CAPABILITIES_MIME ); my $request = HTTP::Request->new( 'GET', $url, $headers ); my $response = $ua->simple_request( $request ); my $capabilities = undef; my $htmlMetaUrl; if( $response->code eq HTTP::Status::RC_OK ) { if( $response->content_type eq $CAPABILITIES_MIME ) { $capabilities = parseCapabilities( $response->content ); if( $capabilities ) { $ret .= dumpCapabilities( $capabilities ); } else { $ret .= "

No capabilities found in response of MIME type $CAPABILITIES_MIME.

\n"; } } else { $ret .= "

Response of MIME type '" . $response->content_type . "' ignored the MIME type that was requested.

\n"; if( $response->content_type eq $HTML_MIME ) { $htmlMetaUrl = findHtmlMetaUrl( $response->content ); if( $htmlMetaUrl ) { $ret .= "

Found META http-equiv header '$YADIS_HTTP_HEADER' in response.

\n"; } } } } else { $ret .= "

Empty response (HTTP code " . $response->code . ")

\n"; } my $yadisMetaUrl = $response->header( $YADIS_HTTP_HEADER ); if( $yadisMetaUrl ) { if( $yadisMetaUrl =~ m!^(https?|ftp)://...! ) { $ret .= "

Returning $YADIS_HTTP_HEADER pointing to URL $yadisMetaUrl.

\n"; } else { $ret .= "

Is returning $YADIS_HTTP_HEADER with syntactically invalid URL $yadisMetaUrl.

\n"; $yadisMetaUrl = undef; } } else { $ret .= "

No HTTP header '$YADIS_HTTP_HEADER' in response.

\n"; } $ret .= "

No META http-equiv header '$YADIS_HTTP_HEADER' in response.

\n" unless( $htmlMetaUrl ); ## Now look at any returned $YADIS_HTTP_HEADER, if any if( $yadisMetaUrl ) { $ret .= "

Query to $YADIS_HTTP_HEADER returned from HTTP

\n"; $ret .= "

Querying URL $yadisMetaUrl.

\n"; $ua = LWP::UserAgent->new( parse_head => 0 ); $request = HTTP::Request->new( 'GET', $yadisMetaUrl ); $response = $ua->simple_request( $request ); if( $response->is_success ) { $capabilities = parseCapabilities( $response->content ); if( $capabilities ) { $ret .= dumpCapabilities( $capabilities ); } else { $ret .= "

No capabilities found in response from URL" . " $yadisMetaUrl.

\n"; } } else { $ret .= "

Request to URL" . " $yadisMetaUrl" . " failed with HTTP response code " . $response->code . "

\n"; } } ## Now look at any meta-equiv in return HTML, if any if( $htmlMetaUrl ) { $ret .= "

Query to $YADIS_HTTP_HEADER found as HTTP-EQUIV in HTML

\n"; $ret .= "

Querying URL $htmlMetaUrl.

\n"; $ua = LWP::UserAgent->new( parse_head => 0 ); $request = HTTP::Request->new( 'GET', $htmlMetaUrl ); $response = $ua->simple_request( $request ); if( $response->is_success ) { $capabilities = parseCapabilities( $response->content ); if( $capabilities ) { $ret .= dumpCapabilities( $capabilities ); } else { $ret .= "

No capabilities found in response from URL" . " $htmlMetaUrl.

\n"; } } else { $ret .= "

Request to URL" . " $htmlMetaUrl" . " failed with HTTP response code " . $response->code . "

\n"; } } $ret .= "

Result

\n"; if( $capabilities ) { $ret .= "

Capabilities found, this is a Yadis URL.

\n"; } else { $ret .= "

No capabilities found for URL" . " $url. This is not a Yadis URL.

\n"; } return $ret; } sub findHtmlMetaUrl { my $html = shift; require HTML::HeadParser; my $p = HTML::HeadParser->new; $p->parse( $html ); return $p->header( $YADIS_HTTP_HEADER ); } sub parseCapabilities { my $content = shift; my $error = 1; my @capNodes; eval { my $lidXp = XML::XPath->new(xml => $content); @capNodes = $lidXp->find( '/XRDS/xrd:XRD/xrd:Service' )->get_nodelist; $error = 0; }; if( $error ) { return undef; } else { return \@capNodes; } } sub dumpCapabilities { my $cap = shift; my $ret = < Type HTML foreach my $capNode( @$cap ) { $ret .= " \n"; foreach my $childNode ( $capNode->getChildNodes() ) { if( $childNode->getName eq 'xrd:Type' ) { $ret .= " "; my $type; foreach my $grandChildNode( $childNode->getChildNodes() ) { $type .= $grandChildNode->getData(); } $ret .= "$type\n"; $ret .= "\n"; } } $ret .= " \n"; } $ret .= "\n"; return $ret; }