#!/usr/bin/perl

# HTMaiL-view - single web page renderer based on WebKit
#
# Authors:
#   Thomas Liske <thomas@fiasko-nw.net>
#
# Copyright Holder:
#   2015 (C) Thomas Liske [http://fiasko-nw.net/~thomas/]
#
# License:
#   This program is free software; you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation; either version 2 of the License, or
#   (at your option) any later version.
#
#   This program is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with this package; if not, write to the Free Software
#   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
#

use Browser::Open qw(open_browser);
use Getopt::Std;
use Glib::Object::Introspection;
use URI;

use warnings;
use strict;

my $version = 0.3;


# settings
my %hp_allowed;
my $hp_allowall = 0;

my %webkit_settings = (
    q(enable-plugins) => 0,
    q(enable-fullscreen) => 0,
    q(enable-html5-local-storage) => 0,
    q(enable-html5-database) => 0,
    q(enable-dns-prefetching) => 0,
    q(enable-private-browsing) => 1,
    );


# gir initialization
Glib::Object::Introspection->setup(
    basename => 'Gtk',
    version => '3.0',
    package => 'Gtk3');

Glib::Object::Introspection->setup(
    basename => 'WebKit',
    version => '3.0',
    package => 'WebKit');


# initialize GTK and parse GTK standard command line options
Gtk3::init(\@ARGV);


# getopt stuff
$Getopt::Std::STANDARD_HELP_VERSION++;

sub HELP_MESSAGE {
    print <<USG;
Usage:

  htmail-view [-v] <url>

    -v		be more verbose

    --help      show this help
    --version   show version information

    The <url> requires to contain a scheme. Showing local HTML files
    requires to use the "file://" scheme.

USG
}

sub VERSION_MESSAGE {
    print <<LIC;

 htmail-view $version - single web page renderer based on WebKit

 Authors:
   Thomas Liske <thomas\@fiasko-nw.net>

 Copyright Holder:
   2015 (C) Thomas Liske [http://fiasko-nw.net/~thomas/]

Upstream:
  https://github.com/liske/htmail-view

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

LIC
#/
}

our $opt_v;
unless(getopts('v') && (scalar @ARGV) != 0) {
    HELP_MESSAGE;
    exit 1;
}


# prepare supplied URL
my $uri = URI->new(shift);
my $uri_hp = eval { $uri->host_port; };
$hp_allowed{$uri_hp}++ if($uri_hp);

unless($uri->has_recognized_scheme) {
    print STDERR "ERROR: missing or unsupported scheme in URI!\n";
    exit 1;
}


# GUI initialization
my $window = Gtk3::Window->new('toplevel');
$window->set_wmclass('htmail-view', 'HTMaiL-View');
$window->set_role('browser');
$window->set_title($uri->as_string." - HTMaiL-View");
$window->set_icon_name('text-html');
my $box = Gtk3::Overlay->new;
my $box2 = Gtk3::Overlay->new;

my $scrolls = Gtk3::ScrolledWindow->new;
my $view = WebKit::WebView->new;
$scrolls->add($view);

my $label = Gtk3::Label->new('');
$label->set_halign('GTK_ALIGN_CENTER');
$label->set_valign('GTK_ALIGN_END');

my $toolbar = Gtk3::Toolbar->new;
$toolbar->set_halign('GTK_ALIGN_CENTER');
$toolbar->set_valign('GTK_ALIGN_START');
$toolbar->set_icon_size('GTK_ICON_SIZE_SMALL_TOOLBAR');

my $btn_close = Gtk3::ToolButton->new;
$btn_close->set_label("Quit");
$btn_close->set_icon_name('gtk-quit');
$btn_close->set_tooltip_text('Close this view.');
$btn_close->signal_connect(clicked => sub { Gtk3::main_quit(); });

my $btn_network = Gtk3::ToggleToolButton->new;
$btn_network->set_label('Remote Content');
$btn_network->set_icon_name('gtk-network');
$btn_network->set_tooltip_text('Allow all external resources...');
$btn_network->set_active($hp_allowall);
$btn_network->signal_connect(toggled => sub {
    $hp_allowall = $btn_network->get_active || 0;
    $view->reload;
			     });

$toolbar->insert($btn_close, 0);
$toolbar->insert($btn_network, 1);

my $accel = Gtk3::AccelGroup->new;
$window->add_accel_group($accel);
$window->set_default_size(762, 724);

$box2->add($scrolls);
$box2->add_overlay($label);
$box->add($box2);
$box->add_overlay($toolbar);
$window->add($box);
$window->show_all;
$window->present;
$window->signal_connect(destroy => sub { Gtk3::main_quit(); });

$btn_close->add_accelerator("clicked", $accel, ord('Q'), 'GDK_META_MASK', 'GTK_ACCEL_VISIBLE');
$btn_network->get_child->add_accelerator("clicked", $accel, ord('R'), 'GDK_META_MASK', 'GTK_ACCEL_VISIBLE');


# WebKit privacy tuning
my $settings = $view->get_settings;
foreach my $option (sort keys %webkit_settings) {
    print STDERR "SETTING#WEBKIT $option ".$settings->get($option)." => $webkit_settings{$option}\n" if($opt_v);
    $settings->set($option, $webkit_settings{$option});
}

# check if a request should pass
sub check_request {
    my $req = shift;
    my $req_hp = eval { $req->host_port; };

    # requests of the original URI should always pass
    return 1 if($hp_allowall || $uri->eq($req));

    # allow whitelist
    return $hp_allowed{$req_hp} || 0 if($req_hp);

    # deny any any
    return 0;
}

# window title
$view->signal_connect('title-changed' => sub {
    my ($view, $frame, $text) = @_;

    $window->set_title("$text - HTMaiL-View");
});

# show destination while hovering a link
$view->signal_connect('hovering-over-link' => sub {
    my ($view, $title, $uri) = @_;

    $label->set_label($uri || '');
});

# intercept any resource requests
$view->signal_connect('resource-request-starting' => sub {
    my ($view, $frame, $resource, $request, $response) = @_;

    my $requri = URI->new($request->get_uri, $uri->scheme);
    if(check_request($requri)) {
	print STDERR "RES-REQ#PERMIT ".$request->get_uri."\n" if($opt_v);
	return;
    }

    print STDERR "RES-REQ#REJECT ".$request->get_uri."\n" if($opt_v);
    $request->set_uri('about:blank');
});

sub check_navpol {
    my $req = shift;

    # requests of the original URI should always pass
    return 1 if($uri->eq($req));

    # any else should launch the external browser
    return 0;
}

$view->signal_connect('navigation-policy-decision-requested' => sub {
    my ($view, $frame, $request, $action, $decision) = @_;

    my $requri = URI->new($request->get_uri, $uri->scheme);
    if(check_navpol($requri)) {
	print STDERR "NAV-POL#INTERN ".$request->get_uri."\n" if($opt_v);
	return 0;
    }

    if($action->get_reason eq 'link-clicked') {
	# launch external browser
	print STDERR "NAV-POL#EXTERN ".$request->get_uri."\n" if($opt_v);
	open_browser($request->get_uri);
    }
    else {
	# ignore request (user has not clicked)
	print STDERR "NAV-POL#IGNORE ".$request->get_uri.' ('.$action->get_reason.")\n" if($opt_v);
    }
    
    $decision->ignore;
    return 1;
});

# <a target="_blank"> stuff
$view->signal_connect('new-window-policy-decision-requested' => sub {
    my ($view, $frame, $request, $action, $decision) = @_;

    my $requri = URI->new($request->get_uri, $uri->scheme);
    if(check_navpol($requri)) {
	print STDERR "NEW-POL#INTIGN ".$request->get_uri."\n" if($opt_v);
	$decision->ignore;
	return 1;
    }

    if($action->get_reason eq 'link-clicked') {
	# launch external browser
	print STDERR "NEW-POL#EXTERN ".$request->get_uri."\n" if($opt_v);
	open_browser($request->get_uri);
    }
    else {
	# ignore request (user has not clicked)
	print STDERR "NEW-POL#IGNORE ".$request->get_uri."\n" if($opt_v);
    }

    $decision->ignore;
    return 1;
		      });

# load initial site
$view->load_uri($uri->as_string);

# main loop
Gtk3::main();
