~duncan-bayne/halp

8342b90f0849edef584248a8461a048ecb9bb62a — Duncan Bayne 29 days ago 0be70af
Continue removing server code
30 files changed, 27 insertions(+), 442 deletions(-)

M halp.pl
A lib/Halp/GeminiGenerator.pm
D lib/Halp/GeminiServer.pm
D lib/Halp/MimeTypes.pm
R lib/Halp/{WebServer.pm => WebGenerator.pm}
D t/Halp/atom_feed_test.t
D t/Halp/web_server_test.t
D t/fixtures/atom_feed/.title
D t/fixtures/atom_feed/bar/.baz.title
D t/fixtures/atom_feed/bar/baz
D t/fixtures/atom_feed/bar/qux
D t/fixtures/atom_feed/foo
D t/fixtures/www/.description.html
D t/fixtures/www/.gitkeep
D t/fixtures/www/.title
D t/fixtures/www/blog/.2023-05-07_first-article.html.title
D t/fixtures/www/blog/.description.html
D t/fixtures/www/blog/.footer.html
D t/fixtures/www/blog/.title
D t/fixtures/www/blog/2023-05-07_first-article.html
D t/fixtures/www/blog/2023-05-07_second-article.html
D t/fixtures/www/miscellaneous/.description.html
D t/fixtures/www/miscellaneous/.gitkeep
D t/fixtures/www/projects/.description.html
D t/fixtures/www/projects/.title
D t/fixtures/www/projects/halp/.description.html
D t/fixtures/www/projects/halp/.gitkeep
D t/fixtures/www/projects/halp/.index.html.title
D t/fixtures/www/projects/unicomp-overhaul/.description.html
D t/fixtures/www/projects/unicomp-overhaul/.gitkeep
M halp.pl => halp.pl +4 -4
@@ 5,8 5,8 @@ use strict;
use warnings;

use Getopt::Long;
use Halp::GeminiServer;
use Halp::WebServer;
use Halp::GeminiGenerator;
use Halp::WebGenerator;

my %halp_config;
my $config_filename = '';


@@ 31,7 31,7 @@ my $config_hash = do($config_filename);
%halp_config = %$config_hash;

if ($web) {
    my $web_server = Halp::WebServer->new(
    my $web_server = Halp::WebGenerator->new(
	author => $halp_config{author},
	domain => $halp_config{domain},
	host => $halp_config{gemini}{host},


@@ 42,7 42,7 @@ if ($web) {
}

if ($gemini) {
    my $gemini_server = Halp::GeminiServer->new(
    my $gemini_server = Halp::GeminiGenerator->new(
	author => $halp_config{author},
	domain => $halp_config{domain},
	host => $halp_config{gemini}{host},

A lib/Halp/GeminiGenerator.pm => lib/Halp/GeminiGenerator.pm +22 -0
@@ 0,0 1,22 @@
package Halp::GeminiGenerator;

use strict;
use warnings;

use File::Basename;
use File::Spec;
use IO::Socket::INET;
use IO::Socket::SSL;
use Text::Template;

sub new {
    my ($class, %args) = @_;
    my $self = bless \%args, $class;

    return $self;
}

sub generate {
}

1;

D lib/Halp/GeminiServer.pm => lib/Halp/GeminiServer.pm +0 -83
@@ 1,83 0,0 @@
package Halp::GeminiServer;

use strict;
use warnings;

use File::Basename;
use File::Spec;
use IO::Socket::INET;
use IO::Socket::SSL;
use Text::Template;

sub new {
    my ($class, %args) = @_;
    my $self = bless \%args, $class;

    return $self;
}

sub ok_20 {
    my ($self, $content) = @_;
    return "20 text/gemini\r\n$content";
}

sub not_found_51 {
    my ($self, $path) = @_;
    return "51 text/gemini\r\n";
}

sub handle_request {
    my ($self, $host, $path) = @_;
    my $local_path = File::Spec->catfile($self->{gemini_path}, $path);
    my $local_filename = basename($local_path);

    if ($local_filename =~ m/^_/ || !-f $local_path) {
	return $self->not_found_51($path);
    } else {
	my $template = Text::Template->new(SOURCE => $local_path);
	my $result = $template->fill_in(HASH => {'path' => $path});
	return $self->ok_20($result)
    }
}

sub run {
    my ($self) = @_;

    my $gemini_server = IO::Socket::SSL->new(
	LocalAddr => $self->{host},
	LocalPort => $self->{port},
	Listen => 10,
	ReuseAddr => 1,
	SSL_cert_file => $self->{cert_path},
	SSL_key_file => $self->{key_path}
	) or die "Unable to create SSL server: ", IO::Socket::SSL::errstr(), "\n";

    while (my $client = $gemini_server->accept()) {
	my $request = "";
	{
	    local $/ = "\r\n";
	    $request = $client->getline();
	}
	chomp $request;

	if ($request =~ /^gemini:\/\/([^\/]+)(\/.*)?/) {
	    my $host = $1;
	    $host =~ s/\s+$//;

	    my $path = $2 // '/';
	    $path =~ s/\s+$//;

	    my $response = $self->handle_request($host, $path);
	    print $client $response;
	} else {
	    print $client "59 Invalid request\r\n";
	}

	$client->close();
    }
}

sub generate {
}

1;

D lib/Halp/MimeTypes.pm => lib/Halp/MimeTypes.pm +0 -74
@@ 1,74 0,0 @@
package Halp::MimeTypes;

use Exporter 'import';
our @EXPORT = qw(mime_types);

sub mime_types {
    return {
	'ai'    => 'application/postscript',
	    'aif'   => 'audio/x-aiff',
	    'aifc'  => 'audio/x-aiff',
	    'aiff'  => 'audio/x-aiff',
	    'au'    => 'audio/basic',
	    'avi'   => 'video/x-msvideo',
	    'bmp'   => 'image/bmp',
	    'bz2'   => 'application/x-bzip2',
	    'class' => 'application/java',
	    'css'   => 'text/css',
	    'csv'   => 'text/csv',
	    'eps'   => 'application/postscript',
	    'flac'  => 'audio/flac',
	    'gif'   => 'image/gif',
	    'gz'    => 'application/gzip',
	    'htm'   => 'text/html',
	    'html'  => 'text/html',
	    'ics'   => 'text/calendar',
	    'jar'   => 'application/java-archive',
	    'jfif'  => 'image/jpeg',
	    'jpe'   => 'image/jpeg',
	    'jpeg'  => 'image/jpeg',
	    'jpg'   => 'image/jpeg',
	    'js'    => 'text/javascript',
	    'json'  => 'application/json',
	    'm3u'   => 'audio/x-mpegurl',
	    'm4a'   => 'audio/mp4',
	    'mid'   => 'audio/midi',
	    'midi'  => 'audio/midi',
	    'mov'   => 'video/quicktime',
	    'mp3'   => 'audio/mpeg',
	    'mp4'   => 'video/mp4',
	    'mpeg'  => 'video/mpeg',
	    'mpg'   => 'video/mpeg',
	    'odp'   => 'application/vnd.oasis.opendocument.presentation',
	    'ods'   => 'application/vnd.oasis.opendocument.spreadsheet',
	    'odt'   => 'application/vnd.oasis.opendocument.text',
	    'ogg'   => 'audio/ogg',
	    'pdf'   => 'application/pdf',
	    'php'   => 'application/x-httpd-php',
	    'png'   => 'image/png',
	    'ps'    => 'application/postscript',
	    'qt'    => 'video/quicktime',
	    'rar'   => 'application/x-rar-compressed',
	    'rtf'   => 'application/rtf',
	    'sh'    => 'application/x-sh',
	    'svg'   => 'image/svg+xml',
	    'swf'   => 'application/x-shockwave-flash',
	    'tar'   => 'application/x-tar',
	    'tex'   => 'application/x-tex',
	    'tif'   => 'image/tiff',
	    'tiff'  => 'image/tiff',
	    'ts'    => 'video/mp2t',
	    'txt'   => 'text/plain',
	    'wav'   => 'audio/wav',
	    'weba'  => 'audio/webm',
	    'webm'  => 'video/webm',
	    'webp'  => 'image/webp',
	    'woff'  => 'font/woff',
	    'woff2' => 'font/woff2',
	    'xml'   => 'application/xml',
	    'xslt'  => 'application/xslt+xml',
	    'zip'   => 'application/zip',
    };
}

1;

R lib/Halp/WebServer.pm => lib/Halp/WebGenerator.pm +1 -10
@@ 1,21 1,12 @@
package Halp::WebServer;
package Halp::WebGenerator;

use Cwd;
use Data::Dump qw(dump);
use File::Basename;
use File::Copy;
use File::Copy::Recursive "dircopy";
use File::Glob;
use File::Slurp;
use File::Spec;
use Halp::AtomFeed;
use Halp::ContentUtils;
use Halp::MimeTypes;
use HTTP::Server::Simple::CGI;
use Text::Template;
use Time::Piece;
use utf8;
use XML::Atom::SimpleFeed;

use base qw(HTTP::Server::Simple::CGI);


D t/Halp/atom_feed_test.t => t/Halp/atom_feed_test.t +0 -36
@@ 1,36 0,0 @@
use Cwd;
use lib cwd() . '/lib';

use strict;
use warnings;

use File::Spec::Functions 'rel2abs';
use Halp::AtomFeed;
use Mojo::DOM;
use Test::More;

use Test::More tests => 8;

my $feed = feed_for('/feed.xml',
		    rel2abs('./t/fixtures/atom_feed/feed.xml'),
		    'example.com',
		    {email => 'author@example.com', name => 'An Author'});

my $xml = Mojo::DOM->new->xml(1)->parse($feed);

is($xml->at('feed')->at('title')->text, 'Test Title', 'The Atom feed has the correct title.');
like($xml->at('feed updated')->text, qr/2023-04-16T00:48:08\+10:00/, 'Feed Updated timestamp is correct');

my $entries = $xml->find('entry');

is($entries->[0]->at('title')->text, 'An Exposition on Baz', 'Entry Title is correct');
like($entries->[0]->at('updated')->text, qr/2023-08-19T18:24:16\+10:00/, 'Entry Updated timestamp is correct');

is($entries->[1]->at('title')->text, 'qux', 'Entry Title is correct');
like($entries->[1]->at('updated')->text, qr/2023-08-19T18:24:16\+10:00/, 'Entry Updated timestamp is correct');

is($entries->[2]->at('title')->text, 'foo', 'Entry Title is correct');
like($entries->[2]->at('updated')->text, qr/2023-08-19T18:24:16\+10:00/, 'Entry Updated timestamp is correct');

exit(0);


D t/Halp/web_server_test.t => t/Halp/web_server_test.t +0 -217
@@ 1,217 0,0 @@
use Cwd;
use lib cwd() . "/lib";

use strict;
use warnings;

use File::Spec::Functions 'rel2abs';
use Halp::WebServer;
use LWP::UserAgent;
use Mojo::DOM;
use Test::Exception;
use Test::More;
use Time::HiRes qw(time);

my $ua = LWP::UserAgent->new();
my $web_pid = 0;

$SIG{TERM} = \&cleanup;

sub cleanup {
    if (defined($web_pid) && $web_pid > 0) {
	kill('TERM', $web_pid);
	waitpid($web_pid, 0);
    }
    exit(0);
}

sub run_404_tests {
    my $response = $ua->get('http://localhost:8088/qux');
    my $dom = Mojo::DOM->new($response->content);

    is($response->code, 404, 'Requesting a non-existent resource returns a 404.');
    like($dom->at('main')->at('p')->text, qr/\/qux was not found/, '404 page explains the problem.');
    like($dom->at('title')->text, qr/^Page not found$/, '404 page has a title');
}

sub run_constructor_tests {
    dies_ok {
	my $web_server = Halp::WebServer->new(
	    domain => 'example.com',
	    port => 8088,
	    web_path => './t/fixtures/www'
	    );
    } 'Constructor should fail when given a relative web path.';
}

sub run_directory_tests {
    my $response = $ua->get('http://localhost:8088/blog');
    my $dom = Mojo::DOM->new($response->content);

    is($response->code, 200, 'Requesting a directory without an index file returns 200.');
    like($dom->at('title')->text, qr/^My Blog$/, 'The directory listing has a title.');

    like($dom->at('#description p')->text, qr/My blog posts/, 'The directory listing has a description.');
    my $ul_elements = $dom->find('ul#directory-listing')->size;
    is($ul_elements, 1, 'There is exactly one list of directory contents.');

    my $li_elements = $dom->find('ul#directory-listing li')->size;
    is($li_elements, 2, 'There are exactly two <li> tags inside the <ul> tag.');

    my @li_texts = $dom->find('ul#directory-listing li a')->map('text')->each;
    is($li_texts[0], 'My First Ever Article', 'The first item is the title of the first blog post, per HREF order.');
    is($li_texts[1], '2023-05-07_second-article.html', 'The second item is its filename, as it has no .title file.');

    my @li_links = $dom->find('ul#directory-listing li a')->map(attr => 'href')->each;
    is($li_links[0], '/blog/2023-05-07_first-article.html', 'The first item has the URL of the second blog post, alphabetically by HREF.');
    is($li_links[1], '/blog/2023-05-07_second-article.html', 'The first item has the URL of the first blog post, alphabetically by HREF.');
}

sub run_feed_tests() {
    my $response = $ua->get('http://localhost:8088/feed.xml');
    my $xml = Mojo::DOM->new->xml(1)->parse($response->content);

    like($xml->at('feed')->at('title')->text, qr/^My Site$/, 'The Atom feed has the correct title.');
    is($xml->at('feed')->at('link')->attr('href'), 'https://example.com', 'The Atom feed has the correct URL.');

    my $item_links = $xml->find('feed > entry > link');
    is($item_links->size, 3, 'There should be three links because feeds include all files in subdirectories.');
    is($item_links->[0]->attr('href'), 'https://example.com/blog/2023-05-07_first-article.html', 'The first blog link has the correct URL.');
    is($item_links->[1]->attr('href'), 'https://example.com/blog/2023-05-07_second-article.html', 'The first blog link has the correct URL.');
    is($item_links->[2]->attr('href'), 'https://example.com/projects/halp/index.html', 'The first blog link has the correct URL.');
}

sub run_performance_tests {
    my $start_time = time;
    for (1...10) {
	$ua->get('http://localhost:8088/');
    }
    my $elapsed_ms = (time - $start_time) * 1000.0;
    cmp_ok($elapsed_ms, '<', 150, '10 GETs of / takes < 150ms in total.');
}

sub run_protocol_tests {
    my $response;
    my $dom;

    $response = $ua->post('http://localhost:8088/');
    $dom = Mojo::DOM->new($response->content);
    is($response->code, 405, 'A POST request returns a 405.');
    like($dom->at('main')->at('p')->text, qr/Method not allowed/, '405 page explains the problem.');
    like($dom->at('title')->text, qr/^Method not allowed$/, '405 page has a title');

    $response = $ua->delete('http://localhost:8088/');
    is($response->code, 405, 'A DELETE request returns a 405.');

    $response = $ua->head('http://localhost:8088/');
    is($response->code, 405, 'A HEAD request returns a 405.');

    $response = $ua->patch('http://localhost:8088/');
    is($response->code, 405, 'A PATCH request returns a 405.');

    $response = $ua->put('http://localhost:8088/');
    is($response->code, 405, 'A PUT request returns a 405.');
}

sub run_root_tests {
    my $response = $ua->get('http://localhost:8088');
    my $dom = Mojo::DOM->new($response->content);

    is($response->code, 200, 'Requesting a directory without an index file returns 200.');
    like($dom->at('title')->text, qr/^My Site$/, 'The directory listing has a title taken from its .title file.');
    my $ul_elements = $dom->find('ul#directory-listing')->size;
    is($ul_elements, 1, 'There is exactly one list of directory contents.');

    my $li_elements = $dom->find('ul#directory-listing li')->size;
    is($li_elements, 3, 'There are exactly three <li> tags inside the <ul> tag.');

    my @li_texts = $dom->find('ul#directory-listing li a')->map('text')->each;
    is($li_texts[0], 'My Blog', 'The first item is the title of the first subdirectory.');
    is($li_texts[1], 'miscellaneous', 'The second item is the filename of the second subdirectory, because it contains no .title file.');
    is($li_texts[2], 'Projects', 'The third item is the title of the third subdirectory.');

    my @li_links = $dom->find('ul#directory-listing li a')->map(attr => 'href')->each;
    is($li_links[0], '/blog', 'The first root subdirectory has the correct URL.');
    is($li_links[1], '/miscellaneous', 'The third root subdirectory has the correct URL.');
    is($li_links[2], '/projects', 'The third root subdirectory has the correct URL.');

    my @menu_links = $dom->find('ul.menu li a')->map(attr => 'href')->each;
    is($menu_links[0], '#top', 'The menu starts with a link back to the top of the page.');
    is($menu_links[1], '/', 'The second menu link is always home.');
    is($menu_links[2], '/blog', 'The third menu link has the correct URL.');
    is($menu_links[3], '/miscellaneous', 'The fourth menu link has the correct URL.');
    is($menu_links[4], '/projects', 'The fifth menu link has the correct URL.');
}

sub run_static_file_tests {
   my $response = $ua->get('http://localhost:8088/static/styles/halp.css');
   my $css = Mojo::DOM->new($response->content);

   is($response->code, 200, 'Requesting a static CSS file returns 200.');
   is($response->content_type, 'text/css', 'Static CSS file is served with the correct content type.');
   like($response->content, qr/^body \{/, 'Static CSS file starts with body selector.');

   $response = $ua->get('http://localhost:8088/static/images/avatar.jpg');
   is($response->code, 200, 'Requesting a static JPG file returns 200.');
   is($response->content_type, 'image/jpeg', 'Static JPG file is served with the correct content type.');
}

sub run_subdirectory_tests {
    my $response = $ua->get('http://localhost:8088/projects');
    my $dom = Mojo::DOM->new($response->content);

    is($response->code, 200, 'Requesting a directory without an index file returns 200.');
    like($dom->at('title')->text, qr/^Projects$/, 'The directory listing has a title.');

    like($dom->at('#description p')->text, qr/My projects./, 'The directory listing has a description.');

    my $ul_elements = $dom->find('ul#directory-listing')->size;
    is($ul_elements, 1, 'There is exactly one list of directory contents.');

    my $li_elements = $dom->find('ul#directory-listing li')->size;
    is($li_elements, 2, 'There are exactly two <li> tags inside the <ul> tag.');

    my @li_links = $dom->find('ul#directory-listing li a')->map(attr => 'href')->each;
    is($li_links[0], '/projects/halp', 'The first item has the URL of the first subdirectory.');
    is($li_links[1], '/projects/unicomp-overhaul', 'The first item has the URL of the second subdirectory.');
}

sub run_templated_file_tests {
    my $response = $ua->get('http://localhost:8088/blog/2023-05-07_first-article.html');
    my $dom = Mojo::DOM->new($response->content);

    is($response->code, 200, 'Requesting a templated file returns 200.');
    like($dom->at('title')->text, qr/^My First Ever Article$/, 'The title is extracted from the hidden title file.');
    like($dom->at('p')->text, qr/^\s*This is a blog post, which should be templated.\s*$/, 'The templated file has the expected content.');
    like($dom->at('footer')->text, qr/^\s*A footer!\s*$/, 'The templated file includes the footer from .footer.html.');
}

$web_pid = fork();
if (!defined($web_pid)) {
    print STDERR "forking hell\n";
    exit 1;
}

if ($web_pid == 0) {
    my $web_server = Halp::WebServer->new(
	domain => 'example.com',
	port => 8088,
	web_path => rel2abs('./t/fixtures/www')
	);
    $web_server->run();
} else {
    use Test::More tests => 58;
    run_404_tests();
    run_constructor_tests();
    run_directory_tests();
    run_feed_tests();
    run_performance_tests();
    run_protocol_tests();
    run_root_tests();
    run_static_file_tests();
    run_subdirectory_tests();
    run_templated_file_tests();
    done_testing();
    cleanup();
    exit(0);
}

D t/fixtures/atom_feed/.title => t/fixtures/atom_feed/.title +0 -1
@@ 1,1 0,0 @@
Test Title

D t/fixtures/atom_feed/bar/.baz.title => t/fixtures/atom_feed/bar/.baz.title +0 -1
@@ 1,1 0,0 @@
An Exposition on Baz

D t/fixtures/atom_feed/bar/baz => t/fixtures/atom_feed/bar/baz +0 -0
D t/fixtures/atom_feed/bar/qux => t/fixtures/atom_feed/bar/qux +0 -0
D t/fixtures/atom_feed/foo => t/fixtures/atom_feed/foo +0 -0
D t/fixtures/www/.description.html => t/fixtures/www/.description.html +0 -2
@@ 1,2 0,0 @@
<p>This is my site, served by Halp.</p>
<img alt="My Avatar" src="/.static/images/avatar.jpg">

D t/fixtures/www/.gitkeep => t/fixtures/www/.gitkeep +0 -0
D t/fixtures/www/.title => t/fixtures/www/.title +0 -1
@@ 1,1 0,0 @@
My Site
\ No newline at end of file

D t/fixtures/www/blog/.2023-05-07_first-article.html.title => t/fixtures/www/blog/.2023-05-07_first-article.html.title +0 -1
@@ 1,1 0,0 @@
My First Ever Article

D t/fixtures/www/blog/.description.html => t/fixtures/www/blog/.description.html +0 -1
@@ 1,1 0,0 @@
<p>My blog posts.</p>

D t/fixtures/www/blog/.footer.html => t/fixtures/www/blog/.footer.html +0 -1
@@ 1,1 0,0 @@
A footer!

D t/fixtures/www/blog/.title => t/fixtures/www/blog/.title +0 -1
@@ 1,1 0,0 @@
My Blog

D t/fixtures/www/blog/2023-05-07_first-article.html => t/fixtures/www/blog/2023-05-07_first-article.html +0 -3
@@ 1,3 0,0 @@
<p>
    This is a blog post, which should be templated.
</p>

D t/fixtures/www/blog/2023-05-07_second-article.html => t/fixtures/www/blog/2023-05-07_second-article.html +0 -0
D t/fixtures/www/miscellaneous/.description.html => t/fixtures/www/miscellaneous/.description.html +0 -1
@@ 1,1 0,0 @@
A description

D t/fixtures/www/miscellaneous/.gitkeep => t/fixtures/www/miscellaneous/.gitkeep +0 -0
D t/fixtures/www/projects/.description.html => t/fixtures/www/projects/.description.html +0 -1
@@ 1,1 0,0 @@
<p>My projects.</p>

D t/fixtures/www/projects/.title => t/fixtures/www/projects/.title +0 -1
@@ 1,1 0,0 @@
Projects

D t/fixtures/www/projects/halp/.description.html => t/fixtures/www/projects/halp/.description.html +0 -1
@@ 1,1 0,0 @@
Halp

D t/fixtures/www/projects/halp/.gitkeep => t/fixtures/www/projects/halp/.gitkeep +0 -0
D t/fixtures/www/projects/halp/.index.html.title => t/fixtures/www/projects/halp/.index.html.title +0 -1
@@ 1,1 0,0 @@
The Halp Project

D t/fixtures/www/projects/unicomp-overhaul/.description.html => t/fixtures/www/projects/unicomp-overhaul/.description.html +0 -1
@@ 1,1 0,0 @@
Unicomp Overhaul

D t/fixtures/www/projects/unicomp-overhaul/.gitkeep => t/fixtures/www/projects/unicomp-overhaul/.gitkeep +0 -0