perl-gopher-server/gopher.pl

#!/usr/bin/perl

#####################################
# Thomas Schwery <thomas@schwery.me>
####################################
#
# TODO: 
#  - Support for a list of tags
#  - Default port if failure
#  - ...

use strict;
use IO::Socket;
use Fcntl ':mode';
use Privileges::Drop;
use HTML::Parse;
use HTML::FormatText;
use Text::Wrap;
use Date::Parse;
use Date::Format;
use threads;

use Clone qw(clone);

our ($port, $basedir, $server) = @ARGV;

print "Port is " . $port . "\n";
print "Base dir is " . $basedir . "\n";

$SIG{INT} = \&signal_handler_interrupt;
$SIG{PIPE} = \&signal_handler_pipe;

my $socket = new IO::Socket::INET(LocalPort => $port,
                                  Proto     => 'tcp',
                                  Listen    => '1',
                                  Reuse     => 1);
die "Unable to open port: $! \n" unless $socket;

drop_privileges('nobody');

our %tags_entries;

while (1) {
    my $listen_socket = $socket->accept();
    my $thr = threads->create(\&connection_thread, $listen_socket);
    $thr->detach();
}

sub connection_thread {
    my ($listen_socket) = @_;
    $_ = <$listen_socket>;
    s/\r*\n*//g;
    s/\t.*//g; # Don't care about the parameters now ...
    my $directory = $_;
    
    $directory =~ s/^blog\///;
    $directory =~ s/[.\/]//g;
    $directory = $basedir . "/" . $directory;
    $directory =~ s/\/$//;
    
    unless (-e $directory) {
        print("Requested file or directory not readable : $directory \n");
        $listen_socket->send("No entry found with this name ...\r\n");
        $listen_socket->send(".\r\n");
        return 0;
    }
    
    if (-f $directory) {
        $listen_socket->send(send_blog_entry($directory));
        $listen_socket->send(".\r\n");
    } else {
        my $header = generate_header(".");
        my $blog_entries = list_blog_entries($directory);
        my $tags_entries = list_entries_by_tag($directory);
        
        $listen_socket->send($header);
        $listen_socket->send("i----- Blog entries ---------------\tfake\tfake\t0\r\n");
        $listen_socket->send($blog_entries);
        $listen_socket->send("i----- Blog entries by tags---------------\tfake\tfake\t0\r\n");
        $listen_socket->send($tags_entries);
        $listen_socket->send(".\r\n");
    }
    
    $listen_socket->close();
    
    return 0;
}

sub generate_header {
    my ($directory) = @_;
    $directory .= "/" if ($directory);
    
    return "" unless (-T $directory . "header");
    
    my $message = "";
    open FILE, $directory . "header";
    while (<FILE>) {
        s/\r*\n*//g;
        $message .= "i" . $_ . "\tfake\tfake\t0\r\n";
    }
    close FILE;
    #$message .= "0About this gopher server\theader\t" . $server . "\t" . $port . "\r\n"; 
    
    return $message;
}

sub map_content {
    my ($dir_entry, $directory) = @_;
    $directory .= "/" if ($directory);
    
    my $file_type = -f $directory . $dir_entry ? 0 : 1;
    $file_type = 9 if (-f $directory . $dir_entry && -B $directory . $dir_entry);
    
    return $file_type . $dir_entry . "\t" . $dir_entry . "\tlocalhost\t" . $port;
}

sub filter_content {
    my ($dir_entry, $blog_dir) = @_;
    return 0 unless -r $blog_dir."/".$dir_entry;
    return 1 unless (substr($dir_entry,0,1) eq "." || $dir_entry eq "header");
    return 0;
}

sub list_blog_entries {
    my ($blog_dir) = @_;
    unless (opendir(IMD, $blog_dir)) {
        return "";
    }
    my @files = readdir(IMD);
    closedir(IMD);
    
    @files = grep filter_content($_, $blog_dir), @files;
    @files = map map_blog_entry($_, $blog_dir), @files; 
    
    @files = sort sort_entry_line($a,$b), @files;
    return join "\r\n", @files;
}

sub list_entries_by_tag {
    my $entries;
    my %tags_entries_local = %{ clone (\%tags_entries) };
    foreach my $tag (sort keys %tags_entries_local) {
        $entries .= "i----- " . $tag . " ---------------\tfake\tfake\t0\r\n";
        foreach my $entry (@{$tags_entries_local{$tag}}) {
            $entry =~ m/^(.*)\/(.*)$/;
            my $entry_dir = $1;
            my $entry_name = $2;
            $entries .= map_blog_entry($entry_name, $entry_dir) . "\r\n";
        }
    }
    return $entries;
}

sub sort_entry_line {
    my $a_date = $2 if ($a =~ m/^0(\[.*\]\s)?(.*?)\s*-.*$/);
    my $b_date = $2 if ($b =~ m/^0(\[.*\]\s)?(.*?)\s*-.*$/);
    
    return -(str2time($a_date) <=> str2time($b_date));
}

sub read_entry_file {
    my ($entry_file) = @_;
    my $subject = "";
    my $date_file = "";
    my $tags = "";
    
    open ENTRY, $entry_file;
    while (<ENTRY>) {
        s/\r*\n*//g;
        $subject = $1 if (m/^Subject:\s*(.*)$/);
        $tags = $1 if (m/^Tags:\s*(.*)$/);
        $date_file = $1 if (m/^Date:\s*(.*)$/);
    }
    close ENTRY;
    
    my @tag_list = split ',',$tags;
    
    foreach my $tag (@tag_list) {
        push @{ $tags_entries{$tag} }, $entry_file;
    }
    
    my $time = str2time($date_file);
    my $date = time2str("%o %h %Y", $time);
    return "[" . $tags . "] " . $date . " - " . $subject if($tags);
    return $date. " - " . $subject;
}

sub map_blog_entry {
    my ($entry_file, $entry_dir) = @_;
    my $entry_title = read_entry_file($entry_dir . "/" . $entry_file);
    return "0" . $entry_title . "\t" . "blog/" . $entry_file . "\t" . $server . "\t" . $port;
}

sub send_blog_entry {
    my ($entry_file) = @_;
    open FILE, $entry_file;
    my $entry_text = "";
    while (<FILE>) {
        $entry_text .= $_;
    }
    $entry_text =~ s/\r?\n/<br>/mg;
    my $plain_text = HTML::FormatText->new->format(parse_html($entry_text));
    $Text::Wrap::columns = 80;
    $plain_text = wrap("\t", "", $plain_text);
    return $plain_text;
}

sub signal_handler_interrupt {
    print "ctrl-c, exiting...\n";
    $socket->shutdown(2);
    $socket->close();
    exit 0;
}

sub signal_handler_pipe {
    print "sigpipe, don't care\n";
    return 0;
}