server/gen_site.pl

#!/usr/bin/env perl

use v5.10.1;
use strict;
use warnings;
use threads;
use threads::shared;

use Cwd 'abs_path';
use File::Basename;
use File::Copy;
use File::Find;
use File::Path qw/make_path remove_tree/;
use File::Temp "tempdir";
use Getopt::Long;
use IO::Socket;
use Thread::Queue;

our $outdir = "outest";
our $outteams = "/teams/";
our $outerrors = "/errors/";
our $outhome = "/htdocs/";
our $tmpdir = tempdir();

our $baseurl = "http://localhost";
our $baseadmin = "/admin/";
our $basehome = "/";
our $baseerrors = "/errors/";
our $baseteams = "/connected/";
our $threads = 6;

sub genErrors(;$)
{
    my $m = shift // Mirror->new();

    $m->add_url($baseerrors . "400");
    $m->add_url($baseerrors . "403");
    $m->add_url($baseerrors . "404");
    $m->add_url($baseerrors . "413");
    $m->add_url($baseerrors . "500");
    $m->add_url($baseerrors . "502");

    return $m;
}

sub genHome(;$)
{
    my $m = shift // Mirror->new();
    $m->add_url($basehome . "index.html");
    $m->add_url($basehome);

    genErrors($m);

    return $m;
}

sub genFull(;$)
{
    my $m = shift // Mirror->new();
    $m->add_url($baseteams);

    return $m;
}

sub genTeam($;$)
{
    my $team_id = shift;
    my $m = shift // Mirror->new();

    $m->add_url($baseteams . $team_id);

    return $m;
}

sub genTeamTheme($$;$)
{
    my $team_id = shift;
    my $theme_id = shift;
    my $m = shift // Mirror->new();

    $m->add_url($baseteams . $team_id . "/" . $theme_id);

    return $m;
}


my $queue :shared = Thread::Queue->new();
my $main_thread;

sub manage
{
    my $m = shift // Mirror->new();

    while (1)
    {
	if ($queue->pending() <= 0)
	{
	    lock($queue);
	    cond_wait($queue) while $queue->pending() <= 0;
	}

	my $cmd;
	{
	    lock($queue);
	    $cmd = $queue->peek();
	}

	$m->{end} = 0 if ($m->{end});

	for ($cmd)
	{
	    if (/^all$/)
	    {
		say "Generate all teams";
		genFull($m);
	    }
	    elsif (/^HOME/)
	    {
		say "Generate full public part";
		genHome($m);
	    }
	    elsif (/^ERRORS?/)
	    {
		say "Generate errors pages";
		genErrors($m);
	    }
	    elsif (/^TEAM([0-9]+)$/)
	    {
		say "Generate team: $1";
		genTeam($1, $m);
	    }
	    elsif (/^TEAM([0-9]+),([0-9]+)$/)
	    {
		say "Generate team theme: $1/$2";
		genTeamTheme($1, $2, $m);
	    }
	    elsif (/^(reset)*r(e(s(e(t)?)?)?)?/)
	    {
		say "Performing RESET ...";
		remove_tree($main::tmpdir);
		mkdir($main::tmpdir);
		$m->reset();
	    }
	    elsif (/^(D)?(SYNC)*S(Y(N(C)?)?)?/)
	    {
		sync($1);
	    }
	    elsif (/^LS$/)
	    {
		system("ls '$main::tmpdir'");
	    }
	    elsif (/^J(O(I(N)?)?)?$/)
	    {
		say "JOIN receive, stopping all threads...";
		$m->stop();
		return 1;
	    }
	    elsif (/^help/i)
	    {
		say "TODO, sorry :(";
	    }
	    else {
		say "$cmd is not a valid command";
	    }
	}

	next if ! $m->join();
	say ">>> $cmd done";
	{
	    lock($queue);

	    my $dq = $queue->dequeue();
	    if ($cmd ne $dq)
	    {
		$queue->insert(0, $dq);

		for (my $i = 0; $i < $queue->pending(); $i++)
		{
		    if ($queue->peek($i) eq $cmd)
		    {
			$queue->extract($i);
			last;
		    }
		}
	    }
	}
    }
}

sub sync
{
    if (shift)
    {
	say "Full synchronization to $main::outdir";

	my $tmpcopy = tempdir();

	find(
	    sub
	    {
		if (-f)
		{
		    my $todir = $File::Find::dir."/";
		    if ($todir =~ /^\Q$main::tmpdir\E\/?(\Q$main::baseadmin\E|\Q$main::baseteams\E|\Q$main::baseerrors\E|\Q$main::basehome\E)(.*)$/)
		    {
			$todir = $tmpcopy;

			return if ($1 eq $main::baseadmin);
			$todir .= $main::outteams if ($1 eq $main::baseteams);
			$todir .= $main::outerrors if ($1 eq $main::baseerrors);
			$todir .= $main::outhome if ($1 eq $main::basehome);

			$todir .= $2;
		    }
		    make_path($todir, { mode => 0751 }) if (! -d $todir );

		    copy($File::Find::name, $todir) or warn(q{copy failed:} . $!);
		}
	    },
	    $tmpdir
	    );

	abs_path($main::outdir);
	abs_path($tmpcopy);

	remove_tree($main::outdir);
	mkdir($main::outdir);

	system("mv '$tmpcopy'/* '$main::outdir/'");
    }
    else
    {
	say "Incremental synchronization to $main::outdir";

	find(
	    sub
	    {
		if (-f)
		{
		    my $todir = $File::Find::dir."/";
		    if ($todir =~ /^\Q$main::tmpdir\E\/?(\Q$main::baseadmin\E|\Q$main::baseteams\E|\Q$main::basehome\E)(.*)$/)
		    {
			$todir = $main::outdir;

			return if ($1 eq $main::baseadmin);
			$todir .= $main::outteams if ($1 eq $main::baseteams);
			$todir .= $main::outerrors if ($1 eq $main::baseerrors);
			$todir .= $main::outhome if ($1 eq $main::basehome);

			$todir .= $2;
		    }
		    make_path($todir, { mode => 0751 }) if (! -d $todir );

		    say "$File::Find::name -> $todir";

		    copy($File::Find::name, $todir) or warn(q{copy failed:} . $!);
		}
	    },
	    $tmpdir
	    );
    }
}

sub parse($$;$)
{
    my $m = shift;
    my $change_current = 0;
    my $cmds = shift;
    my $chan_output = shift // \*STDOUT;

    for my $cmd ($cmds =~ /([^:]+)/g)
    {
	my $len = length($cmd);

	# Search the right position
	my $i;
	for ($i = 0; $i < $queue->pending(); $i++)
	{
	    last if ($len > length($queue->peek($i)));
	}
	say $chan_output "Inserting $cmd at position $i/".$queue->pending();
	$queue->insert($i, $cmd);
	$change_current = 1 if $i == 0 && $queue->pending() != 1;
    }

    if ($change_current)
    {
	say "Priority item have changed, stoping running threads";
	$m->end();
    }

    {
	lock($queue);
	cond_broadcast($queue);
    }

    #print Dumper($queue);
}


# Parse arguments
my $help; my $deamon; my $socket;
GetOptions ("threads|thread|t=i" => \$threads,
	    "baseadmin|ba=s" => \$baseadmin,
	    "basehome|bh=s" => \$basehome,
	    "baseteams|bt=s" => \$baseteams,
	    "outdir|out|o=s" => \$outdir,
	    "deamon|d" => \$deamon,
	    "socket|s=s" => \$socket,
            "help|h|?" => \$help);

$outdir = abs_path($outdir);

sub create_socket
{
    my $m = shift;
    my $socket_path = abs_path( shift );

    unlink($socket_path) if -e $socket_path;

    my $socket = IO::Socket::UNIX->new(
	Local  => $socket_path,
	Type   => SOCK_STREAM,
	Listen => SOMAXCONN,
	);
    say "Socket listening on $socket_path; waiting for connections...";

    while(my $connection = $socket->accept)
    {
	say "New connexion, new thread ready for parsing actions!";
	threads->create(\&socket_run, $m, $connection);
    }
}

sub socket_run
{
    my $m = shift;
    my $connection = shift;

    $connection->autoflush(1);
    say $connection "You are connected to gen_site.pl, please enter command:";
    while (<$connection>)
    {
	chomp $_;
	parse($m, $_, $connection);
    }
    say "Closing socket connection; stopping thread.";
    close $connection;
}

if ($deamon)
{
    my $m :shared = Mirror->new();

    $main_thread = threads->create(\&manage, $m);

    threads->create(\&create_socket, $m, $socket) if ($socket);

    while(<>)
    {
	chomp $_;
	parse($m, $_);
    }

    parse($m, "J");
    $main_thread->join();
}
elsif (@ARGV)
{
    my $m :shared = Mirror->new();

    $main_thread = threads->create(\&manage, $m);

    threads->create(\&create_socket, $m, $socket) if ($socket);

    while ($_ = shift) {
	parse($m, $_);
    }

    parse($m, "J");
    $main_thread->join();
}
else
{
    my $m = genFull();
    genHome($m);

    $m->join();

    sync(1);
}

remove_tree($main::tmpdir);


package Mirror;

use v5.10.1;
use strict;
use warnings;
use threads;
use threads::shared;

use Thread::Queue;

sub new($)
{
    my $class = shift;
    my $self :shared = shared_clone({
	threads => [],
	stop => 0,
    });

    bless $self, $class;

    $self->start();

    return $self;
}

sub start($)
{
    my $self = shift;

    $self->{add} = Thread::Queue->new("#RESET");
    $self->{todo} = Thread::Queue->new();
    $self->{waiting} = 0;
    $self->{end} = 0;

    push @{ $self->{threads} }, threads->create(\&run_add, $self)->tid();

    for (my $i = 0; $i < $main::threads; $i++) {
	push @{ $self->{threads} }, threads->create(\&run, $self, $i + 1)->tid();
    }
}

sub reset($)
{
    my $self = shift;

    $self->{add}->enqueue("#RESET");
}

sub end($)
{
    my $self = shift;

    $self->{end} = 1;

    while($self->{add}->dequeue_nb()) { }
    while($self->{todo}->dequeue_nb()) { }

    $self->reset();

    {
	lock($self);

	cond_broadcast($self);
    }

    return $self->join();
}

sub stop($)
{
    my $self = shift;

    $self->{stop} = 1;

    return $self->end();
}

sub add_url($@)
{
    my $self = shift;

    while (my $link = shift)
    {
	$self->{add}->enqueue($link);
    }
}

sub run_add
{
    my $self = shift;
    my $id = shift // 0;

    my %urlseen;

    while (! $self->{stop})
    {
	my $link = $self->{add}->dequeue_nb();

	if (! defined $link)
	{
	    {
		lock($self);
		$self->{waiting} += 1;
		cond_broadcast($self);
	    }
	    $link = $self->{add}->dequeue();
	    last if (! defined $link);
	    {
		lock($self);
		$self->{waiting} -= 1;
	    }
	}

	next if (exists $urlseen{$link});

	if ($link eq "#RESET")
	{
	    %urlseen = ();
	}
	else
	{
	    $self->{todo}->enqueue($link);
	    $urlseen{$link} = 1;
	}
    }
}

sub run
{
    my $self = shift;
    my $id = shift // 0;

    while (! $self->{stop})
    {
	my $url = $self->{todo}->dequeue_nb();

	if (! defined $url)
	{
	    {
		lock($self);
		$self->{waiting} += 1;
		cond_broadcast($self);
	    }
	    $url = $self->{todo}->dequeue();
	    last if (! defined $url);
	    {
		lock($self);
		$self->{waiting} -= 1;
	    }
	}

	say "[$id] $baseurl$url";

	my $p = FicPage->new($baseurl . $url);
	$p->fetch();

	$p->toRightURL() if ($url !~ /\/$/);

	my @links = $p->getNearLinks() if ! $self->{end};

	$p->treatLinks();
	$p->save();

	for my $link (@links)
	{
	    $self->add_url($link) if ($link ne $url && ($link =~ /^?\Q$url\E/) || $p->{url} =~ /\.css$/);
	}
    }
}

sub join($)
{
    my $self = shift;

    sleep 1 if ($self->{waiting} == $main::threads + 1);

    return ($self->{waiting} > 0 && ! $self->{end}) if ($self->{waiting} == $main::threads + 1);

    {
	lock($self);
	cond_wait($self) until ($self->{waiting} >= $main::threads + 1 || $self->{waiting} < 0 || $self->{stop});
    }

    return ($self->{waiting} > 0 && ! $self->{end});
}


package FicPage;

use v5.10.1;
use strict;
use warnings;

use File::Basename;
use File::Path qw(make_path);
use HTTP::Request::Common qw(GET POST);
use LWP::UserAgent;

sub new
{
    my $class = shift;
    my $self = {
	url => shift,
    };

    bless $self, $class;

    return $self;
}

sub toRightURL($)
{
    my $self = shift;

    my $search = $self->{url};
    $search =~ s!/$!!;

    for my $url ($self->getLinks())
    {
	$url = $baseurl . $url;
	if ($url =~ /^\Q$search\E/)
	{
	    $url =~ s!^(\Q$search\E[^/]*).*$!$1/!;

	    $self->{url} = $url;
	    return $url;
	}
    }

    return $self->{url};
}

sub getLinks($)
{
    my $self = shift;

    return $self->{content} =~ /(?:src|href|action)="([^"]+)"/g;
}

sub getNearLinks($)
{
    my $self = shift;

    if ($self->{url} =~ /\.css$/)
    {
	return $self->{content} =~ /url\(["']?(?:\Q$main::baseurl\E|(?:\/?\.\.)+)?([^:)"'?#]+)/g;
    }
    else
    {
	my @links = $self->{content} =~ /(?:src|href)="(?:\Q$main::baseurl\E|(?:\/?\.\.)+)?([^:"]+)"/g;

	for my $action ($self->{content} =~ /action="(?:\Q$main::baseurl\E|(?:\/?\.\.)+)?([^:"]+)"/g)
	{
	    push @links, $action;
	    push @links, "$action/gerr";
	    push @links, "$action/serr";
	}

	return @links;
    }
}

sub treatLinks($)
{
    my $self = shift;

    $self->{content} =~ s!(src|href|action)="( \Q$baseteams\E[^/]+/ | \Q$baseadmin\E | \Q$basehome\E)([^"]*)"!$1="/$3"!gx;
}

sub fetch($)
{
    my $self = shift;
    my $ua = LWP::UserAgent->new;

    my $res = $ua->request(GET $self->{url});

    $self->{content} = $res->content;
}

sub alreadySaved($;$)
{
    my $self = shift;

    my $path = $self->getSavePath(@_);
    return -f $path || ( -d $path && -f "$path/index.html" );
}

sub getSavePath($;$)
{
    my $self = shift;
    my $basedir = shift // $main::tmpdir;

    # Convert URL to real directory path
    my $path = $self->{url};
    $path =~ s/^\Q$main::baseurl\E//;

    return "$basedir$path";
}

sub save($;$)
{
    my $self = shift;

    # Convert URL to real directory path
    my $path = $self->getSavePath(@_);

    eval
    {
	if ($path =~ /\.[a-z0-9]{2,4}$/)
	{
	    eval {
		make_path( dirname("$path") , { mode => 0751 }) if (! -d dirname("$path") );
	    };

	    open my $fd, ">", $path or die "$path: $!";
	    print $fd $self->{content};
	    close $fd;
	}
	else
	{
	    eval {
		make_path "$path", { mode => 0751 } if (! -d "$path");
	    };

	    open my $fd, ">", "$path/index.html" or die "$path: $!";
	    print $fd $self->{content};
	    close $fd;
	}
    };
    print $@ if ($@);
}