HTTP::Recorder - record interaction with websites

    #!/usr/bin/perl

    use HTTP::Proxy;
    use HTTP::Recorder;

    my $proxy = HTTP::Proxy->new();

    # create a new HTTP::Recorder object
    my $agent = new HTTP::Recorder;

    # set the log file (optional)
    $agent->file("/tmp/myfile");

    # set HTTP::Recorder as the agent for the proxy
    $proxy->agent( $agent );

    # start the proxy
    $proxy->start();

    1;

package HTTP::Recorder;

our $VERSION = "0.05";

use strict;
use warnings;
use LWP::UserAgent;
use HTML::TokeParser;
use HTTP::Recorder::Logger;
use URI::Escape qw(uri_escape uri_unescape);
use URI::QueryParam;
use HTTP::Request::Params;

our @ISA = qw( LWP::UserAgent );

sub new {
    my $class = shift;

    my %args = ( @_ );

    my $self = $class->SUPER::new( %args );
    bless $self, $class;

    $self->{prefix} = $args{prefix} || "rec";
    $self->{control} = $args{control} || "http-recorder";
    $self->{logger} = $args{logger} || 
	new HTTP::Recorder::Logger(file => $args{file});
    $self->{ignore_favicon} = $args{ignore_favicon} || 1;

    return $self;
}

sub prefix { shift->_elem('prefix',      @_); }

sub control { shift->_elem('control',      @_); }

sub logger { 
    my $self = shift;
    $self->_elem('logger',      @_);
}

sub ignore_favicon { shift->_elem('ignore_favicon',      @_); }

sub file {
    my $self = shift;
    my $file = shift;

    $self->{logger}->file($file) if $file;
}

sub send_request {
    my $self = shift;
    my $request = shift;

    my $response;

    # special handling if the URL is the control URL
    if ($request->uri->host eq $self->{control}) {

	# get the arguments passed from the form
	my $arghash;
	$arghash = extract_values($request);

	# there may be an action we need to perform
	if (exists $arghash->{updatescript}) {
	    my $script = $arghash->{ScriptContent};
	    $self->{logger}->SetScript($script || '');
	} elsif (exists $arghash->{clearscript}) {
	    $self->{logger}->SetScript("");
	} 

	my ($h, $content);
	if (exists $arghash->{goto}) {
	    my $url = $arghash->{url};

	    if ($url) {
		my $r = new HTTP::Request("GET", $url);
		my $response = $self->send_request( $r );

		return $response;
	    } else {
		$h = HTTP::Headers->new(Content_Type => 'text/html');
		$content = $self->get_start_page();
	    }
	} elsif (exists $arghash->{savescript}) {
	    $h = HTTP::Headers->new(Content_Type => 'text/plain',
				    Content_Disposition => 'attachment; filename=recorder-script.pl');
	    my @script = $self->{logger}->GetScript();
	    $content = join('', @script);
	} else {
	    $h = HTTP::Headers->new(Content_Type => 'text/html');
	    $content = $self->get_recorder_content();
	}

	$response = HTTP::Response->new(200,
					"",
					$h,
					$content,
					);
    } else {
	$request = $self->modify_request ($request)
            unless $self->{ignore_favicon}
                && $request->uri->path =~ /favicon\.ico$/i;

	$response = $self->SUPER::send_request( $request );

	my $content_type = $response->headers->header('Content-type') || "";

	# don't try to modify the content unless it's text/<something>
	if ($content_type =~ m#^text/#i) {
	    $self->modify_response($response);
	}
    }

    return $response;
}

sub modify_request {
    my $self = shift;
    my $request = shift;

    my $values = extract_values($request);

    # log the actions
    my $action = $values->{"$self->{prefix}-action"};

    my $referer = $request->headers->referer;
    if (!$action) {
	if (!$referer) {
	    my $uri = $self->unmodify($request->uri);;

	    # log a blank line to give the code a little breathing room
	    $self->{logger}->LogLine();
	    $self->{logger}->GotoPage(url => $uri);
	}
    } elsif ($action eq "follow") {
	$self->{logger}->FollowLink(text => $values->{"$self->{prefix}-text"} || "",
			    index => $values->{"$self->{prefix}-index"} || "",
			    url => $values->{"$self->{prefix}-url"});
    } elsif ($action eq "submitform") {
	my %fields;
	my ($btn_name, $btn_value, $btn_number);
	foreach my $param (keys %$values) {
	    my %fieldhash;
	    my ($fieldtype, $fieldname);
	    if ($param =~ /^$self->{prefix}-form(\d+)-(\w+)-(.*)$/) {
		$fieldtype = $2;
		$fieldname = $3;

		if ($fieldtype eq 'submit') {
		    next unless $values->{$fieldname};
		    $btn_name = $fieldname;
		    $btn_value = $values->{$fieldname};
		} else {
		    next if ($fieldtype eq 'hidden');
		    next unless $fieldname && exists $values->{$fieldname};
		    $fieldhash{'name'} = $fieldname;
		    $fieldhash{'type'} = $fieldtype;
		    if (ref($values->{$fieldname}) eq 'ARRAY') {
			my @tempvalues = @{$values->{$fieldname}};
			for (my $i = 0 ; $i < scalar @tempvalues ; $i++) {
			    $fieldhash{'value'} = $tempvalues[$i];
			    my %temphash = %fieldhash;
			    $fields{"$fieldname-$i"} = \%temphash;
			}
		    } else {
			$fieldhash{'value'} = $values->{$fieldname};
			$fields{$fieldname} = \%fieldhash;
		    }
		}
	    }
	}

	$self->{logger}->SetFieldsAndSubmit(name => $values->{"$self->{prefix}-formname"}, 
					    number => $values->{"$self->{prefix}-formnumber"},
					    fields => \%fields,
					    button_name => $btn_name,
					    button_value => $btn_value);

	# log a blank line to give the code a little breathing room
	$self->{logger}->LogLine();
    }

    # undo what we've done
    $request->uri($self->unmodify($request->uri));
    $request->content($self->unmodify($request->content));

    # reset the Content-Length (if needed) to prevent warnings from
    # HTTP::Protocol
    if ($action && ($action eq "submitform")) {
	$request->headers->header('Content-Length' => length($request->content()) );
	
    }

    my $https = $values->{"$self->{prefix}-https"};
    if ( $https && $https == 1) {
	my $uri = $request->uri;
	$uri->scheme('https') if $uri->scheme eq 'http';

	$request = new HTTP::Request($request->method, 
				     $uri, 
				     $request->headers, 
				     $request->content);
	
    }	    

    return $request;
}

sub unmodify {
    my $self = shift;
    my $content = shift;

    return $content unless $content;

    # get rid of the arguments we added
    my $prefix = $self->{prefix};

    for my $key ($content->query_param) {
	if ($key =~ /^$prefix-/) {
	    $content->query_param_delete($key);
	}
    }
    return $content;
}

sub extract_values {
    my $request = shift;

    my $parser = HTTP::Request::Params->new({
	req => $request,
    });

    # un-escape all params
    for my $key (keys %{$parser->params}) {
	$parser->params->{$key} = uri_unescape($parser->params->{$key});
    }

    return $parser->params;
}

sub modify_response {
    my $self = shift;
    my $response = shift;
    my $formcount = 0;
    my $formnumber = 0;
    my $linknumber = 1;

    $response->headers->push_header('Cache-Control', 'no-store, no-cache');
    $response->headers->push_header('Pragma', 'no-cache');

    my $content = $response->content();
    my $p = HTML::TokeParser->new(\$content);
    my $newcontent = "";
    my %links;
    my $formname;

    my $js_href = 0;
    my $in_head = 0;
    my $basehref;
    while (my $token = $p->get_token()) {
	if (@$token[0] eq 'S') {
	    my $tagname = @$token[1];
	    my $attrs = @$token[2];
	    my $oldaction;
	    my $text;

	    if ($tagname eq 'head') {
		$in_head = 1;
	    } elsif ($in_head && $tagname eq 'base') {
		$basehref = new URI($attrs->{'base'});
	    } elsif ($tagname eq 'html') {
		# add the javascript to update the script
		$newcontent .= $self->script_update();
	    } elsif (($tagname eq 'a' || $tagname eq 'link') && 
		     $attrs->{'href'}) {
		my $t = $p->get_token();
		if (@$t[0] eq 'T') {
		    $text = @$t[1];
		} else {
		    undef $text;
		}
		$p->unget_token($t);

		# up the counter for links with the same text
		my $index;
		if (defined $text) {
		    $links{$text} = 0 if !(exists $links{$text});
		    $links{$text}++;
		    $index = $links{$text};
		} else {
		    $index = $linknumber;
		}
		if ($attrs->{'href'} =~ m/^javascript:/i) {
		    $js_href = 1;
		} else {
		    if ($tagname eq 'a') {
			$attrs->{'href'} = 
			    $self->rewrite_href($attrs->{'href'}, 
						$text, 
						$index,
						$response->base);
		    } elsif ($tagname eq 'link') {
			$attrs->{'href'} = 
			    $self->rewrite_linkhref($attrs->{'href'}, 
						    $response->base);
		    }
		}
		$linknumber++;
	    } elsif ($tagname eq 'form') {
		$formcount++;
		$formnumber++;
	    }

	    # put the hidden field before the real field
	    # so that it won't be inside
	    if (!$js_href && 
		$tagname ne 'form' && ($formcount == 1)) {
		my ($formfield, $fieldprefix, $fieldtype, $fieldname);
		$fieldprefix = "$self->{prefix}-form" . $formnumber;
		$fieldtype = lc($attrs->{type}) || 'unknown';
		if ($attrs->{name}) {
		    $fieldname = $attrs->{name};
		    $formfield = ($fieldprefix . '-' . 
				  $fieldtype . '-' . $fieldname);
		    $newcontent .= "<input type=\"hidden\" name=\"$formfield\" value=1>\n";
		}
	    }

	    $newcontent .= ("<".$tagname);

	    # keep the attributes in their original order
	    my $attrlist = @$token[3];
	    foreach my $attr (@$attrlist) {
		# only rewrite if 
		# - it's not part of a javascript link
		# - it's not a hidden field
		$newcontent .= (" ".$attr."=\"".$attrs->{$attr}."\"");
	    }
	    $newcontent .= (">\n");
	    if ($tagname eq 'form') {
		if ($formcount == 1) {
		    $newcontent .= $self->rewrite_form_content($attrs->{name} || "",
							       $formnumber,
							       $response->base);
		}
	    }
	} elsif (@$token[0] eq 'E') {
	    my $tagname = @$token[1];
	    if ($tagname eq 'head') {
		if (!$basehref) {
		    $basehref = $response->base;
		    $basehref->scheme('http') if $basehref->scheme eq 'https';
		    $newcontent .= "<base href=\"" . $basehref . "\">\n";
		}
		$basehref = "";
		$in_head = 0;
	    }
	    $newcontent .= ("</");
	    $newcontent .= ($tagname.">\n");
	    if ($tagname eq 'form') {
		$formcount--;
	    } elsif ($tagname eq 'a' || $tagname eq 'link') {
		$js_href = 0;
	    }
	} elsif (@$token[0] eq 'PI') {
	    $newcontent .= (@$token[2]);
	} else {
	    $newcontent .= (@$token[1]);
	}
    }

    $response->content($newcontent);

    return;
}

sub rewrite_href {
    my $self = shift;
    my $href = shift || "";
    my $text = shift || "";
    my $index = shift || 1;
    my $base = shift;

    my $newhref = new URI($href);
    my $prefix = $self->{prefix};

    if ($base->scheme eq 'https') {
	$newhref->query_param_append( "$prefix-https", 1);
	$newhref->scheme('http');
    }

    # the original URL
    $newhref->query_param_append( "$prefix-url", uri_escape($href));
    
    # the action (i.e. follow link)
    $newhref->query_param_append( "$prefix-action", 'follow');

    # the link information
    $text = uri_escape($text); # might have special characters
    $newhref->query_param_append( "$prefix-text", $text);
    $newhref->query_param_append( "$prefix-index", $index);

    return $newhref;
}

sub rewrite_linkhref {
    my $self = shift;
    my $href = shift || "";
    my $base = shift;

    my $newhref = new URI($href);
    my $prefix = $self->{prefix};

    $newhref->query_param_append( "$prefix-https", 1) 
				  if $base->scheme eq 'https';

    # the original URL
    $newhref->query_param_append( "$prefix-url", uri_escape($href));
    
    # the action (i.e. don't record)
    $newhref->query_param_append( "$prefix-action", 'norecord');

    return $newhref;
}

sub rewrite_form_content {
    my $self = shift;
    my $name = shift || "";
    my $number = shift;
    my $url = shift;
    my $fields;

    my $https = 1 if ($url->scheme eq 'https');

    $fields .= ("<input type=hidden name=\"$self->{prefix}-action\" value=\"submitform\">\n");
    $fields .= ("<input type=hidden name=\"$self->{prefix}-formname\" value=\"$name\">\n");
    $fields .= ("<input type=hidden name=\"$self->{prefix}-formnumber\" value=\"$number\">\n");
    if ($https) {
    $fields .= ("<input type=hidden name=\"$self->{prefix}-https\" value=\"$https\">\n");
    }

    return $fields;
}

sub get_start_page {
    my $self = shift;

    my $content = <<EOF;
<html>
<head>
<title>HTTP::Recorder Start Page</title>
<SCRIPT LANGUAGE="JavaScript">
<!-- // start
    self.focus(); // bring this window to the front
// end -->
</SCRIPT>
</head>
<body>
<h1>Start Recording</h1>
<p>Type a url into the browser's adddress field to begin recording.
</html>
EOF

    return $content;
}

sub get_recorder_content {
    my $self = shift;

    my @script = $self->{logger}->GetScript();
    my $script = "";
    foreach my $line (@script) {
	next unless $line;
	$line =~ s/\n//g;
	$script .= "$line\n";
    }

    my $content = <<EOF;
<SCRIPT LANGUAGE="JavaScript">
<!-- // start
function scrollScriptAreaToEnd() {
    scriptarea = document.forms['ScriptForm'].elements['ScriptContent'];
    scriptarea.scrollTop = scriptarea.scrollHeight;
    scriptarea.focus();
}
// end -->
</SCRIPT>

<html>
<head>
<title>HTTP::Recorder Control Panel</title>
<STYLE type="text/css">
   table {font-family:Helvetica,sans-serif; font-size:14px}
   input {font-family:Helvetica,sans-serif; font-size:12px}
 </STYLE>
</head>
<body bgcolor="lightgrey" 
      onLoad="javascript:scrollScriptAreaToEnd()"
>
<table width=100% height=98%>
<FORM name="GotoForm" method="POST" action="http://$self->{control}/" target="recording">
  <tr>
    <td>
      Goto page: <input name="url" size=30>
      <input type=submit name="goto" value="Go">
      <hr>
    </td>
  </tr>
</FORM>
  <tr>
    <td width="100%" height="100%">
      <table width="100%" height="100%">
        <FORM name="ScriptForm" method="POST" action="http://$self->{control}/">
        <tr>
	  <td>
Current Script:
          </td>
        </tr>
        <tr>
          <td height=100%>
<textarea style="font-size: 10pt;font-family:monospace;width:100%;height:100%" name="ScriptContent">$script</textarea>
          </td>
        </tr>
        <tr>
          <td align=center>
            <INPUT TYPE="SUBMIT" name="updatescript" VALUE="Apply">
            <INPUT TYPE="RESET">
            <INPUT TYPE="BUTTON" VALUE="Refresh" onClick="window.location='http://$self->{control}/'">
          </td>
        </tr>
        <tr>
          <td align=center>
             <INPUT TYPE="SUBMIT" name="clearscript" VALUE="Delete"
            onClick="if (!confirm('Do you really want to delete the script?')){ return false; }">
            <INPUT TYPE="SUBMIT" name="savescript" VALUE="Save As">
          </td>
        </tr>
      </FORM>
      </table>
    </td>
  </tr>
      </table>
</body></html>
EOF

    return $content;
}

sub script_update {
    my $self = shift;

    my $url = "http://" . $self->control . "/";
    my $js = <<EOF;
// find the top-level opener window
var opwindow = window.opener;
while (opwindow.opener) {
  opwindow = opwindow.opener;
}
// update it with HTTP::Recorder's control panel
if (opwindow) {
 opwindow.location = "http://http-recorder/";
}
EOF

return <<EOF;
<SCRIPT LANGUAGE="JavaScript">
<!-- // start
$js
// end -->
</SCRIPT>
EOF
}

1;