#!perl -w
#
# Form2WSDL Converter
# March 2005
# by Ross Shannon <ross.shannon@gmail.com>
#
################################################################################
#	Pull in required Perl modules

use strict;
use CGI;
use URI::URL;
use CGI qw(:all);
use CGI::Carp qw(fatalsToBrowser);
use LWP::UserAgent;
use HTML::Form;
use HTML::TreeBuilder;
use HTML::Element;

################################################################################
#	Set constants and initialise global variables

my $doc_root	= $ENV{'DOCUMENT_ROOT'};					# filesystem location
my $timestamp	= scalar localtime();					    # report timestamp

# User-Agent string and contact address for robot
my $version = "0.9";
my $botUA = "Form2WSDL/$version (http://www.yourhtmlsource.com/projects/Form2WSDL/)";
my $botFrom = 'ross.shannon@gmail.com';

# A little metadata...
my $browser = $ENV{'HTTP_USER_AGENT'};

################################################################################
# Variables, variables everywhere

my $userAgent;
my $document;

my $request;
my $response;

my @forms;
my @complexElements;
my @complexValues;
my @submits;
my $parsetree;

################################################################################
# Get the data sent to this script from the form

my $query = new CGI;

# URL of document to check
my $url = &trim($query->param('url'));
# Eventual URL, taking redirects into account
my $examinedUrl;
my $contentType;
my $pageTitle;
my $metaRefreshUrl;

################################################################################
# Do some processing

&print_header();

# First check if it's URL input. Most probably will be, but we'll leave the door open.
if ($url) {
  
# Check if URL is valid
  if ($url =~ m#(?:https?://)|(?:ftp://)\S#i) { #URL is valid (enough), go ahead
    
    &getDocument($url);
    
    &tidyDocument($url);
    
    &extractForms($url);
    
    &makeParseTree($url);
    
  } else {
    # URL is invalid, print error message and exit.
    &print_error("Invalid URL: &#8220;" . $query->escapeHTML($url) . "&#8221;", 1);
  }
} else {
  &print_error("No URL specified.", 1);
}

################################################################################
# Start Output. We'll only get here if there haven't been any 'quickdeath' errors so far.

# Primary metadata
print "<div id=\"metadata\">";
unless ($url eq $examinedUrl) {
  print "<p>URL requested: &#8220;<a href=\"".$url."\">".$url."</a>&#8221;.<br/>After following HTTP redirects we were served and examined the page: &#8220;<strong><a href=\"" .$examinedUrl."\">" .$examinedUrl."</a></strong>&#8221;.</p>";
} else {
  print "<p>URL examined: &#8220;<strong><a href=\"" .$examinedUrl."\">" .$examinedUrl."</a></strong>&#8221;</p>";
}
if ($metaRefreshUrl) {
  print_warning("This page was set up to automatically redirect to &#8220;$metaRefreshUrl&#8221; after a number of seconds. It&#8217;s recommended that you also <a href=\"./convert.pl?url=$metaRefreshUrl\">convert that page</a>.");
}
print "Page Title: &#8220;$pageTitle&#8221;" if $pageTitle;
##print "<p>Content-Type: &#8220;".$contentType."&#8221;.</p>";
print "</div>";
print "<hr />";

&outputFormsInformation;

# Don't output any WSDL if no forms existed on the page
if (scalar(@forms)) {
  &outputWSDL;
}

print "<hr />";
    
&outputOriginalSource;

&outputTidiedSource;

&print_footer();

exit(0);

##################################################################
# Functions

# Fetches document and returns it. Assumes basic validation check has been done on the URL.
sub getDocument {
  my $url = shift;
  
  # Configure the UA
  $userAgent = LWP::UserAgent->new;
  $userAgent->agent("$botUA");
  $userAgent->from("$botFrom");
  $userAgent->timeout(20);
  $userAgent->proxy(['http', 'ftp', 'https'], 'http://proxy5.ucd.ie:8585');
  $userAgent->no_proxy('localhost', 'htmlsource',);
  
  # Send request
  $request = HTTP::Request->new('GET', $url);
  
  # Get response
  $response = $userAgent->request($request);
  
  # Check on the URL we've gotten back. This may be different to the URL was asked for due to redirects etc.
  if (defined $response->request) {
    $examinedUrl = $response->request->url;
  }
  
  # Check how the bot got on
  if ($response->is_success) {
    
    # Determine character encoding of document (handy if we need to deal with encoding, erk!)
    $contentType = $response->header('Content-Type');
    unless (checkContentType($contentType)) {
      &print_error("This file was returned to us with the Content-Type &#8220;".$response->header('Content-Type')."&#8221; which this program does not accept. This commonly happens if you supply the <acronym title=\"Uniform Resource Locator\">URL</acronym> of an image or file in a data format that is not a form of <abbr title=\"Standard Generalised Markup Language\">SGML</abbr>. If you are sure that this is not the case, check your server setup to make sure this file is being served correctly.", 1);
    }
    
    # Grab Last-Modified header
    my $lastModified = $response->header('Last-Modified');
    
    # Store the response text
    $document = $response->content;
    
  } else {
    # Something's gone wrong with the request
    &print_error("Could not get page &#8220;$url&#8221;. Please check that the address is valid and that the page exists.</p>\n<p>The server&#8217;s response was: &#8220;".$response->status_line."&#8221;", 1);
  }
  
}

# Writes fetched page to file, runs it through tidy and outputs the tidied code
sub tidyDocument {
  my $url = shift;
  
  # Write page to file
  open(SOURCEFILE, ">sourcefile.txt");
  print SOURCEFILE $document;
  close SOURCEFILE;
  
  # run through tidy, save in place (online: /usr/local/bin/tidy )
  open(TIDY, "tidy.exe -f tidyerrors.txt -config tidyconfig.txt -i -wrap 150 -asxhtml -n -m sourcefile.txt 2>&1 |")
        || &print_warning("Could not tidy the document. This means the markup we&#8217;re parsing may not be of optimum quality, but will probably not affect the output.");
  close(TIDY);
}

# Parses the page for HTML forms
sub extractForms {
  @forms = HTML::Form->parse(&readFile("sourcefile.txt"), $response->base());
  
  # Find elements that require more complex parsing (enumerated types)
  # Whisk through the forms on the page and push any complex elements into the 2d array
  # We'll iterate through that again when we're writing the WSDL
  my $i = 0;
  my $j = 0;
  foreach my $form (@forms) {
    foreach my $input ($form->inputs) {
      if ($input->type eq "radio" or $input->type eq "option") {
        $complexElements[$i][$j++] = $input;
      }
    }
    $i++;
    $j = 0;
  }
  # $complexElements[0][0] now holds the first complex type in the first form, etc
}

# Creates a parse tree from the HTML file and then traverses is to find useful elements
# such as meta refresh commands and labels for form elements
sub makeParseTree {
  my $tree = HTML::TreeBuilder->new(); #empty tree
  $tree->parse_file("sourcefile.txt");
  
  my $h = $tree;
  $h->elementify(); # $h should now be <html>
  my @children = $h->content_list;
  foreach my $rootel (@children) {
    if ($rootel->tag() eq "head") {
      # We've found the <head> element
      my @headchildren = $rootel->content_list;
      foreach my $headel (@headchildren) {
        if ($headel->tag() eq "title") {
          my @a = $headel->content_list;
          $pageTitle = $a[0];
        }
        # Now search for meta refresh
        elsif ($headel->tag() eq "meta" and $headel->attr('http-equiv') eq "refresh") {
          $_ = &trim($headel->attr('content')); # Syntax:  5; url=newurl.html
          /^[0-9]*; url=(.*)/;
          $metaRefreshUrl = $1;
          my $pageUrl = URI::URL->new($metaRefreshUrl, $examinedUrl);
          $metaRefreshUrl = $pageUrl->abs; # Resolve to absolute URL
        }
      } 
    } else {
      $h = $rootel; # Make it the <body> tag. Slight optimization for further traversals
    }             
  }
  
  # Run through the 'work' array ($complexElements) and grab the necessary elements
  for my $form (0 .. $#complexElements) {
    for my $elem (0 .. $#{$complexElements[$form]}) {
      ##print "<p>element $form-$elem is ", $complexElements[$form][$elem]->type, "</p>";
      my $tempelem;
      my @tempelems;
      
      # Get radio values
      if ($complexElements[$form][$elem]->type eq "radio") {
        @tempelems = $h->look_down("_tag", "input",
                                   "type", "radio",
                                   "name", $complexElements[$form][$elem]->name);
        # This was the bastard causing all the trouble. I was calling the array
        # in scalar context, unbeknownst to me. Turns out sticking brackets around
        # the @tempelems array copies it to a new anonymous array which is then 
        # passed by reference. Well, obviously.
        $complexValues[$form][$elem] = [ @tempelems ];
      }
      
      # Get select values
      # Clever hack: instead of treating option values differently to radio buttons
      # later, we simply add a name attribute to each one, which makes them
      # behave exactly as a group of radio buttons.
      if ($complexElements[$form][$elem]->type eq "option") {
        $tempelem = $h->look_down("_tag", "select",
                                  "name", $complexElements[$form][$elem]->name);
                                  ##print $tempelem->attr('_tag');
        @tempelems = $tempelem->look_down("_tag", "option");
        for my $i (0 .. $#tempelems) {
          $tempelems[$i]->attr("name", $complexElements[$form][$elem]->name);
        }
        $complexValues[$form][$elem] = [ @tempelems ];
      }
      
      ##print "<p>Values for $form-$elem-0, aka ", $complexValues[$form][$elem][0]->attr("name"), " : ", $complexValues[$form][$elem][0]->attr("value"), "</p>";
    }
  }
  
  # Get submit values
  # Get all forms (again...), as we only want submits from one form at a time
  my @f = $h->look_down("_tag", "form");
  for my $form (0 .. $#forms) {
    
    ##print $forms[$form]->action;
    ##print $f[$form]->attr('action');                   
    my @tempelems = $f[$form]->look_down("_tag", "input",
                              "type", "submit");
    my @tempimageelems = $f[$form]->look_down("_tag", "input",
                              "type", "image");
                              ##print @tempimageelems[0]->attr('type');
    push @tempelems, @tempimageelems;
    @submits[$form] = [ @tempelems ];
  }
  ##print "\n", $submits[0][0]->attr('name');
}

# Trim leading and trailing whitespace from a string
# Takes a string as the first argument and returns the new string
sub trim {
    my $str = shift || return;
    $str =~ s/^\s+//go;
    $str =~ s/\s+$//go;
    return $str;
}

# Prints error page. If second argument is 1, the script'll die right here.
sub print_error {
  my $message = shift;
  my $shoulddie = shift;
  
  print "<div class=\"error\">\n<h2 class=\"error\">Error</h2>\n\n";
  print "<p><strong class=\"error\">$message</strong></p>\n";
  print "</div>";
  if ($shoulddie == 1) {
    &print_footer();
    exit;
  }
}

# Prints amber warning for errors requiring relatively minor attention.
sub print_warning {
  my $message = shift;
  
  print "<div class=\"warning\">\n";
  print "<p><strong>Warning</strong>: $message</p>\n";
  print "</div>";
}

# Checks if returned content-type is part of a list we'll accept, false otherwise
sub checkContentType {
    my $ctype = shift;

    return ($ctype =~ /text\/html/
        || $ctype =~ /text\/xml/
        || $ctype =~ /application\/xml/
        || $ctype =~ /application\/xhtml\+xml/
        || $ctype =~ /text\/sgml/
        || $ctype =~ /application\/sgml/);
}

# Print the contents of a file
sub readFile {

    my $file = shift || return;
    my $input = "";
    open(FILE, "$file") || die("Unable to open file: $!");
    while (<FILE>) {
        $input .= "$_";
    }
    close FILE;
    return $input;
}

#########################################################################
# Output Functions #

# Outputs the original source code
sub outputOriginalSource {
    print "<h2>Original Source Listing</h2>";
    print "<p class=\"showhide\"><input type=\"submit\" id=\"toggleoriginal\" onclick=\"toggleDisplay('original'); return false;\" onkeypress=\"toggleDisplay('original'); return false;\" value=\"Hide Source\"/></p>";
    print "<div class=\"sourcelisting\">";
    print "<pre id=\"originalsource\" class=\"hide\">" . trim($query->escapeHTML($document)) . "</pre>";
    print "</div>";
    #Free up memory
    undef($document);
}

# Outputs the file after tidy has been run on it
sub outputTidiedSource {
    #print $query->escapeHTML(&readFile("tidyerrors.txt"));

    print "<h2>Tidied Source Listing</h2>";
    print "<p class=\"showhide\"><input type=\"submit\" id=\"toggletidied\" onclick=\"toggleDisplay('tidied'); return false;\" onkeypress=\"toggleDisplay('tidied'); return false;\" value=\"Hide Source\"/></p>";
    print "<div class=\"sourcelisting\">";
    print "<pre id=\"tidiedsource\" class=\"hide\">" . $query->escapeHTML(&readFile("sourcefile.txt")) . "</pre>";
    print "</div>";
}

# Outputs details about the page's forms
sub outputFormsInformation {
 
  print "\n\n<h2>Form Information</h2>\n";
  
  # Count the number of forms on the page
  my $fc = scalar(@forms);
  if ($fc == 0) {
    print "<p>There are <strong>no forms</strong> on this page.</p>";
  } elsif ($fc == 1) {
    print "<p>There is <strong>one form</strong> on this page.</p>";
  } else {
    print "<p>There are <strong>".$fc." forms</strong> on this page.</p>";
  } print "\n";
  
  my $i = 1;
  foreach my $form (@forms) {
    print "\n<dl>\n";
    print "<dt><strong>$i. &nbsp;Action: <em class=\"action\">".$form->action."</em></strong></dt>\n";
    print "<dd>Method: <code>".$form->method."</code></dd>\n";
    ##print "<dd>Encoding: ".$form->enctype."</dd>\n";
    $i++;
    
    print "<dd><strong>Inputs: ".$form->inputs."</strong>\n<ol>\n"; # input count
    foreach my $input ($form->inputs) {
      print "<li>";
      print "Name: &#8220;<var>".$input->name."</var>&#8221;&nbsp;\n" if $input->name;
      print "Type: &#8220;<var>".$input->type."</var>&#8221;\n";
      print "&nbsp;Value: &#8220;<var>".$input->value."</var>&#8221;\n" if $input->value;
      print "</li>";
    }
      print "</ol></dd></dl>\n";
    
  } print "\n\n\n";
  
}

# Outputs the WSDL for this page
sub outputWSDL {

  # Rip apart the URL until we have the domain name sans extension, which we can then use to name things
  $url =~ m|(\w+)://([^/:]+)(:\d+)?/(.*)|;
  my $domainName = $2;
  $domainName =~ m/(www\.)?([^\.]+)(\.com|\.net|\.org)/;
  my $domain = $2;
  

  print "\n<h2><acronym title=\"Web Services Description Language\">WSDL</acronym> Output</h2>\n";
  
  print "<pre class=\"sourcelisting\">\n";
  print "&lt;?xml version=\"1.0\" encoding=\"UTF-8\"?>\n\n";
  #print "&lt;schema targetNamespace=\"http://$domain.com/schemas\"
       #xmlns=\"http://www.w3.org/2000/10/XMLSchema\"&gt;\n";
  #print "&lt;/schema&gt;\n";
  
  print "&lt;definitions name=\"".$domain."\"\n  targetNamespace=\"urn:".$domain."\"\n  xmlns=\"http://schemas.xmlsoap.org/wsdl/\"\n  xmlns:xsd=\"http://www.w3.org/2001/XMLSchema\"\n  xmlns:soap=\"http://schemas.xmlsoap.org/wsdl/soap/\"&gt;\n";
  
  # Types
  #print "&lt;<strong>types</strong>&gt;\n";
  #print "&lt;!-- no complex types yet --&gt;\n";
  #print "&lt;/types&gt;\n\n";
  
  # Messages (i.e. form elements)
  my $i = 1;
  foreach my $form (@forms) {
    print "\n&lt;<strong>message</strong> name=\"Message$i\"&gt;\n";
    foreach my $input ($form->inputs) {
    
      if ($input->type eq "radio" or $input->type eq "select" or $input->type eq "option") {
        # It's an enumerated type, so we need to work it
        &writeEnumerated($input->name, $i, $input->type);
        
      } else {
        unless ($input->type eq "submit" or $input->type eq "image") { 
          # It's a simple type, so just fire in the name and work out an xsd type
          print "  &lt;part name=\"".$input->name."\" type=\"xsd:".evaluate_type($input->name, $input->type, $input->value)."\"/&gt;\n" if $input->name and $input->type ne "reset";
        }
      }
    }
    # Finally, write submit button choice, if there is one
    &writeSubmits($i);
    print "&lt;/message&gt;\n";
    $i++;
  }
  # Output webpage message
  print "\n&lt;<strong>message</strong> name=\"MessageOut\"&gt;\n";
  print "  &lt;part name=\"Webpage\" type=\"xsd:string\"/&gt;\n";
  print "&lt;/message&gt;\n";
  
  # Ports (i.e. operations, i.e. forms)
  print "\n&lt;<strong>portType</strong> name=\"".$domain."Port\"&gt;\n";
  
  my $i = 1;
  foreach my $form (@forms) {
    print "  &lt;<em>operation</em> name=\"FormNumber$i\"&gt;\n";
    print "    &lt;input message=\"Message$i\"/&gt;\n";
    print "    &lt;output message=\"MessageOut\"/&gt;\n";
    print "  &lt;/operation&gt;\n";
    $i++;
  }
  print "&lt;/portType&gt;\n";
  
  # Binding
  print "\n&lt;<strong>binding</strong> name=\"".$domain."Binding\" type=\"typens:".$domain."Port\"&gt;\n";
  print "  &lt;soap:binding style=\"rpc\" transport=\"http://schemas.xmlsoap.org/soap/http\"/&gt;\n";
  my $i = 1;
  foreach my $form (@forms) {
    print "  &lt;<em>operation</em> name=\"FormNumber$i\"&gt;\n";
    print "    &lt;soap:operation soapAction=\"urn:".$domain."Action\"/&gt;\n";
    print "    &lt;input&gt;\n";
    print "      &lt;soap:body use=\"encoded\" namespace=\"urn:".$domain."\" encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"/&gt;\n";
    print "    &lt;/input&gt;\n";
    print "    &lt;output&gt;\n";
    print "      &lt;soap:body use=\"encoded\" namespace=\"urn:".$domain."\" encodingStyle=\"http://schemas.xmlsoap.org/soap/encoding/\"/&gt;\n";
    print "    &lt;/output&gt;\n";
    print "  &lt;/operation&gt;\n";
    $i++;
  }
  print "&lt;/binding&gt;\n";
  
  print "\n&lt;<strong>service</strong> name=\"".$domain."Service\"&gt;\n";
  print "  &lt;port name=\"".$domain."Port\" binding=\"typens:".$domain."Binding\"&gt;\n";
  print "    &lt;soap:address location=\"http://www.yourhtmlsource.com/projects/Form2WSDL/\n";  
  print "         invoke.pl?url=".$examinedUrl."\"/&gt;\n";
  print "  &lt;/port&gt;\n";
  print "&lt;/service&gt;\n";
  
  print "\n&lt;/definitions&gt;\n";
  print "</pre>";
}

#Writes the WSDL for complex enumerated elements like radio buttons, selects and multi-submits
sub writeEnumerated {
  my $name = shift;
  my $formNumber = shift; $formNumber--; # we started the count at 1, thus 'formNumber1' etc.
  my $type = shift;
  
  print "  &lt;simpleType name=\"$name\"&gt;\n";
  print "    &lt;restriction base=\"xsd:string\"&gt;\n";
  my $j = 0;
  while ($complexValues[$formNumber][$j]) {
    if ($complexValues[$formNumber][$j][0]->attr('name') eq $name) {
      my $i = 0;
      while ($complexValues[$formNumber][$j][$i]) {
        print "      &lt;enumeration value=\"",$complexValues[$formNumber][$j][$i]->attr("value"), "\"&gt;&lt;/enumeration&gt;\n";
        $i++;
      }
    }
  $j++;
  }
  print "    &lt;/restriction&gt;\n";
  print "  &lt;/simpleType&gt;\n";
}

# Write the submits for a form as an enumeration, IF there's more than one
sub writeSubmits {
  my $formNumber = shift; $formNumber--; # start at 0
  # Don't print anything if there's only one submit, as that doesn't represent a choice
  if ($#{$submits[$formNumber]} > 0) {
    print "\n  &lt;simpleType name=\"submit\"&gt;\n";
    print "    &lt;restriction base=\"xsd:string\"&gt;\n";
    my $j = 0;
    while ($submits[$formNumber][$j]) {
      print "      &lt;enumeration value=\"", $submits[$formNumber][$j]->attr('name'), "\"&gt;&lt;/enumeration&gt;\n";
      $j++;
    }
    print "    &lt;/restriction&gt;\n";
    print "  &lt;/simpleType&gt;\n";
  }
}

# Evaluates the type of a message
sub evaluate_type {
  my $name = shift;
  my $type = shift;
  my $value = shift;
  
  if ($type eq "checkbox" or ($value eq "true" or $value eq "false")) {
    return "boolean";
  } elsif ($value =~ /^[0-9]+$/ and $type ne "radio") {
    return "int";
  } elsif ($value =~ /^[0-9]+.[0-9]+$/ and $type ne "radio") {
    return "float";
  } elsif ($value =~ /^[http https ftp]+:/ and $type ne "password") {
    return "anyURI";
  } elsif ($value =~ /^[0-9]{2,4}[\/ -][0-9]{2}[\/ -][0-9]{2,4}$/) {
    return "date";
  }
  return "string";
}


# Prints standard start to all pages
sub print_header {
  print "Content-type: text/html; charset=ISO-8859-1\n\n";
  
  # if the script is being asked to convert the referring document, we extract this URL now
  my $badref = 0;
  if ($url =~ /referr?er/) {
    if ($ENV{'HTTP_REFERER'}) {
      $url = $ENV{'HTTP_REFERER'};
    } else {
      $badref = 1;
    }
  }
  
  print <<HERE;
  
  <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
  
  <html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
  <head>
    <title>Form2WSDL Conversion Results for &#8220;$url&#8221;</title>
HERE

  my $openfile = "includes/headstuff.inc";
  open(SSIFILE,"$openfile") || die "Cannot read from $openfile: $!";
	while(<SSIFILE>) { print $_; }
	close(SSIFILE);
  
  if ($badref) { &print_error("No referrer was found.", 1); }
  
}

sub print_footer {
  print <<HERE;
  <hr/>
  
  <h2>A Little Metadata...</h2>
  
  <p>Your user agent is &#8220;$browser&#8221;</p>
  
  <p>Your conversion occured at $timestamp. Thank you and good night.</p>
  
  </div>
  </body>
  <!-- ~Fin~ -->
  </html>
HERE
}