#!/usr/bin/perl -T
#
# "Redirect" 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 3 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 program.  If not, see <http://www.gnu.org/licenses/>.
#
# $Id: redirect.cgi,v 1.26 2011/08/24 00:34:37 suter Exp suter $
#
# [MJS 30 May 2002] Re-implementation of "makeashorterlink.com"
# [MJS 27 Jul 2002] Added choices: SHA1, MD5 and random
# [MJS 14 Feb 2003] Registered zwit.org and adapted this to use it
# [MJS 10 Nov 2004] Added a *.zwit.org wildcard!
# [MJS 19 Apr 2006] Some tidying up, added link count
# [MJS 16 Aug 2010] Shifted from "same as perl" to GPLv3
# [MJS 16 Aug 2010] Added "+" preview feature, use Template.pm and cleanup code
# [MJS 23 Aug 2011] Start using Google's Safe Browsing Lookup API
# [MJS 23 Aug 2011] Subtle: tell people if the random hash already existed
# [MJS  7 Apr 2012] Upgrade links to Google's Safe Browsing pages

# Testing - all these should redirect correctly to the same website:
# for uri in b5.zwit.org www.b5.zwit.org zwit.org/b5 zwitterion.org/link/b5 ; do HEAD -PS $uri ; done

use strict;
use warnings;
use English qw( -no_match_vars );
use CGI::Simple;
use Template;
use URI::Heuristic qw( uf_uristr );
use Digest::SHA1 qw( sha1_base64 );
use Digest::MD5 qw( md5_base64 );
use GDBM_File;
use File::Slurp;
use WWW::Mechanize;

## Meta details
our $VERSION = '2.1';
our $NAME = 'zwit.org';

## Our database of redirects to perform
my $db = '/var/www/zwitterion.org/link/db/link';

## Initialize our template and variables
my $tt = Template->new( { INCLUDE_PATH => '/home/suter/web/zwitterion.org:/var/www/zwitterion.org', EVAL_PERL => 1 } );
my %detail = ( phase => 'Create', title => 'Link Redirect: ' );

## Initialize CGI object
my $q = new CGI::Simple;

eval {

    if ( defined $q->param('uri') ) {
        ## Create a new redirect for the given uri
        $detail{uri} = uf_uristr $q->param('uri') or die "getting uri to store\n";
        my $method = defined( $q->param('method') ) ? $q->param('method') : 'random';
        @detail{qw( hash how )} = create_hash( $method, $detail{uri} );
        $detail{phase} = 'Added';
        $detail{safebrowsing} = check_uri( $detail{uri} );
    }
    elsif ( $ENV{REQUEST_URI} =~ m{ /link/ (?:w+\.)? (.+?) (\+?) \Z }msix ) {
        ( $detail{hash}, my $preview ) = ( $1, $2 );

        ## Mode?
        $detail{phase} = $preview ? 'Preview' : 'Use';

        ## Lookup the hash
        tie my %db, 'GDBM_File', $db, &GDBM_READER, 0600 or die "opening database\n";
        defined( $db{ $detail{hash} } ) or die "finding stored link $detail{hash}\n";
        $detail{uri} = uf_uristr $db{ $detail{hash} } or die "retrieving stored link\n";
        untie %db or die "closing database\n";

        $detail{safebrowsing} = check_uri( $detail{uri} );

        ## Force Preview?
        if ( not $detail{safebrowsing} eq 'ok' ) {
            $detail{phase} = 'Preview';
        }
    }
    else {
        ## Return the form to create a redirect
        $detail{phase}      = 'Create';
        $detail{link_count} = link_count();
    }

    ## Safely done
    1;
    }
    or do {
    ## Store any error for the template
    $detail{error} = $EVAL_ERROR;
    $detail{phase} = 'Error';
    };

## Redirect or process the template
if ( $detail{phase} eq 'Use' ) {
    print $q->redirect( $detail{uri} );
}
else {
    print $q->header( -pragma => 'no-cache', -expires => '-1d' );
    $detail{title} .= $detail{phase};
    $tt->process( 'link/index.tt', \%detail ) or die "redirect template: ", $tt->error();
}

## FIXME: Return my Google Safe Browsing API key
## https://developers.google.com/safe-browsing/key_signup
sub api_key {
    my $key = read_file('/home/suter/.google-safebrowsing-api-key');
    chomp($key);
    return $key;
}

## Check a URI using Google Safe Browsing API
## https://developers.google.com/safe-browsing/lookup_guide
sub check_uri {
    my ($url) = @_;

    ## Make the request
    my $mech = WWW::Mechanize->new( autocheck => 0, timeout => 10 );
    $mech->agent( "$NAME/$VERSION " . $mech->agent );
    $mech->post( sprintf( 'https://sb-ssl.google.com/safebrowsing/api/lookup?client=%s&apikey=%s&appver=%s&pver=%s',
            $NAME, api_key(), $VERSION, '3.0' ),
        Content => sprintf( "1\n%s\n", $url ) );

    ## No content (204) means all the URI is okay
    if ( 204 == $mech->status() ) {
        return 'ok';
    }

    ## Results means there's an issue with the URI
    if ( 200 == $mech->status() ) {
        my $verdict = ( split m{\r\n}, $mech->content() )[-1];
        if ( $verdict =~ m{ \A ( phishing | malware | phishing,malware ) \Z }msix ) {
            return $verdict;
        }
    }

    ## Otherwise, it's my local error
    return 'local-internal-error';
}

## The count of links in the hash
sub link_count {
    my $count = 0;
    eval {
        ## GDBM_File seems to get my @_ with the local :(
        local @_;
        tie my %db, 'GDBM_File', $db, &GDBM_READER, 0600
            or die "opening database\n";
        $count += scalar keys %db;
        untie %db or die "closing database\n";

        ## Safely done
        1;
    } or return 'more than 42';
    return $count;
}

## The "string" to be used as the hash key
sub create_hash {
    my ( $method, $uri ) = @_;
    my $hash = q{};
    my $how = 'created';

    ## GDBM_File seems to get my @_ with the local :(
    local @_;
    tie my %db, 'GDBM_File', $db, &GDBM_WRCREAT, 0600
        or die "opening database\n";

    if ( $method eq 'sha1' ) {
        $hash = sha1_base64 "$uri" or die "generating sha1 link\n";
    }
    elsif ( $method eq 'md5' ) {
        $hash = md5_base64 "$uri" or die "generating md5 link\n";
    }
    elsif ( $method eq 'random' ) {

        ## Don't add same url twice
        my %reverse = reverse %db;
        if ( exists $reverse{$uri} ) {
            $hash = $reverse{$uri};
            $how = 'found';
        }
        else {

            ## Skip oft-confused characters
            my @ch     = ( '2' .. '9', 'a' .. 'h', 'j', 'k', 'm', 'n', 'p' .. 'z' );
            my $tries  = 1;
            my $length = 2;
            do {
                $hash = join q{}, @ch[ map rand @ch, 1 .. $length ];
                $tries++ % 3 and $length++;
                $length > 6  and die "generating random link\n";
            } until not exists( $db{$hash} );

        }
    }
    else {
        die "finding the unknown method\n";
    }

    $db{$hash} = "$uri" or die "storing link\n";
    untie %db or die "closing database\n";
    return $hash, $how;
}