New guestbook
This commit is contained in:
parent
0167bb0a51
commit
d552a28ed9
|
|
@ -10,209 +10,5 @@ use utf8;
|
||||||
use open qw{:std :utf8}; # Fix "Wide character in print" warning
|
use open qw{:std :utf8}; # Fix "Wide character in print" warning
|
||||||
use CGI qw{-utf8}; # Needed to parse unicode params
|
use CGI qw{-utf8}; # Needed to parse unicode params
|
||||||
use CGI::Carp qw{fatalsToBrowser};
|
use CGI::Carp qw{fatalsToBrowser};
|
||||||
use XML::LibXML;
|
|
||||||
use WebService::Mattermost;
|
|
||||||
#use Data::Dumper; # Uncomment for debugging
|
|
||||||
|
|
||||||
## Variables ##
|
print CGI->redirect('https://guestbook.swagg.net');
|
||||||
|
|
||||||
# Create CGI object (query)
|
|
||||||
my $q = CGI->new();
|
|
||||||
|
|
||||||
# Open banned phrases and users files
|
|
||||||
open(my $thoughtCrimes, '.msg.bans') or die "$@";
|
|
||||||
open(my $nameBans, '.name.bans') or die "$@";
|
|
||||||
|
|
||||||
# Get creds file
|
|
||||||
my $dotfile = ".mmCreds.xml";
|
|
||||||
# Create XML::LibXML object
|
|
||||||
my $dom = XML::LibXML->load_xml(location => $dotfile);
|
|
||||||
# Grab the values from creds file
|
|
||||||
my %conf;
|
|
||||||
$conf{'authenticate'} = 1;
|
|
||||||
$conf{'username'} = $dom->findvalue('/credentials/username');
|
|
||||||
$conf{'password'} = $dom->findvalue('/credentials/password');
|
|
||||||
$conf{'base_url'} = $dom->findvalue('/credentials/base_url');
|
|
||||||
my $chan = $dom->findvalue('/credentials/channel_id');
|
|
||||||
my $spam = $dom->findvalue('/credentials/spam_chan_id');
|
|
||||||
# Create new WebService::Mattermost objects (mm && resource)
|
|
||||||
my $mm = WebService::Mattermost->new(%conf);
|
|
||||||
my $resource = $mm->api->posts;
|
|
||||||
|
|
||||||
## Functions ##
|
|
||||||
|
|
||||||
# Print the form
|
|
||||||
sub form_out {
|
|
||||||
# Begin printing the form
|
|
||||||
print $q->div(
|
|
||||||
{-class => "inner"},
|
|
||||||
|
|
||||||
# Little bit of text
|
|
||||||
$q->p("Use the form below to sign the guestbook and send
|
|
||||||
SwaggNet a message. Please be patient after submitting
|
|
||||||
as messages are checked for spam via cutting-edge
|
|
||||||
Swagg::AI blockchain techmology."),
|
|
||||||
"\n", # Newlines to make it pretty
|
|
||||||
|
|
||||||
# Opening form tag
|
|
||||||
$q->start_form(
|
|
||||||
-name => 'main',
|
|
||||||
-method => 'POST'
|
|
||||||
), "\n",
|
|
||||||
|
|
||||||
# Opening table tag
|
|
||||||
$q->start_table(), "\n",
|
|
||||||
|
|
||||||
# Name field
|
|
||||||
$q->Tr(
|
|
||||||
$q->th("Name:"),
|
|
||||||
$q->td(
|
|
||||||
$q->textfield(
|
|
||||||
-name => "name",
|
|
||||||
-size => 40
|
|
||||||
)
|
|
||||||
)
|
|
||||||
), "\n",
|
|
||||||
|
|
||||||
# Location field
|
|
||||||
$q->Tr(
|
|
||||||
$q->th("Location:"),
|
|
||||||
$q->td(
|
|
||||||
$q->textfield(
|
|
||||||
-name => "location",
|
|
||||||
-size => 40
|
|
||||||
)
|
|
||||||
)
|
|
||||||
), "\n",
|
|
||||||
|
|
||||||
# Message box
|
|
||||||
$q->Tr(
|
|
||||||
$q->th("Message:"),
|
|
||||||
$q->td(
|
|
||||||
$q->textarea(
|
|
||||||
-name => "message",
|
|
||||||
-columns => 50,
|
|
||||||
-rows => 10
|
|
||||||
)
|
|
||||||
)
|
|
||||||
), "\n",
|
|
||||||
|
|
||||||
# Submit button
|
|
||||||
$q->Tr(
|
|
||||||
$q->th(' '), # Non-breaking space
|
|
||||||
$q->td($q->submit(-value => "Submit"))
|
|
||||||
), "\n",
|
|
||||||
|
|
||||||
# Closing table tag
|
|
||||||
$q->end_table(), "\n",
|
|
||||||
|
|
||||||
# Closing form tag
|
|
||||||
$q->end_form(), "\n"
|
|
||||||
) . "\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
# Process params & say thanks
|
|
||||||
sub params_in {
|
|
||||||
# Params to variables
|
|
||||||
my $name = $q->param("name");
|
|
||||||
my $location = $q->param("location");
|
|
||||||
my $message = $q->param("message");
|
|
||||||
|
|
||||||
# Enforce max length for params
|
|
||||||
if (length($name) < 1 || length($name) >= 40) {
|
|
||||||
die "Name field must be between 1 and 40 characters\n"
|
|
||||||
}
|
|
||||||
elsif (length($location) < 1 || length($location) >= 40) {
|
|
||||||
die "Location field must be between 1 and 40 characters\n"
|
|
||||||
}
|
|
||||||
elsif (length($message) < 1 || length($message) >= 1900) {
|
|
||||||
die "Message field must be between 1 and 1900 characters\n"
|
|
||||||
}
|
|
||||||
|
|
||||||
# Variable set for banned user
|
|
||||||
my ($ban, $trigger);
|
|
||||||
|
|
||||||
# Parse the banned names list
|
|
||||||
chomp(my @nameBan = <$nameBans>);
|
|
||||||
for (@nameBan) {
|
|
||||||
last if $ban;
|
|
||||||
|
|
||||||
if ($name =~ /$_/i) {
|
|
||||||
$ban = 1;
|
|
||||||
$trigger = $_;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# Parse the banned phrases list
|
|
||||||
chomp(my @thoughtCrime = <$thoughtCrimes>);
|
|
||||||
for (@thoughtCrime) {
|
|
||||||
last if $ban;
|
|
||||||
|
|
||||||
if ($message =~ /$_/i) {
|
|
||||||
$ban = 1;
|
|
||||||
$trigger = $_;
|
|
||||||
}
|
|
||||||
}
|
|
||||||
|
|
||||||
# Send it unless ban is true; else send it to spam if spam chan is
|
|
||||||
# defined
|
|
||||||
unless ($ban) {
|
|
||||||
$resource->create(
|
|
||||||
{
|
|
||||||
channel_id => "$chan",
|
|
||||||
message => "$name from $location says: $message"
|
|
||||||
}
|
|
||||||
);
|
|
||||||
}
|
|
||||||
elsif ($spam) {
|
|
||||||
$resource->create(
|
|
||||||
{
|
|
||||||
channel_id => "$spam",
|
|
||||||
message => "$name from $location says: $message\n\n" .
|
|
||||||
"Spam trigger: `$trigger`"
|
|
||||||
}
|
|
||||||
);
|
|
||||||
}
|
|
||||||
|
|
||||||
# Say thanks (even if banned, e.g. shadow ban)
|
|
||||||
print $q->div(
|
|
||||||
{-class => "inner"},
|
|
||||||
$q->h2("Thanks!"),
|
|
||||||
$q->p("Your note has been sent, thanks for using the
|
|
||||||
guestbook.")
|
|
||||||
) . "\n";
|
|
||||||
}
|
|
||||||
|
|
||||||
## Begin script ##
|
|
||||||
|
|
||||||
# Print header
|
|
||||||
print $q->header(-charset => 'UTF-8');
|
|
||||||
|
|
||||||
# Print the head & title, begin the body
|
|
||||||
print $q->start_html(
|
|
||||||
-title => 'SwaggNet Guestbook',
|
|
||||||
-style => '/css/swagg.css'
|
|
||||||
);
|
|
||||||
|
|
||||||
# Heading
|
|
||||||
print $q->div(
|
|
||||||
{-class => "outer"},
|
|
||||||
$q->h1("Swagg::Net Guestbook"),
|
|
||||||
$q->br(),
|
|
||||||
"\n"
|
|
||||||
) . "\n";
|
|
||||||
|
|
||||||
# Process returned params if present; else print form
|
|
||||||
$q->param() ? params_in() : form_out();
|
|
||||||
|
|
||||||
# Print link to go back to homepage in footer
|
|
||||||
print $q->div(
|
|
||||||
{-class => "inner"},
|
|
||||||
$q->br(),
|
|
||||||
"<footer>Go back to", # CGI.pm doesn't have footer tag?
|
|
||||||
$q->a({-href => "/"}, "homepage"),
|
|
||||||
"</footer>\n" # Closing footer tag
|
|
||||||
);
|
|
||||||
|
|
||||||
# Close body
|
|
||||||
print $q->end_html() . "\n";
|
|
||||||
|
|
|
||||||
2
cpanfile
2
cpanfile
|
|
@ -4,5 +4,3 @@ requires 'Mojolicious';
|
||||||
requires 'Mojolicious::Plugin::CGI';
|
requires 'Mojolicious::Plugin::CGI';
|
||||||
requires 'Number::Format';
|
requires 'Number::Format';
|
||||||
requires 'Regexp::Common';
|
requires 'Regexp::Common';
|
||||||
requires 'WebService::Mattermost', '>= 0.25';
|
|
||||||
requires 'XML::LibXML';
|
|
||||||
|
|
|
||||||
12
t/basic.t
12
t/basic.t
|
|
@ -13,20 +13,18 @@ my %guest_form = (
|
||||||
message => 'Ayy... lmao'
|
message => 'Ayy... lmao'
|
||||||
);
|
);
|
||||||
|
|
||||||
# GET Requests
|
# Routes
|
||||||
for my $route (@routes) {
|
for my $route (@routes) {
|
||||||
$t->get_ok("/$route")->status_is(200)
|
$t->get_ok("/$route")->status_is(200)
|
||||||
}
|
}
|
||||||
|
|
||||||
# CGI Scripts
|
# CGI Scripts
|
||||||
for my $script (qw{guest whoami}) {
|
$t->get_ok('/cgi-bin/whoami.cgi')->status_is(200);
|
||||||
$t->get_ok("/cgi-bin/$script.cgi")->status_is(200)
|
$t->get_ok('/cgi-bin/guest.cgi' )->status_is(302);
|
||||||
}
|
|
||||||
# ULA Tool
|
# ULA Tool
|
||||||
$t->get_ok('/ula6', form => {macaddr => 'ea:88:5e:3f:a3:34'})->status_is(200);
|
$t->get_ok('/ula6', form => {macaddr => 'ea:88:5e:3f:a3:34'})->status_is(200);
|
||||||
|
|
||||||
# POST Requests
|
|
||||||
$t->post_ok('/cgi-bin/guest.cgi', form => \%guest_form)->status_is(200);
|
|
||||||
|
|
||||||
# Resume files
|
# Resume files
|
||||||
$t->get_ok('/resume/dbowling-resume.odt')->status_is(200);
|
$t->get_ok('/resume/dbowling-resume.odt')->status_is(200);
|
||||||
$t->get_ok('/resume/dbowling-resume.docx')->status_is(200);
|
$t->get_ok('/resume/dbowling-resume.docx')->status_is(200);
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue