This repository has been archived on 2025-02-01. You can view files and clone it, but cannot push or open issues or pull requests.
perl-gopher-server/gopher.pl
2010-08-14 22:34:11 +02:00

161 lines
4.2 KiB
Perl

#!/usr/bin/perl
#####################################
# Thomas Schwery <thomas@schwery.me>
####################################
#
# TODO:
# - Support for a list of tags
# - Cleanup on ctrl-c
# - Multithreading
# - ...
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;
our $port = 70;
our %entries = ();
$SIG{INT} = \&signal_handler_interrupt;
my $socket = new IO::Socket::INET (LocalPort => $port, Proto => 'tcp', Listen => '1');
die "Unable to open port\n" unless $socket;
drop_privileges('nobody');
while (1) {
my $listen_socket = $socket->accept();
$_ = <$listen_socket>;
s/\r*\n*//g;
s/\t.*//g; # Don't care about the parameters now ...
my $directory = $_;
print "Client " . $.. ": <" . $_ . ">\n";
if (-f $directory) {
if (substr($directory, 0, 4) eq "blog") {
$listen_socket->send(send_blog_entry($directory));
} else {
open FILE, $directory;
while (<FILE>) {
$listen_socket->send($_);
}
$listen_socket->send("\r\n.\r\n") if (-T $directory);
}
} else {
my $header = generate_header($directory);
my $blog_entries = list_blog_entries();
$listen_socket->send($header . "\r\n");
$listen_socket->send("\r\n");
$listen_socket->send("i----- Blog entries ---------------\tfake\tfake\t0\r\n");
$listen_socket->send($blog_entries . "\r\n");
$listen_socket->send("\r\n.\r\n");
}
}
sub generate_header {
my ($directory) = @_;
$directory .= "/" if ($directory);
return "\r\n" unless (-T $directory . "header");
my $message = "";
open FILE, $directory . "header";
while (<FILE>) {
$message .= "i" . $_ . "\tfake\tfake\t0\r\n";
}
close FILE;
$message .= "0About this gopher server\theader\tlocalhost\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" . $directory . $dir_entry . "\tlocalhost\t" . $port;
}
sub filter_content {
my ($dir_entry, $blog_dir) = @_;
return 1 unless (substr($dir_entry,0,1) eq "." || $dir_entry eq "header");
return 0;
}
sub list_blog_entries {
my $blog_dir = "blog";
unless (opendir(IMD, $blog_dir)) {
die("Fuck you all ...");
}
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 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*//;
$subject = $1 if (m/^Subject:\s*(.*)$/);
$tags = $1 if (m/^Tags:\s*(.*)$/);
$date_file = $1 if (m/^Date:\s*(.*)$/);
}
close ENTRY;
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" . $entry_dir . "/" . $entry_file . "\tlocalhost\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";
exit 0;
}