#!/usr/bin/perl
use 5.010;
use strict;
use warnings;
package SGO;

require Exporter;
use CGI;
use HTML::Entities qw(encode_entities);
use DBI;
use HTTP::Date;
use Carp;
use Encode::Guess;
use Encode;
use CGI::Session;
use CGI::Cookie;
use List::Util qw(min);
use File::Path qw/make_path/;
use Cache::SizeAwareFileCache;
use Cache::Memcached;

use constant CACHE_TIMEOUT => 3600;


=head1 NAME

SGO - Sudoku Garden Online

=head1 SYNOPSIS

	use SGO qw(get_dbh guess_language);
	my $dbh = get_dbh();
	my $lang = guess_language();
	# work with $dhb here...
	
=head1 DESCRIPTION

Commonly used functions in the Sudoku Garden Online scripts

=head1 FUNCTIONS

=cut

our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
        cache
        expire_cache
        ll_cache
        get_dbh 
        get_session
        get_cookie
        link_sudoku
        populate_template
        time_pretty_print 
        url_encode
        guess_language
        date_pretty_print
        cache_date
        my_decode
        send_back
        get_token_for_user
        discontinuities
        );

our %EXPORT_TAGS = (":all" => \@EXPORT_OK);

$CGI::DISABLE_UPLOADS = 1;
$CGI::POST_MAX        = 64 * 1024;

=pod

=head2	get_dbh

reads the password for the mysql database from the file "password", 
opens a DBI handle for the db "moritz2" and returns that.

=cut

my @pwfiles = qw(
    /var/www/sudokugarden.de/online/password
    /home/moritz/www/sg/online/password
);

sub get_dbh {

    state $dbh;
    return $dbh if $dbh;
	my $db_dsn = "DBI:mysql:database=moritz2;host=localhost";

    my ($pwfile) = grep -r, @pwfiles;
    die "None of the password files is readable!" unless $pwfile;
	open (my $PWD, '<', $pwfile) or
		die "Can't read password file: $!";
	my $passwd = <$PWD>;
	chomp $passwd;
	close $PWD;

	$dbh = DBI->connect($db_dsn, "moritz", $passwd,
			{RaiseError=>1, AutoCommit => 1});
	return $dbh;
}

=head2 get_session 

Returns a CGI::Session object.

Expects a  L<CGI> object and a boolean as arguments.
If the boolean is true, a new session will be created if none exists;
otherwise C<undef> is returned if no session is known.

=cut

sub get_session {
    my ($cgi, $autovivify) = @_;
    $cgi //= CGI->new;
    my $dir = '/tmp/sudokugarden/' . lc( (split /[.:]+/, $cgi->remote_addr)[0] );

    unless (-d $dir) {
        make_path $dir;
    }

    my $file = "$dir/sessions.sqlite3";

    unless (-e $file) {
        my $dbh = DBI->connect("dbi:SQLite:dbname=$file", undef, undef, { RaiseError => 1, AutoCommit => 1});
        $dbh->do(<<SQL);
            CREATE TABLE sessions (
                id CHAR(32) NOT NULL PRIMARY KEY,
                a_session TEXT NOT NULL
            );
SQL
        $dbh->disconnect;
    }

    my $method = $autovivify ? 'new' : 'load';
    my $session = CGI::Session->$method(
        'driver:sqlite',
        $cgi,
        {
            DataSource => $file,
        },
    );
    return undef unless $session;
    if ($session->param('_logged_in')){
        $session->expire('+3M');
    } else {
        $session->expire('+1d');
    }

    return $session;
}

=head2 get_cookie 

Expects a L<CGI::Session> object and returns a CGI::Cookie object.

=cut

sub get_cookie {
    my ($session) = @_;
    return undef unless $session;
    return CGI::Cookie->new(
            -name       => $session->name,
            -value      => $session->id,
            -expires    => '+1y',
        );

}

=head2 populate_template

Expects a HTML::Template object and a CGI::Session object, and adds
information about possibly logged in users to the template.

Doesn't have a meaningful return value.

=cut

sub populate_template {
    my ($template, $session) = @_;
    $session //= get_session();
    if ($session && $session->param('_logged_in')){
        $template->param(AUTH   => 1);
        $template->param(L_USER => decode('utf8', $session->param('user')));
    }
}

=head2 time_pretty_print

Expects an integer argument in seconds, and returns a formatted string
in Minutes, for example time_pretty_print(65) is "1:05"

=cut

sub time_pretty_print($) {
	my $time = shift;
	return sprintf("%d:%02d", int($time/60), $time % 60);
}

=pod

=head2 url_encode($)

Encodes an arbitrary string as a URL, for example "/foo bar" -> "/foo%20bar"

=cut
	

sub url_encode($) {
	my $url = shift;
	# stolen from http://support.internetconnection.net/CODE_LIBRARY/Perl_URL_Encode_and_Decode.shtml
	# seems to make sense ;-)
	$url =~ s/([^A-Za-z0-9])/sprintf("%%%02X", ord($1))/seg;
	return $url;
}

=pod

=head2 guess_language()

analyses the REQUERST_URI and HTTP_ACCEPT_LANGUAGE environment variables to see if English or German is preffered

=cut

sub guess_language {
	if ($ENV{REQUEST_URI} && $ENV{REQUEST_URI} =~ m#^/(de|en)/#){
		return $1;
	}
	my $l = $ENV{HTTP_ACCEPT_LANGUAGE};
	$l = "" unless ($l);
	my @lang = split /[;,]/, $l;
	foreach (@lang){
		if (m/(de|en)/){
			return $1;
		}
	}
	return "en";
}

sub my_decode($) {
	my $str = shift;
	my $enc = guess_encoding($str, qw/latin1 utf-8/);
	if (ref($enc)){
		return decode($enc, $str);
	} else {
        # falling back to utf8
        return decode('utf-8', $str);
	}
}

sub date_pretty_print($) {
	my $date = shift;
	confess("No date given") unless ($date);
	my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
		localtime($date);
	return sprintf("%04d-%02d-%02d %02d:%02d", $year + 1900, $mon + 1,
			$mday, $hour, $min);
}

sub cache_date {
	my $cache_date = $ENV{HTTP_IF_MODIFIED_SINCE} or return;

	# Strip off length part, if sent
	$cache_date =~ s/;.*$//;

	return unless $cache_date;

	my $prev_cache_date = $cache_date;

	unless ( $cache_date = HTTP::Date::str2time( $cache_date ) ) {
		warn("Failed to decode: '$prev_cache_date' from browser: $ENV{HTTP_USER_AGENT}\n");
		return;
	}
	return $cache_date;
}

=head2 send_back

Prints a redirection header to the previous URL, if it is from sudokugarden.de,
otherwise redirect to C</$lang/online/today>

=cut

sub send_back {
    my $cgi = shift || new CGI;
    if ($cgi->referer && $cgi->referer =~ m/sudokugarden\.de/){
        print $cgi->redirect($cgi->referer);
    } else {
        my $lang = guess_language();
        print $cgi->redirect($cgi->url(-base => 1) . "/$lang/online/today");
    }
}

sub get_token_for_user {
    my ($user) = @_;
    my $get_token = get_dbh()->prepare_cached(qq/
            SELECT token FROM sg_register_token WHERE nick = ?
            /);
    $get_token->execute($user);
    $get_token->bind_columns(\my $db_token);
    $get_token->fetch();
    $get_token->finish;
    return $db_token;
}


=head2 discontinuities

expects a cheatlog entry, and returns the number that is a measure for the 
way that the user entered the numbers. 0 means all fields have been filled
in in order (very unlikely if you solve it manually), higher numbers mean
more discord.

=cut

sub discontinuities {
    my $cheatlog = shift;
    return undef unless $cheatlog;
    my @log = split m/\|/, $cheatlog;
	if (scalar @log < 81 - 17){
        return undef;
	}
	my @seq1 = map {my @a = split /:/, $_; $a[2] * 9 + $a[3] } @log;
	my @seq2 = map {my @a = split /:/, $_; $a[3] * 9 + $a[2] } @log;
	return min(_arry_discontinuities(@seq1), _arry_discontinuities(@seq2));
}

sub _arry_discontinuities {
	my $last = shift;
	my $res = 0;
	foreach (@_){
		if ($_ < $last) {
			$res++;
		}
		$last = $_;
	}
	return $res;
}

sub expire_cache {
    ll_cache()->delete($_) for @_;
}

sub ll_cache {
    state $cache = Cache::Memcached->new(
        servers => [ '127.0.0.1:11212' ],
    );
}

sub cache {
    my ($key, $callback, @args) = @_;
    my $cache = ll_cache();
    my $res = $cache->get($key);
    return $res if defined $res;
    $res = $callback->(@args);
    $cache->set($key, $res, CACHE_TIMEOUT) if defined $res;
    return $res;
}

sub link_sudoku {
	my $date = shift;
	if ($date =~ m#\d{4}-\d\d-\d\d#){
        state $lang = guess_language();
		return qq{<a href="/$lang/online/$date">$date</a>};
	} else {
		return $date;
	}
}

# vim: sw=4 ts=4 expandtab
1;