i've been working on rebuilding my old perl web framework sylfaen for quite a while now, and it still isn't production ready.
when bringing up this new site I decided to just hack together a quick and dirty CGI application as a temporary solution.
the code isn't the greatest, but it certainly works well enough for what I need. i probably should've written a static page generator instead of a fully dynamic system, but meh, we'll revisit that later.
if you find a vulnerability, go nuts, just give me a heads up please :)
the code isn't the greatest, but it certainly works well enough for what I need. i probably should've written a static page generator instead of a fully dynamic system, but meh, we'll revisit that later.
if you find a vulnerability, go nuts, just give me a heads up please :)
#!/usr/bin/env perl
use strict;
use warnings;
use v5.24;
use experimental 'signatures';
# if you're reading this, don't judge me for this code i was too lazy to actually finish the web framework stuff i've been working on for *looks at notes* 3 years
# it's Good Enough:tm: for now
use Carp 'longmess';
use Data::Dumper 'Dumper';
use Hash::MultiValue;
use Text::Template;
my $__headers_sent;
$SIG{__DIE__} = sub { print "Status: 503\r\nContent-type: text/plain\r\n\r\n" unless $__headers_sent; print "something went extra wonky: $_[0]\n"; print longmess(); exit; };
my %pages = (
'/' => 'index.tpl',
'/index.html' => 'index.tpl',
'/notes/' => \&list_notes,
'/music/' => \&list_music,
'/recipes/' => \&list_recipes,
);
my @dynamic_pages = (
[qr!^/music/([^/]+)/$! => \&get_music],
[qr!^/notes/([^/]+)/$! => \&get_note],
[qr!^/recipes/([^/]+)/$! => \&get_recipe],
);
my $status; # set in emit_body
my $var = _query_string_unpack($ENV{QUERY_STRING} // ''); # fallback to an empty string to silence spurious warning when running in non-cgi context
my $path = $ENV{PATH_INFO};
# enforce trailing slashes on any request that isn't in %pages, to make sure relative urls don't break in templates
if (! defined $pages{$path} && $path !~ m!/$!) {
# $path always has a leading slash, no need to worry about off-site redirects
print "Status: 301\r\nLocation: $path/\r\n\r\n";
exit
}
# FIXME: what about pages where we want to override the container?
my $payload = emit_template('./asset/template/container.tpl');
print "Status: $status\r\nContent-type: text/html\r\n\r\n"; $__headers_sent = 1;
print $payload;
sub _url_decode($str) {
return unless defined $str;
$str =~ tr!+! !;
$str =~ s!%([[:xdigit:]][[:xdigit:]])!pack 'C', hex $1!ega;
$str
}
sub _query_string_unpack($str) {
Hash::MultiValue->new(map { my ($k, $v) = split '=', $_, 2; $k, _url_decode($v) } split m![&;]!, $str)
}
sub indent_wrap($padlen, $buf = '') {
my $pad = ' ' x $padlen;
my $out = '';
my $tty = 0;
foreach my $line (split /\n/, $buf) {
$tty ||= index($line, '<pre') != -1; # latch tty flag when detecting opening <pre> tag
$out .= ($tty? $line : $pad.$line)."\n";
$tty = 0 if index($line, '</pre>') != -1;
}
$out
}
sub template_broken(%args) {
print "Status: 503\r\nContent-type: text/html\r\n\r\n" unless $__headers_sent;
print "congrats, you broke my site! you get to keep the pieces.\n<pre>\n";
print $args{error};
print longmess();
print "</pre>\n";
exit 1;
}
sub emit_template($file, %vars) {
template_broken(error => "wow, the template doesn't exist") unless -e $file;
Text::Template->new(
TYPE => 'FILE',
SOURCE => $file,
DELIMITERS => [', '],
BROKEN => \&template_broken,
)->fill_in(PACKAGE => 'main', HASH => \%vars);
}
sub emit_title() { # XXX: gets called before emit_body so we have no idea what page we're on, find a way to defer this until post-render
return "eureka's homepage";
}
sub emit_body() {
# static route, static page
if (defined $pages{$path} && ! ref $pages{$path}) {
$status = 200;
return emit_template('./asset/template/'.$pages{$path})
}
# static route, dynamic page
return $pages{$path}->() if ref $pages{$path} eq 'CODE';
# dynamic route, dynamic page
foreach my $robj (@dynamic_pages) {
my ($route, $func) = @{ $robj };
if (my @args = ($path =~ $route)) {
return $func->(@args);
}
}
$status = 404;
return emit_template('./asset/template/404.tpl');
}
sub emit_ring() {
# ...
my %rings = (
'astral' => ['https://astr.al/', 'https://astr.al/asset/img/88x31/astral.gif'],
'benis' => ['https://astr.al/', 'https://astr.al/asset/img/88x31/benis.gif'],
'amd' => ['https://astr.al/', 'https://astr.al/asset/img/88x31/amd_powered.gif'],
'iris' => ['https://nilfm.cc/', 'https://astr.al/asset/img/88x31/nilfm.gif'],
'hinfo' => ['https://hinfo.network/', 'https://astr.al/asset/img/88x31/hinfo.gif'],
);
my @buf;
foreach my $ring (keys %rings) {
push @buf, emit_template('./asset/template/ring.tpl', name => $ring, uri => $rings{$ring}->[0], img => $rings{$ring}->[1]);
}
return join ' ~ ', @buf;
}
sub list_music() {
my $tracks = parse_tracks();
if (! ref $tracks) {
$status = 503;
return "parse_tracks(): $tracks";
}
$status = 200;
return emit_template('./asset/template/music_list.tpl', tracks => $tracks);
}
sub list_notes() {
my $notes = parse_notes();
if (! ref $notes) {
$status = 503;
return "parse_notes(): $notes";
}
$status = 200;
return emit_template('./asset/template/note_list.tpl', notes => $notes);
}
sub parse_notes() {
my %notes;
opendir my $dh, './notes/' or return $!;
foreach my $fn (readdir $dh) {
next if ($fn eq '.' || $fn eq '..');
next if ! -d "./notes/$fn";
my ($date, $subject) = split '_', $fn;
$notes{ $fn }{date} = $date;
$notes{ $fn }{subject} = $subject;
open my $fh, '<', "./notes/$fn/meta.txt" or do {
$notes{ $fn }{description} = "<em>entry metadata: $!</em>";
next;
}; # return "parse_meta($fn): $!";
my $buf; { local $/; $buf = <$fh>; }
close $fh;
chomp $buf;
$notes{ $fn }{description} = $buf;
}
return \%notes;
}
sub list_recipes() {
$status = 200;
"sorry, list not implemented"
}
sub get_music($track) {
# we avoid path traversal here because the httpd will parse and strip any ../../ in the path. parse_track uses 3 arg open so it isn't vuln to injection either
my $obj = parse_track($track.'.txt');
if (! ref $obj) {
$status = 404;
return "parse_track(): $obj";
}
$status = 200;
return emit_template('./asset/template/track.tpl', track => $obj);
}
sub parse_tracks() {
my %tracks;
opendir my $dh, './music/' or return "opendir: $!";
foreach my $fn (grep { /\.txt$/ } (readdir $dh)) {
my $tmp = parse_track($fn);
return "parse_track_metadata($fn): $tmp" unless ref $tmp;
$tracks{ $tmp->{name} } = $tmp;
}
return \%tracks;
}
sub parse_track($track) {
open my $fh, '<', "./music/$track" or return "open(music/$track): $!";
my $buf; { local $/; $buf = <$fh>; }
close $fh;
my $name = substr($track, 0, -4);
my ($header, $blurb, $text, $tracklist) = (split /\n\n/, $buf);
my ($date, $length, $location, $genre) = (split /\n/, $header);
return {
name => $name,
genre => $genre,
date => $date,
location => $location,
len => $length,
blurb => $blurb,
text => $text,
url => (sprintf '/music/%s.mp3', $name),
tracks => [ map { [ (split /\t+/, $_) ] } (split /\n/, $tracklist) ],
};
}
sub get_note($note) {
$status = 500;
# after 11 months of writing powershell i actually miss exceptions... :(
my $res = eval {
local $SIG{__DIE__};
if (! -d "./notes/$note/") {
$status = 404;
die "throw:journal entry not found\n";
}
if (! -e "./notes/$note/body.tpl") {
die "throw:journal entry exists, but has no body\n"
}
$status = 200;
return emit_template("./notes/$note/body.tpl");
};
if ($@) {
my $msg = $@;
if ($msg =~ m!^throw:(.+)$!) {
my $exc = $1;
return "sorry, $exc"
}
else {
return "uh-oh... <pre>$msg</pre>"
}
}
# all ok
return $res;
}
sub get_recipe($recipe) {
$status = 500;
my $res = eval {
local $SIG{__DIE__};
if (! -e "./recipes/$recipe.txt") {
die "throw:recipedir body not found\n"
}
$status = 200;
return emit_template("./asset/template/recipe.tpl", recipe => $recipe);
};
if ($@) {
my $msg = $@;
if ($msg =~ m!^throw:(.+)$!) {
my $exc = $1;
return "something didn't work right, maybe try again later? ($exc)"
}
else {
return "looks like this one was our fault ($msg)"
}
}
# all ok
return $res;
}