package HTTP::Recorder;

our $VERSION = "0.04";

=head1 NAME

HTTP::Recorder - record interaction with websites

=head1 VERSION

Version 0.04

=head1 SYNOPSIS

Set HTTP::Recorder as the user agent for a proxy, and it rewrites HTTP
responses so that additional requests can be recorded.

Set it up like this:

    #!/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;

Start the proxy script, then change the settings in your web browser
so that it will use this proxy for web requests.  For more information
about proxy settings and the default port, see L<HTTP::Proxy>.

The script will be recorded in the specified file, and can be viewed
and modified via the control panel.

=head2 The Control Panel

HTTP::Proxy provides a control panel.  From this panel, you can view
the script as it's being recorded, modify it, delete it, etc.

If you use C<< $agent->showwindow(1) >> in your proxy script and you have
popups enabled in your browser, the control panel will appear as a
Javascript popup window will appear after each recorded action.

=head2 SSL sessions

As of version 0.03, L<HTTP::Recorder> can record SSL sessions.

To begin recording an SSL session, go to the control URL
(http://http-recorder/ by default), and enter the initial URL.
Then, interact with the web site as usual.

=head2 Script output

By default, L<HTTP::Recorder> outputs L<WWW::Mechanize> scripts.

However, you can override HTTP::Recorder::Logger to output other types
of scripts.

=cut

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 );

=head1 Functions

=head2 new

Creates and returns a new L<HTTP::Recorder> object, referred to as the 'agent'.

=cut

sub new {
    my $class = shift;

    my %args = ( @_ );

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

    $self->{prefix} = $args{prefix} || "rec";
    $self->{showwindow} = $args{showwindow} || 0;
    $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;
}

=head2 $agent->prefix([$value])

Get or set the prefix string that L<HTTP::Recorder> uses for rewriting
responses.

=cut

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

=head2 $agent->showwindow([0|1])

Get or set whether L<HTTP::Recorder> opens a JavaScript popup window,
displaying the recorder's control panel.

=cut

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

=head2 $agent->control([$value])

Get or set the URL of L<HTTP::Recorder>'s control panel.  By default,
the control URL is 'http-recorder'.

The control URL will display a control panel which will allow you to
view and edit the current script.

=cut

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

=head2 $agent->logger([$value])

Get or set the logger object.  The default logger is a
L<HTTP::Recorder::Logger>, which generates L<WWW::Mechanize> scripts.

=cut

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

=head2 $agent->ignore_favicon([0|1])

Get or set ignore_favicon flag that causes L<HTTP::Recorder> to skip
logging requests favicon.ico files.  The value is 1 by default.

=cut

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

=head2 $agent->file([$value])

Get or set the filename for generated scripts.  The default is
'/tmp/scriptfile'.

=cut

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 = uri_unescape($arghash->{ScriptContent});
	    $self->{logger}->SetScript($script || '');
	} elsif (exists $arghash->{clearscript}) {
	    $self->{logger}->SetScript("");
	} elsif (exists $arghash->{goto}) {
	    my $url = uri_unescape($arghash->{url});

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

	    return $response;
	}
	
	my ($h, $content);
	if (exists $arghash->{savescript}) {
	    $h = HTTP::Headers->new(Content_Type => 'text/plain');
	    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,
    });

    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') {
		if ($self->{showwindow}) {
		    $newcontent .= $self->script_popup();
		}
	    } 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_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>
</head>
<body bgcolor="lightgrey" onLoad="javascript:scrollScriptAreaToEnd()">
<FORM name="ScriptForm" method="POST" action="http://$self->{control}/">
<table width=100% height=98%>
  <tr>
    <td>
Goto page: <input name="url" size=30>
<input type=submit name="goto" value="Go">
    </td>
  </tr>
  <tr>
    <td>
      <hr>
    </td>
  </tr>
  <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="BUTTON" VALUE="Refresh" onClick="window.location='http://$self->{control}/'">
      <INPUT TYPE="SUBMIT" name="updatescript" VALUE="Update">
      <INPUT TYPE="SUBMIT" name="clearscript" VALUE="Delete"
      onClick="if (!confirm('Do you really want to delete the script?')){ return false; }">
      <INPUT TYPE="RESET">
      <INPUT TYPE="SUBMIT" name="savescript" VALUE="Download">
    </td>
  </tr>
  <tr>
    <td align=center>
      <INPUT TYPE="BUTTON" VALUE="Close Window" onClick="self.close()">
    </td>
  </tr>
</table>
</body></html>
EOF

    return $content;
}

sub script_popup {
    my $self = shift;

    my $url = "http://" . $self->control . "/";
    my $js = <<EOF;
mywin = window.open("$url", "script", "width=400,height=600,toolbar=no,scrollbars=yes,resizable=yes");
EOF

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

=head1 Bugs, Missing Features, and other Oddities

=head2 Javascript

L<WWW::Mechanize> can't play back Javascript actions, and
L<HTTP::Recorder> doesn't record them.

=head2 Why are my images corrupted?

HTTP::Recorder only tries to rewrite responses that are of type
text/*, which it determines by reading the Content-Type header of the
HTTP::Response object.  However, if the received image gives the wrong
Content-Type header, it may be corrupted by the recorder.  While this
may not be pleasant to look at, it shouldn't have an effect on your
recording session.

=head1 See Also

See also L<LWP::UserAgent>, L<WWW::Mechanize>, L<HTTP::Proxy>.

=head1 Requests & Bugs

Please submit any feature requests, suggestions, bugs, or patches at
http://rt.cpan.org/, or email to bug-HTTP-Recorder@rt.cpan.org.

If you're submitting a bug of the type "X doesn't record correctly,"
be sure to include a (preferably short and simple) HTML page that
demonstrates the problem, and a clear explanation of a) what it does
that it shouldn't, and b) what it should do instead.

=head1 Mailing List

There's a mailing list for users and developers of HTTP::Recorder.
You can subscribe at
http://lists.fsck.com/mailman/listinfo/http-recorder, or by sending
email to http-recorder-request@lists.fsck.com with the subject
"subscribe".

The archives can be found at
http://lists.fsck.com/pipermail/http-recorder.

=head1 Author

Copyright 2003-2005 by Linda Julien <leira@cpan.org>

Released under the GNU Public License.

=cut

1;
