#!/opt/local/bin/perl -w
use strict;

# this is a script to quickly logon to a kpn-hotspot.
# after logging in, it waits until the user presses 'ctrl-c', to logout again.
#
# you should configure a username and password in '~/.hotspotrc'
#
our $debug=0;

#####################################
#   some included support nodules
package WebServer;
use strict;
use warnings;
use HTTP::Request::Common qw(POST GET);
use LWP::UserAgent;
use HTTP::Cookies;

use List::Util qw(first);

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

    my $ua= LWP::UserAgent->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();

    return bless {
        ua=>$ua,
        baseurl=>$baseurl,
    }, $class;
}
sub clearcookies {
    my $self= shift;

    $self->{ua}->cookie_jar(HTTP::Cookies->new(hide_cookie2=>1));
}
sub getcookie {
    my ($self, $domain, $name)=@_;
    my $value;
    $self->{ua}->cookie_jar->scan( sub {
        return if $_[1]!=$name;
        return if $_[4]!=$domain;
        $value= $_[2]; });
    return $value;
}
# 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($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 (Windows; U; Windows NT 5.1; en-US; rv:1.7) Gecko/20040501',
        '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',
    );
    printf("request:\n%s\n", $rq->as_string) if ($main::debug);
    #warn "network access disabled\n";
    #return;
    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    printf("response:") if ($main::debug);
    printf("%s\n", $rp->status_line) if ($main::debug || $rp->code >= 400);
    printf("%s\n", $rp->headers_as_string()) if ($main::debug);
    printf("%s\n", $rp->content) if ($main::debug>1);

    return undef if $rp->code >= 400;
    return $rp->content if (defined(wantarray));
}

# 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" } values %params;

    my $uri= URI->new($self->{baseurl});
    $uri->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 (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',
    );
    printf("request:\n%s\n", $rq->as_string) if ($main::debug);
    #warn "network access disabled\n";
    #return;
    my $rp= $self->{ua}->request($rq) or die "httperror: $@\n";

    printf("response:") if ($main::debug);
    printf("%s\n", $rp->status_line) if ($main::debug || $rp->code >= 400);
    printf("%s\n", $rp->headers_as_string()) if ($main::debug);
    printf("%s\n", $rp->content) if ($main::debug>1);

    return undef if $rp->code >= 400;
    return $rp->content if (defined(wantarray));
}

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";
    }
}


package HotSpot;

# http://www.nu.nl/
# http://redirector.hotspotsvankpn.com/index.php?sdx=1
#   Set-Cookie: CMSSESSID=0b9hj7gpkh37dpggte7rtclpk5; path=/
# https://portal.hotspotsvankpn.com/session.asp?CMSSESSID=0b9hj7gpkh37dpggte7rtclpk5
#   Set-Cookie: hotspotsessionid=0b9hj7gpkh37dpggte7rtclpk5; expires=Thu, 31-Dec-2009 23:00:00 GMT; path=/
#   Set-Cookie: ASPSESSIONIDCCBBCSSR=JDEDNIHDOIBMBKDNFDBFLOMK; path=/
# https://portal.hotspotsvankpn.com/templates/redirector.asp
#   Cookie: hotspotsessionid=0b9hj7gpkh37dpggte7rtclpk5; ASPSESSIONIDCCBBCSSR=JDEDNIHDOIBMBKDNFDBFLOMK
# https://portal.hotspotsvankpn.com/templates/dispatcher.asp?page_id=home_hs_out_nl
#   Cookie: hotspotsessionid=0b9hj7gpkh37dpggte7rtclpk5; ASPSESSIONIDCCBBCSSR=JDEDNIHDOIBMBKDNFDBFLOMK
#   Set-Cookie: ASP.NET_SessionId=5wv0p03rweylr545ffa5q33s; path=/
#   Set-Cookie: ASP.NET_SessionId=gfb3cm2bdizuvjfvhvuolz45; path=/
# POST https://portal.hotspotsvankpn.com/templates/dispatcher.asp?page_id=home_hs_out_nl
#   Cookie: hotspotsessionid=0b9hj7gpkh37dpggte7rtclpk5; ASPSESSIONIDCCBBCSSR=JDEDNIHDOIBMBKDNFDBFLOMK; ASP.NET_SessionId=gfb3cm2bdizuvjfvhvuolz45
#   page_id=1620&ws_action=&provider=4&name=XXXXX&pass=YYYYY&sms-nummer=&sms-code=&name_purchase=&pass_purchase=&kraskaart-nummer=&kraskaart-code=


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

    my $self= bless {
        redirector=> WebServer->new("http://redirector.hotspotsvankpn.com"),
        portal=> WebServer->new("https://portal.hotspotsvankpn.com"),
        %properties,
    }, $class;

    return $self;
}
sub load {
    my ($self)=@_;
    my $redir= $self->{redirector}->httpget("/index.php", sdx=>1) || die "error loading redirector\n";
    if ($redir=~/"0;url=htt.*?CMSSESSID=(.*?)"/) {
        $self->{cmssessid}= $1;
        printf("CMSSESSID=%s\n", $self->{cmssessid});
        $self->{portal}->httpget("/session.asp", CMSSESSID=>$self->{cmssessid}) || die "error loading portal\n";
    }
    else {
        printf("ERROR: no cmssessid\n");
    }
}
sub login {
    my ($self, $user, $pass)=@_;
    $self->{portal}->httppost("/templates/dispatcher.asp", {page_id=>'home_hs_out_nl'},
        page_id => 1620,
#       ws_action =>  '',
        provider => 4,
        name => $user,
        pass => $pass,
#       'sms-nummer' =>  '',
#       'sms-code' =>  '',
#       name_purchase =>  '',
#       pass_purchase =>  '',
#       'kraskaart-nummer' =>  '',
#       'kraskaart-code' =>  '',
    ) || die "error logging in\n";
}
sub logout {
    my ($self)=@_;
    $self->{portal}->httpget("/templates/logout2.asp", CMSSESSID=>$self->{cmssessid}) || die "error logging out\n";
}
package main;

use strict;
use warnings;
use IO::File;
use Getopt::Long;
$|=1;

my $config= readconfig("$ENV{HOME}/.hotspotrc");
my $m= HotSpot->new(map { ($_=>$config->{$_}) } grep { $_ ne "url" && $_ ne "user" && $_ ne "pass" } keys %$config);
$m->load();
$m->login($config->{user}, $config->{pass});
printf("logged in\n");

$SIG{INT}= sub { $m->logout(); printf("logged out\n"); exit(0); };

printf("\n");
while (1) { sleep(1000); }

sub readconfig {
    my $filename=shift;
    my %params;
    my $fh= IO::File->new($filename, "r") or die "$filename: $!";
    while (<$fh>) {
        if (/^(.+?)\s*=\s*(.*?)\s*$/) {
            my ($k, $v)= ($1, $2);
            $params{$k}= $v;
        }
    }
    $fh->close();
    return \%params;
}