package WebServer;
# scripts using 'WebServer' class
#
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/WebObjects.pm
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/breedster.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/orkut/Orkut.pm
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/orkut/WebServer.pm
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wetenschapsbot.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wetenschapskwis.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wiki-image-upload.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wiki-rehash-import.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wiki-update-currentevent.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/sites/wthpgm2xml.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/stemmen/opquery.pl
# /Users/itsme-plain/cvsprj/itsme_homepage/projects/stemmen/wiki-image-upload.pl
# /Users/itsme-plain/projects/funda/Funda.pm
# /Users/itsme-plain/projects/funda/WebServer.pm
# /Users/itsme-plain/projects/stemcomputers/intern-site/wiki-image-upload.pl
# /Users/itsme-plain/projects/stemcomputers/pdfs-070130/wiki-image-upload.pl
# /Users/itsme-plain/projects/wth/wiki-backup.pl
# /Users/itsme-plain/projects/wth/wiki-image-upload.pl
# /Users/itsme-plain/projects/wth/wiki-rehash-import.pl
# /Users/itsme-plain/projects/wth/wiki-update-currentevent.pl
# /Users/itsme-plain/projects/wth/wthpgm2xml.pl
# /Users/itsme/private/thuis/girotel/Girotel.pm
# /Users/itsme/private/thuis/girotel/testgt.pl

use strict;
use warnings;
use HTTP::Request::Common qw(POST GET);
use LWP::UserAgent;
use HTTP::Cookies;

use List::Util qw(first);

{
    package MyLWP;
    our @ISA= qw(LWP::UserAgent);

    my %opts= @LWP::Protocol::http::EXTRA_SOCK_OPTS;
    $opts{SendTE} = 0;
    @LWP::Protocol::http::EXTRA_SOCK_OPTS= %opts;

    sub get_basic_credentials { return @{$_[0]{userpass}} }
}
sub new {
    my ($class, $baseurl)= @_;

    my $ua= MyLWP->new(agent=>'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.7) Gecko/20040501');
    $ua->cookie_jar(HTTP::Cookies->new(hide_cookie2=>1));
    $ua->env_proxy();

    my $self= bless {
        ua=>$ua,
    }, $class;

    if ($baseurl=~ m{^(http\w*)://(.*?)(/\S+)?$}) {
        my ($proto, $hostname, $path)= ($1,$2,$3);
        $self->{baseurl}= sprintf("%s://%s", $proto, $hostname);
        $self->{hostname}= $hostname;
        $path = "" if !defined $path;
        $path =~ s{/$}{};  # remove trailing slash
        $self->{basepath}= $path;
    }
    else {
        $self->{baseurl}= $baseurl;
        $self->{hostname}= "";
        $self->{basepath}= "";
    }
    return $self;
}
sub clearcookies {
    my $self= shift;

    $self->{ua}->cookie_jar(HTTP::Cookies->new(hide_cookie2=>1));
}
sub getcookie {
    my ($self, $server, $path, $name)= @_;
    return $self->{ua}{cookie_jar}{COOKIES}{$server}{$path}{$name}[1];
}
# almost interface compatible with httpost
#   - optional hashref with parameters is merged with parameters.
#
# httpget("/some.cgi", key1=>123, key2=>455);
# httpget("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#
sub httpget {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $uri= URI->new($self->{baseurl});
    $uri->path($self->{basepath}.(($self->{basepath} && $path && $path ne "/")?'/':'').$path);
    $uri->query_form($query?%$query:(), %params);
    my $rq= GET $uri;

    # todo: get rid of 'TE' header, and 'Connection'-TE flag. and 'Cookie2' header
    $rq->header(
        'User-Agent'=> 'Mozilla/5.0',
        'Accpet'=>'*/*',
#        'Accept'=> ($path =~ /\.aspx|\.htm/ ? 'text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5' : $path =~ /\.css/ ? 'text/css,*/*;q=0.1' : '*/*') ,
#        'Accept-Language'=> 'en-us,en;q=0.5',
        #'Accept-Encoding'=> 'gzip,deflate',
#        'Accept-Charset'=> 'ISO-8859-1,utf-8;q=0.7,*;q=0.7',
    );
    if ($self->{D}) {
        print "request:\n", $rq->as_string, "\n";
    }
    #warn "network access disabled\n";
    #return;
    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    if ($self->{D}) {
        print $rp->status_line, "\n";
        print $rp->headers->as_string();
        print "\n";
        print $rp->content;
    }

    #return join("",$rp->content);
    return $rp;
}

# can be called in several ways:
# httppost("/some.cgi", key1=>123, key2=>455);
#   -> just form values
# httppost("/some.cgi", { urlkey1=>999 }, key1=>123, key2=>455);
#   -> both url and form params
# httppost("/some.cgi", key1=>123, key2=>455, file1=>["filename"]);
#   -> form-data file upload
sub httppost {
    my $self= shift;
    my $path= shift;

    my $query;
    if (@_) {
        $query= shift;
        if (ref $query ne "HASH") {
            unshift @_, $query;
            $query=undef;
        }
    }
    my %params= @_;

    my $useformdata= grep { defined ref $_ && ref $_ eq "ARRAY" && $#$_==1 && -f $_->[0]} values %params;

    my $uri= URI->new($self->{baseurl});
    $uri->path($self->{basepath}.($path?'/':'').$path);
    $uri->query_form(%$query) if ($query);
    my $rq;
    if ( $useformdata ) {
        $rq = POST $uri, Content_Type=>"form-data", Content=>[ %params ];
    }
    else {
        $rq = POST $uri, [ %params ];
    }

    # -- for http uploads : 
    # ( Content_Type=>"form-data", Content=>[ %params ]);
    $rq->header(
        'User-Agent'=> 'Mozilla/5.0',
        'Accpet'=>'*/*',
#        'User-Agent'=> 'Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US; rv:1.7) Gecko/20040501',
#        'Accept'=> 'text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5',
#        'Accept-Language'=> 'en-us,en;q=0.5',
        #'Accept-Encoding'=> 'gzip,deflate',
#        'Accept-Charset'=> 'ISO-8859-1,utf-8;q=0.7,*;q=0.7',
    );
    if ($self->{D}) {
        print "request:\n", $rq->as_string, "\n";
    }
    #warn "network access disabled\n";
    #return;
    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    if ($self->{D}) {
        print $rp->status_line, "\n";
        print $rp->headers->as_string();
        print "\n";
        print $rp->content;
    }

    #return join("",$rp->content);
    return $rp;
}

sub httprequest {
    my ($self, $method, @params)= @_;
    if (lc($method) eq "get") {
        return $self->httpget(@params);
    }
    elsif (lc($method) eq "post") {
        return $self->httppost(@params);
    }
    else {
        die "invalid http request method '$method'\n";
    }
}
sub credentials {
    my ($self, $user, $pass)= @_;
    $self->{ua}{userpass}=[$user, $pass];
}
1;