CPAN::Groonga

package App::htrepl;

use strict;
use warnings;

use LWP::UserAgent;
use HTTP::Headers;
use HTTP::Cookies;
use URI;
use Term::ReadLine;

use Data::Dumper;

our $VERSION = '0.001_01';

sub new { 
    my ( $class, %args ) = @_;

    $args{$_} ||= '' for 'host', 'proto', 'port';

    return bless \%args, $class;
}

sub run { 
    my $self = shift;

    $self->{term}  = Term::ReadLine->new( 'htrepl' );
    $self->{outfh} = $self->{term}->OUT || \*STDOUT;
    $self->{infh}  = $self->{term}->IN  || \*STDIN;

    $self->{user_agent} = 'perl-htrepl/' . $VERSION;
    $self->{headers}    = HTTP::Headers->new;
    $self->{cookies}    = HTTP::Cookies->new;

    $self->{show_headers} = 1;
    $self->{show_body}    = 1;

    while( defined ( my $line = $self->{term}->readline( 'htrepl> ' ) ) ) { 
        $self->{term}->addhistory( $line ) if $line =~ /\S/;

        my $res = eval { 
            $self->_eval( $line );
        };

        if ( my $err = $@ ) { 
            print { $self->{outfh} } "ERROR: $err", "\n\n";
            next;
        }

        next unless defined $res;    # commands will print their output directly

        print { $self->{outfh} } $res, "\n\n";

    }
}


sub _eval { 
    my ( $self, $line ) = @_;

    if ( $line =~ /^\./ ) { 
        # commands start with .
        return $self->_process_cmd( $line );
    }

    # otherwise do some http!
    my ( $meth, $uri_str ) = $line =~ m{^\s*(\w+)\s+(.+)$};
    return '' unless $meth;

    my $filename;
    if ( $uri_str =~ /</ ) { 
        ( $uri_str, $filename ) = $uri_str =~ m{^([\S]+)\s*<\s*(.+)$};
    }

    $meth = uc $meth;
    
    my $uri = URI->new( $uri_str );

    if ( my $scheme = $uri->scheme ) { 
        $self->_set_proto( $scheme );
    }

    if ( $uri->can( 'host' ) ) { 
        $self->_set_host( $uri->host );
    }

    if ( $uri->can( 'port' ) ) { 
        $self->_set_port( $uri->port );
    }

    my $path = ( $uri->path_query || '' );
   
    # everything we need?
    $self->_check_reqs;

    return $self->_do_http( $meth, $path, $filename );
}

sub _do_http { 
    my ( $self, $meth, $path, $filename ) = @_;

    my $uri = sprintf '%s://%s:%s/%s', @{ $self }{'proto', 'host', 'port'}, $path;

    my $msg_body = '';
    if ( $meth =~ /^POST|PUT$/ ) { 
        if ( $filename ) { 
            $msg_body = $self->_read_body_file( $filename );
        } else { 
            $msg_body = $self->_read_body( $meth );
        }
    }

    print { $self->{outfh} } "\n\n$meth $uri\n\n";
    my $req = HTTP::Request->new( $meth, $uri, $self->{headers} );
    $req->content( $msg_body );

    my $ua = LWP::UserAgent->new;

    $ua->agent( $self->{user_agent} );
    $ua->cookie_jar( $self->{cookies} );

    my $res = $ua->simple_request( $req );

    my $ret = $res->status_line . "\n";

    if ( $self->{show_headers} ) { 
        $ret .= $res->headers->as_string;
    }

    if ( $self->{show_body} ) { 
        $ret .= $res->content;
    }

    return $ret;
}

sub _read_body {
    my ( $self, $meth ) = @_;

    print { $self->{outfh} } "Enter $meth body data. Terminate with CTRL-d\n\n";
    my $ret = '';

    while ( 1 ) { 
        my $line = $self->{term}->readline( "$meth> " ); 
        last unless defined $line;
        $ret .= $line;
    }

    return $ret;
}

sub _read_body_file { 
    my ( $self, $filename ) = @_;

    open my $fh, $filename or die "$filename: $!\n";

    local $/;

    my $body = <$fh>;

    return $body;
}

sub _set_proto { 
    my ( $self, $scheme ) = @_;

    unless( $scheme =~ /^https?/ ) { 
        die "Don't know what to do with URI protocol [$scheme]. Try http or https.\n";
    }

    if ( $scheme ne $self->{proto} ) { 
        print { $self->{outfh} } "Setting protocol $scheme\n";
        $self->{proto} = $scheme;
    }
}

sub _set_host { 
    my ( $self, $host ) = @_;

    if ( $host ne $self->{host} ) { 
        print { $self->{outfh} } "Setting host $host\n";
        $self->{host} = $host;
    }
}

sub _set_port { 
    my ( $self, $port ) = @_;

    if ( $port ne $self->{port} ) { 
        print { $self->{outfh} } "Setting port $port\n";
        $self->{port} = $port;
    }
}

sub _check_reqs { 
    my $self = shift;

    unless( $self->{proto} ) { 
        $self->_set_proto( 'http' );
    }

    unless( $self->{port} ) { 
        $self->_set_port( 80 );
    }

    unless( $self->{host} ) { 
        die "No hostname specified.\n";
    }
}
    

sub _process_cmd { 
    my ( $self, $line ) = @_;

    my %cmds = 
      ( q       => \&_cmd_quit,
        quit    => \&_cmd_quit,
        set     => \&_cmd_set,
        cookie  => \&_cmd_cookie,
        header  => \&_cmd_header,
        help    => \&_cmd_help,
        hide    => \&_cmd_show_hide,
        show    => \&_cmd_show_hide,
        look    => \&_cmd_look,
      );

    my ( $cmd, $arg ) = $line =~ m{^\.(\w+)(?:\s+)?(.+)?$};

    unless( exists $cmds{lc $cmd} ) { 
        die "Unknown command [$cmd]. Try .help\n";
    }

    my @args;
    if ( $cmd =~ /^show|hide$/ ) { 
        push @args, lc $cmd;
    }

    my $meth = $cmds{$cmd};
    $self->$meth( $arg, @args );
}

sub _cmd_quit { 
    exit;
}

sub _cmd_look { 
    my ( $self, $arg ) = @_;

    if ( $arg =~ /^head/i ) { 
        my ( $hdr ) = $arg =~ /head\w*\s+(.+)$/;

        if ( my $val = $self->{headers}->header( $hdr ) ) { 
            print { $self->{outfh} } "$hdr: $val\n";
        } else { 
            print { $self->{outfh} } "No such header $hdr\n";
        }

    } elsif ( $arg =~ /cook/i ) { 
        my ( $ck ) = $arg =~ /cook\w*\s+(.+)$/;

        if ( my $val = $self->_lookup_cookie( $ck ) ) { 
            print { $self->{outfh} } "$ck: $val\n";
        } else { 
            print { $self->{outfh} } "No such cookie $ck\n";
        }
    } else { 
        die "Don't know what to do with [.look $arg]. Try .help\n";
    }

    return '';
}

sub _cmd_show_hide { 
    my ( $self, $arg, $cmd ) = @_;

    my $field;
    if ( $arg =~ /head/i ) { 
        $field = 'headers';
    } elsif ( $arg =~ /bod/i ) { 
        $field = 'body';
    } else { 
        die "Don't know how to $cmd [$arg]. Try .help\n";
    }

    my $key = 'show_' . $field;
    $self->{$key} = $cmd eq 'show' ? 1 : 0;

    print { $self->{outfh} } ( $cmd eq 'show' ? 'Showing ' : 'Hiding ' ), $field;
    return '';
}

sub _cmd_set { 
    my ( $self, $arg ) = @_;

    if ( $arg =~ /^host/i ) { 
        my ( $val ) = $arg =~ /host\s+(.+)$/;

        if ( defined $val ) { 
            $self->_set_host( $val );
        } else { 
            print { $self->{outfh} } "Unsetting host\n";
            $self->{host} = '';
        }

    } elsif ( $arg =~ /^port/i ) { 
        my ( $val ) = $arg =~ /port\s+(\d+)$/;

        if ( defined $val ) { 
            $self->_set_port( $val );
        } else { 
            print { $self->{outfh} } "Unsetting port\n";
            $self->{port} = '';
        }

    } elsif ( $arg =~ /^ua/i ) { 
        my ( $val ) = $arg =~ /ua\s+(.+)$/;
        unless( $val ) { 
            die "Can't set User-Agent [$val]\n";
        }

        print { $self->{outfh} } "Setting User-Agent $val\n";
        $self->{user_agent} = $val;
    } else { 
        die "Don't know what to do with [.set $arg]. Try .help\n";
    }

    return '';
}

sub _cmd_cookie { 
    my ( $self, $arg ) = @_;

    die "Can't set cookie without a hostname. Set a host or make a request first.\n"
      unless $self->{host};

    my ( $cookie ) = $arg =~ m{^([\w\d-]+)};
    my ( $val )    = $arg =~ m{^\Q$cookie\E\s+(.+)$};

    unless ( $cookie ) { 
        die "Can't understand cookie name $cookie\n";
    }

    if ( defined $val ) { 
        print { $self->{outfh} } "Setting cookie $cookie => $val\n";
        
        # I think we need to do something special to support SSL?
        $self->{cookies}->set_cookie( 1, $cookie, $val, '/', $self->{host}, $self->{port}, 0, 0, 86400 );
        return '';
    }

    # no value == delete
    print { $self->{outfh} } "Deleting cookie $cookie";
    $self->{cookies}->clear( $self->{host}, '/', $cookie );
    return '';
}

sub _cmd_header { 
    my ( $self, $arg ) = @_;

    my ( $header ) = $arg =~ m{^([\w\d-]+)};
    my ( $val )    = $arg =~ m{^\Q$header\E\s+(.+)$};

    unless( $header ) { 
        die "Can't understand header name $header\n";
    }

    if ( defined $val ) { 
        print { $self->{outfh} } "Setting header $header => $val\n";
        $self->{headers}->header( $header => $val );
        return '';
    } 

    # no value == delete
    print { $self->{outfh} } "Deleting header $header\n";
    $self->{headers}->remove_header( $header );
    return '';
}

sub _cmd_help { 
    my $self = shift;

    print { $self->{outfh} } <<'END';

htrepl commands:

.header Content-Type application/json    # set header
.header Content-Type                     # remove header

.cookie ID 12345                         # set a cookie
.cookie ID                               # remove a cookie

.set host 127.0.0.1                      # set the current host
.set port 80                             # set the current port
.set ua MyBrowser/1.2.3                  # set user agent

.show headers                            # display response headers
.show body                               # display response body

.hide headers                            # hide response headers
.hide body                               # hide response body

.look header Content-Type                # show current request header
.look cookie ID                          # show current cookie value

.quit (or .q)                            # quit

END

      return '';
}

sub _lookup_cookie { 
    my ( $self, $name ) = @_;

    # Sigh. HTTP::Cookies has no good interface for looking up
    # cookies by name. :(

    my $jar = $self->{cookies};

    my $ret = '';

    $jar->scan( sub { 
        my ( $v, $cname, $val, $p, $domain, $port ) = @_;

        if ( ( $self->{host} =~ /\Q$domain/ ) and ( $name eq $cname ) ) { 
            $ret = $val;
        }
    } );

    return $ret;
}

__PACKAGE__->run unless caller;

1;


__END__


=head1 NAME

App::htrepl - A commandline REPL for HTTP applications

=head1 VERSION

0.001_01 - Development release

=head1 SYNOPSIS

    [friedo@box ~]$ htrepl

    htrepl> head http://www.google.com
    Setting protocol http
    Setting host www.google.com
    Setting port 80
    
    
    HEAD http://www.google.com:80/
    
    200 OK
    Cache-Control: private, max-age=0
    Connection: close
    Date: Mon, 28 Feb 2011 05:23:23 GMT
    Server: gws
    Content-Type: text/html; charset=ISO-8859-1
    Expires: -1
    Client-Date: Mon, 28 Feb 2011 05:23:23 GMT
    Client-Peer: 72.14.204.103:80
    Client-Response-Num: 1
    Set-Cookie: PREF=ID=1a1bda55cfcf6aa9:FF=0:TM=1298870603:LM=1298870603:S=t8tAuy45KBiOTiuw; expires=Wed, 27-Feb-2013 05:23:23 GMT; path=/; domain=.google.com
    Set-Cookie: NID=44=foHo3p-6-ZXByOkR4TkQOA9EveVk49TQ1jhVthq8HK14LTFN4Vhh92nckgxjBqUfDD3yvzv0vny0q49RnxzpzXdIpNBpXb8Npy9msDN8u8ZtIA01Kub7DGV0s0oWrJw8; expires=Tue, 30-Aug-2011 05:23:23 GMT; path=/; domain=.google.com; HttpOnly
    X-XSS-Protection: 1; mode=block

=head1 DESCRIPTION

App::htrepl provides a commandline tool, C<htrepl>, which implements a REPL (read-eval-print loop) for talking to HTTP
applications. C<htrepl> provides commands for making HTTP requests, manipulating headers and cookies, and other
functions in an interactive environment. It will even preserve command history, if you have a proper C<readline> 
installed.

=head1 REPOSITORY

L<https://github.com/friedo/app-htrepl>

=head1 AUTHOR

Mike Friedman <friedo at friedo dot com>

=head1 COPYRIGHT & LICENSE 

Copyright (C) 2011 by Mike Friedman

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.4 or,
at your option, any later version of Perl 5 you may have available.

=cut