#!/usr/bin/perl -T -w
#
# $Id: redirect.cgi,v 1.23 2007/07/19 13:51:19 suter Exp $
#
# Copyright (c) 2002,2003,2004,2006 Mark Suter <suter@humbug.org.au>  All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
#
# [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

use strict;
use CGI qw( -nosticky );
use CGI::Carp;
use IO::File;
use Digest::SHA1 qw( sha1_base64 );
use Digest::MD5 qw( md5_base64 );
use GDBM_File;
use URI::Heuristic qw(uf_uristr);

## Our short url (use $q->url() if you don't have one)
my $short = "zwit.org";

## Get a redirect request using the hard-coded uri of this script, "link".
my ($hash) =
    defined( $ENV{REQUEST_URI} )
    ? ( $ENV{REQUEST_URI} =~ m{ /? (?:link/)? (?:www.)? (.*) \Z }x )
    : "";

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

## Our template for the main page containing line /^FORM$/
my $template = "/var/www/zwitterion.org/link/index.html";

## A full page, with three variables
sub message {
    my ( $q, $title, $body ) = @_;

    print $q->header,
        $q->start_html(
            -title  => $title,
            -style  => { 'src' => '/style.css' },
            -author => 'suter@humbug.org.au'
        ),
        $q->h1($title),
        $q->p( { class => "alert" }, "$body" ),
        $q->end_html,
        "\n";
}

## 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";
    };
    if ($@) {
        return "around 42";
    }
    else {
        return $count;
    }
}

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

    ## 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};
        }
        else {

            ## Skip oft-confused characters
            my @ch
                = ( '2' .. '9', 'a' .. 'h', 'j', 'k', 'm', 'n', 'p' .. 'z' );
            my $length = 1;
            do {
                $hash = join "", @ch[ map rand @ch, 1 .. $length ];
                $length++ > 5 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;
}

my $q = new CGI;
if ( not $q->param() and $hash eq "" ) {
    ## The to-be-submitted form
    my $form = join "\n",
        $q->start_form(
        -method => "get",
        -action => $q->url(),
        -id     => "link"
        ),
        $q->p(
        "URI: ",
        $q->textfield(
            -name      => 'uri',
            -onfocus   => 'empty(this)',
            -value     => 'http://',
            -size      => 80,
            -maxlength => 2048
        ),
        $q->br(),
        "Hash: ",
        $q->radio_group(
            -name   => 'method',
            -values => [ 'random', 'sha1', 'md5' ]
        ),
        $q->br(),
        $q->submit()
        ),
        $q->endform();
    my $count = link_count();
    print $q->header,
        map { s/^FORM$/$form/; s/LINK_COUNT/$count/; $_ }
        IO::File->new($template)->getlines;
}
else {

    if ( defined( $q->param('uri') ) ) {
        ## Create a new redirect for the given uri
        eval {
            my $uri = uf_uristr $q->param('uri')
                or die "getting uri to store\n";
            my $method =
                defined( $q->param('method') )
                ? $q->param('method')
                : 'random';
            $hash = create_hash( $method, $uri );
            message( $q, "$hash added", "<strong><a href=\"http://$hash.$short/\">$hash.$short</a><strong> redirects to $uri ." );
        };
        $@ and message( $q, "Error in $@", "Notify the webmaster an error occured in $@" );
    }
    else {
        ## Perform an existing redirect
        my $uri = "";
        eval {
            tie my %db, 'GDBM_File', $db, &GDBM_READER, 0600
                or die "opening database\n";
            defined( $db{$hash} ) or die "finding stored link $hash\n";
            $uri = uf_uristr $db{$hash} or die "retrieving stored link\n";
            untie %db or die "closing database\n";
            print $q->redirect($uri);
        };
        $@ and message( $q, "Error in $@", "Notify the webmaster an error occured in $@" );

    }
}