Browse files

Tagging for 0.51 release.

  • Loading branch information...
2 parents b44bc9a + 5ee4a8c commit d1d8cd7015a25cb515b3d121f2b8d16e9d4bcd2f @rcaputo committed Oct 7, 2006
View
1 Makefile.PL
@@ -21,6 +21,7 @@ WriteMakefile(
'POE::Component::IRC' => 5.03,
'Perl::Tidy' => 1.46,
'Test::More' => 0.63,
+ 'Text::Template' => 1.44,
},
EXE_FILES => [ 'pastebot' ],
dist => {
View
2 pastebot
@@ -6,7 +6,7 @@ use strict;
use lib qw(. ./lib);
-our $VERSION = '0.50';
+our $VERSION = '0.51';
use File::Basename;
use Perl::Tidy;
View
19 trunk/MANIFEST
@@ -1,19 +0,0 @@
-# $Id$
-MANIFEST
-MANIFEST.SKIP
-Makefile.PL
-README
-TODO
-examples/pastebot.conf
-lib/Bot/Pastebot/Client/Irc.pm
-lib/Bot/Pastebot/Conf.pm
-lib/Bot/Pastebot/Data.pm
-lib/Bot/Pastebot/Server/Http.pm
-lib/Bot/Pastebot/WebUtil.pm
-pastebot
-static/highlights.css
-static/nopaste.gif
-static/paste-answer.html
-static/paste-form.html
-static/paste-lookup.html
-t/01_basic.t
View
8 trunk/MANIFEST.SKIP
@@ -1,8 +0,0 @@
-/\.#
-\.bak$
-\.orig$
-\.swp$
-\.tar\.gz$
-\bCVS\b
-^\.#
-~$
View
57 trunk/Makefile.PL
@@ -1,57 +0,0 @@
-# $Id$
-
-use warnings;
-use strict;
-
-use ExtUtils::MakeMaker;
-
-# Touch CHANGES so it exists.
-open(CHANGES, ">>CHANGES") and close CHANGES;
-
-WriteMakefile(
- NAME => 'Bot::Pastebot',
- AUTHOR => 'Rocco Caputo <rcaputo@cpan.org>',
- ABSTRACT => 'The original clipboard-to-chat gateway.',
- VERSION_FROM => 'pastebot',
- PREREQ_PM => {
- 'File::ShareDir' => 0.05,
- 'HTTP::Request' => 1.40,
- 'HTTP::Response' => 1.53,
- 'POE' => 0.38,
- 'POE::Component::IRC' => 5.03,
- 'Perl::Tidy' => 1.46,
- 'Test::More' => 0.63,
- 'Text::Template' => 1.44,
- },
- EXE_FILES => [ 'pastebot' ],
- dist => {
- COMPRESS => 'gzip -9f',
- SUFFIX => 'gz',
- PREOP => (
- 'svn-log.perl --repo https://thirdlobe.com/svn/pastebot ' .
- '| tee ./$(DISTNAME)-$(VERSION)/CHANGES > ./CHANGES'
- ),
- },
- depend => { pm_to_blib => 'setup_shared' },
-);
-
-sub MY::postamble {
- my $postamble = (
- "setup_shared:\n" .
- "\t\$(NOECHO) \$(ABSPERLRUN) -MExtUtils::Install -e " .
- "'pm_to_blib({\@ARGV}, '\\''\$(INST_LIB)/auto'\\'', " .
- "'\\''\$(PM_FILTER)'\\'')' -- \\\n"
- );
-
- my @to_copy;
- foreach (<static/*>) {
- next unless -f $_;
- next if /\~$/;
- s!^static/!!;
- push @to_copy, "static/$_ blib/arch/auto/Bot/Pastebot/$_";
- }
-
- $postamble .= "\t " . join("\\\n\t ", @to_copy) . "\n";
-
- return $postamble;
-}
View
145 trunk/README
@@ -1,145 +0,0 @@
-$Id$
-
------
-About
------
-
-Pastebot is a web-based dropbox for small texts. It's a gateway from
-your clipboard to your favorite IRC channel, and hopefully someday
-your favorite chat room.
-
-On the one hand, Pastebot is a web server that accepts "pastes" from
-one person to share with others. On the other hand, it is an IRC bot
-that announces paste URLs on appropriate channels.
-
--------------
-Quick install
--------------
-
-Most of Pastebot's files install the usual CPAN way, either by running
-"install Bot::Pastebot" from the CPAN shell or CPANPLUS, or by
-downloading the tarball and installing it manually:
-
- perl Makefile.PL
- make install
-
-You will also need to create a configuration file. A sample
-configuration file is in the examples directory, and the perldoc for
-pastebot describes each option.
-
- perldoc pastebot
-
-------------
-Requirements
-------------
-
-The installer will tell you what modules are necessary. The CPAN and
-CPANPLUS shells may install them automatically.
-
-----------------
-Use with Proxies
-----------------
-
-Pastebot is its own web server. It often cannot bind to port 80
-because some other web server is already there. The recommended port
-8888 may be hostile towards people behind firewalls.
-
-Apache users can use ProxyPass to map a directory on their port-80
-servers to a running pastebot. This feature requires Apache be built
-with both mod_proxy and mod_proxy_add_forward.c support, and that the
-add forward module come before the proxy module. For example:
-
- ./configure --enable-module=proxy \
- --activate-module=src/modules/extra/mod_proxy_add_forward.c \
- --enable-module=proxy_add_forward \
- --permute-module=proxy:END \
- ...
-
-Once Apache is built, you can create a virtual location for the proxy
-directory.
-
- <Location /pastebot>
- Order allow,deny
- Allow from all
- Deny from none
- </Location>
-
-Then you must tell Apache to forward any requests in the /pastebot/
-directory through to the local Pastebot server.
-
- ProxyPass /pastebot/ http://127.0.0.1:8888/
-
-Now people can use your pastebot on port 80. Be sure to set your
-pastebot's "iname" to match your proxy's address and path. For
-example:
-
- web_server
- ...
- proxy 127.0.0.1
- iname http://example.org/pastebot/
-
-The sample configuration file and Pastebot's documentation should
-explain how to do this.
-
-------
-Errors
-------
-
-Here are some common errors and solutions.
-
-* IRC client (NAME): socket error occurred: Can't assign requested address
-
- The most likely cause is an unknown host name, either for a local
- machine or a remote IRC server. If you have multiple servers
- specified, the bot will try the next server in approximately one
- minute.
-
-* Can't locate [some module] in @INC (@INC contains: ...)
-
- Somehow you managed to install one of pastebot's required modules
- without installing a module it in turn needs. You'll need to install
- [some module] manually and try again.
-
- This error may show up multiple times until each required module is
- installed. On a positive note, it should happen a lot less since
- Pastebot is distributed on the CPAN.
-
-* <something> section <name> is redefined at ##
-
- This error looks something like:
-
- pastes section pbtest is redefined at 68
- Compilation failed in require at Server/Web.pm line 18, <MPH> line 85.
- BEGIN failed--compilation aborted at Server/Web.pm line 18, <MPH> line 85.
- Compilation failed in require at ./pastebot.perl line 9, <MPH> line 85.
- BEGIN failed--compilation aborted at ./pastebot.perl line 9, <MPH> line 85.
-
- The exact filenames and line numbers will be different, of course.
-
- The error is caused when two or more configuration sections share
- the same name. To fix it, update your pastebot's configuration to
- use different names for each section, even if they are different
- types. For example:
-
- web_server
- name poenet
- ...
-
- irc
- name efnet
- ...
-
- pastes
- name neitherpoenetnorefnet
- ...
-
--------
-Support
--------
-
-Support is through Pastebot's tracker at Third Lobe's web site:
-http://thirdlobe.com/projects/pastebot
-
----
-End
----
View
276 trunk/TODO
@@ -1,276 +0,0 @@
-$Id$
-
----------------------------
-Migrating to a Real Tracker
----------------------------
-
-This list is shrinking, but Real Work is not being done! Rather, the
-missing ideas have been entered into Pastebot's tracker at The Third
-Lobe Corporation's web site. You can enter your favorite bug reports
-and wishes at http://thirdlobe.com/projects/pastebot ... and you can
-keep track of the project there.
-
-If you're feeling adventurous, you can also submit patches and new
-features through the tracker. We love your patches, yes we do, and
-you might just win a commit bit!
-
-------------------------------------
-Recent, Miscellaneous, Uncategorized
-------------------------------------
-
-This section is generic notes from discussions with other developers.
-
-Yaakov implemented a requested feature: A hit counter for each paste,
-so posters can see if anybody has looked at their posts. The obvious
-extension is to discount views from the poster's address. That way
-they don't need to count clicks and subtract things in their heads.
-
-There is a large list of source code beautifiers at
-<http://www.softpanorama.org/Tools/beautifiers.shtml>. Perhaps one or
-more of them may be used to beautify/highlight languages other than
-Perl.
-
-------------
-Yaakov Ideas
-------------
-
-Ideas while discussing features with Yaakov.
-
-Move directly from the paste form to the "fetch" page. Discard the
-answer page.
-
- Requires the direct URL to be placed on the "fetch" page.
-
-Allow channels to be embedded in the URL. This is a simple form of
-virtual hosting. More complex forms are also possible.
-
- Done properly, each channel might have its own database.
-
-Allow per-channel configurations, especially with the templates used
-to render pastes.
-
- Channel -> template -> HTML
-
- Save the channel in the paste record. This simplifies lookups to
- the point where you don't need to include the channel.
-
- Paste Number -> record -> channel -> template -> HTML
-
-Allow channel aliases, /js/ instead of /#javascript/, etc.
-
-If the channel is specified in the paste request, we can match it
-against the paste number. If they don't match, we can 404 it. In
-other words, don't show pastes from other channels. Some other form
-of vhosting might be more appropriate, such as using multiple ports or
-watching the Host header.
-
-Have the bot respond to permutations of "no paste" by presenting its
-URL. Also, the devoice- (or kick-) on-flood.
-
-Perform bans, modifications based on paste number, not IP address.
-That is, the paster's address is opaque to users, ops, but they can
-still prevent people from abusing the system.
-
- No plan of action is assigned to this task.
-
-Plan of action.
-
- 1. Store the channel with the paste record. Already done.
- 2. Move the "fetch paste" code to a subroutine.
- Call it from the "fetch paste" URL trigger and from the end of
- the "store paste" URL trigger. This replaces the
- template-answer.html already there.
- 3. Channel-based template lookup.
- Hash the network and channel names into a path.
- Attempt to read the template from there.
- If failure, read the template from a default location.
- Continue with the rendering as usual.
- 4. Create public message triggers for variations of "no paste".
- Build an URL from the %conf records associated with the network
- and channel where the bot heard the trigger.
-
------------------
-Time-limited keys
------------------
-
-Pastebot, like every other tool, has the ability to be abused. Adding
-time-limited keys for paste functions would probably reduce this
-potential at a cost of less convenience.
-
-*** Get a key from the bot.
-
-User sends:
-
- /msg [bot] getkey [channel]
- /msg [bot] getkey [nick]
-
-Bot returns:
-
- /msg [user] You may paste to [channel] via http://host/paste/[key]
- /msg [user] You may paste to [nick] via http://host/paste/[key]
-
-The [key] will be available for some time period, perhaps an hour,
-before it expires. [nick] or [channel] ops would be able to expire
-the key early and possibly block the user from acquiring new keys in
-the future.
-
-*** Give someone else a key.
-
-Public responses to a paste in progress might trigger key generation.
-Possible public messages to look for:
-
- [nick]: no paste!
- [nick]: don't paste!
- [nick]: no pasting!
- etc.
-
-The bot would generate a new key and /msg it to [nick]:
-
- /msg [nick] You may paste to [channel] via http://host/paste/[key]
-
-Whoever publicly admonished the paster would receive an
-acknowledgment:
-
- /msg [admonisher] I sent a paste key to [nick].
-
-*** Private proactive paste prevention.
-
-When someone has expressed the intention of pasting on-channel,
-another user can trigger pastebot to send them a key. This explains
-the bot's purpose and creates the paste key all at once.
-
-Someone's joined the channel and said:
-
- Can I show you some poetry I wrote?
-
-Someone on-channel catches this and rather than explain the bot types:
-
- /msg [bot] meet [nick]
-
-The bot then sends [nick] this private message:
-
- /msg [nick] [requester] has requested that you paste via the web.
- You may paste to [channel] by visiting http://host/paste/[key] ...
- To avoid future problems, /msg [bot] help
-
-*** Automatic key generation.
-
-The bot could incorporate flood detection. On detecting flood, it can
-automatically generate a key and send it to the offending person.
-Optionally, it can kick the flooder or set them -v.
-
-Channel ops would be upset if it did this to them, so detect and
-ignore +o people. :)
-
-*** Disallow anonymous paste.
-
-Remove the personal ID fields from the web form. Fill them in based
-on the channel and nick requesting keys through IRC. This is a small
-convenience as a side effect of the larger inconvenience of using
-one-time keys.
-
--------------
-Web accounts.
--------------
-
-Have persistent accounts with information about each user's viewing
-preferences. Per-viewer settings might include:
-
-Tab widths, although it may be better if the paster could specify
-this.
-
-Admin flags, so users can maintain the bot via the web.
-
-Having an authenticated web account means not needing to publish your
-IP address.
-
----------------------
-Paste Via Form Upload
----------------------
-
-Add a standard "Browse" button and filename field, and let people
-upload via the form.
-
-Also let people download verbatim with a link/button, to circumvent
-crappy HTML renderers.
-
----------------
-Paste Via Email
----------------
-
-This could be done now with a simple mail gateway, but there's
-considerations with being able to block access.
-
-Ideally it would unwrap attachments (maybe just the first attachment)
-if any and paste that rather than just pasting the source of the mail.
-
-It should be possible to block abuses in such a way that attempts to
-forge the From line fail.
-
-Suggested by Uri on Magnet #perl.
-
--------------------
-Paste via DCC chat.
--------------------
-
-Some people don't have web access, or have really bad browsers, or are
-too lazy to be bothered, or just prefer IRC over the web. Provide a
-way for them to DCC chat the bot and paste into it that way.
-
-User:
-
- /dcc [bot] chat
-
-The bot accepts the chat request. The user pastes their paste into
-the query, then closes the chat to save it.
-
- /dcc [bot] close
-
-The bot posts the paste on the web.
-
-*** Reverse DCC chat.
-
-Reverse DCC chat, like eggdrops do, will be needed for people behind
-firewalls.
-
- /ctcp [bot] chat
-
-Then the bot sends a DCC chat request to the user. The user accepts,
-and everything else happens as outlined above.
-
-*** Paste shell over DCC chat.
-
-Add a miniature paste editor so people can specify channel, summary,
-and other information for the paste. More importantly, let users
-paste multiple things per chat session.
-
- To: [channel or nick]
- Subject: A nice subject for the web listing/messaging.
-
- paste
- paste
- paste
-
-------------------
-Internal features.
-------------------
-
-These features are not necessarily visible to end users, but they'll
-make visible changes easier.
-
-*** Make databases persistent.
-
-User state tracking. Probably with POE::Component::UserBase.
-
-Replace the web server code with POE::Component::Server::HTTP.
-
-At one point someone suggested POE::Component::IRCbot. Find out if
-that's ready, and possibly use it in place of pastebot's code.
-
-Background name/address resolution. Replace numeric addresses with
-their proper machine names, using POE::Component::Client::DNS so
-things don't halt during the process.
-
-----
-End.
-----
View
36 trunk/examples/pastebot.conf
@@ -1,36 +0,0 @@
-# $Id$
-
-# Pastebot's documentation explains the various configuration knobs
-# you see here.
-
-web_server
- iface 10.0.0.201
- ifname 10.0.0.201
- iname http://10.0.0.201:8888/
- irc internal_irc
- name internal_web
- port 8888
-
-irc
- away saving humanity from evil paste
- ccinfo ACTION VERSION CLIENTINFO USERINFO
- channel pastebot
- channel poe
- cuinfo owned and operated by rcaputo <rcaputo@cpan.org>
- cver pastebot 1.0 <http://thirdlobe.com/projects/pastebot/>
- flags +i
- iname http://10.0.0.201:8888/
- join_cfg_only 1
- name internal_irc
- nick pastebot
- quit how will you live without me?
- server 10.0.0.25 6667
- uname pastebot
- localaddr 10.0.0.201
-
-pastes
- check 3600
- count 0
- expire 864000
- name pasty
- store /tmp/pastebot
View
586 trunk/lib/Bot/Pastebot/Client/Irc.pm
@@ -1,586 +0,0 @@
-# $Id$
-
-# Rocco's IRC bot stuff.
-
-package Bot::Pastebot::Client::Irc;
-
-use strict;
-
-use POE::Session;
-use POE::Component::IRC;
-
-sub MSG_SPOKEN () { 0x01 }
-sub MSG_WHISPERED () { 0x02 }
-sub MSG_EMOTED () { 0x04 }
-
-use Bot::Pastebot::Conf qw( get_names_by_type get_items_by_name );
-use Bot::Pastebot::Data qw(
- clear_channels fetch_paste_channel delete_paste
- clear_channel_ignores set_ignore clear_ignore get_ignores
- add_channel remove_channel
-);
-use Bot::Pastebot::Server::Http;
-
-my %helptext =
- (
- help => <<EOS,
-Commands: help, ignore, ignores, delete, about, uptime. Use help
-<command> for help on that command Other topics: about wildcards
-pasteids
-EOS
- ignore => <<EOS,
-Usage: ignore <wildcard> [<channels>] where <wildcard> is a wildcard
-IP address. It is only ignored for the given channels of those you
-are an operator on. Put - in front of a mask to remove it. "ignore -"
-to delete all ignores.
-EOS
- ignores => <<EOS,
-Usage: ignores <channel>. Returns a list of all ignores on <channel>.
-EOS
- delete => <<EOS,
-Usage: delete <pasteid> where <pasteid> has been pasted to the
-bot. You can only delete pastes to a channel you are an operator on.
-EOS
- about => <<EOS,
-pastebot is intended to reduce the incidence of pasting of large
-amounts of text to channels, and the aggravation caused those pastes.
-The user pastes to a web based form (see the /whois for this bot), and
-this bot announces the URL in the specified channel
-EOS
- wildcards => <<EOS,
-A set of 4 sets of digits or *. Valid masks: 168.76.*.*, 194.237.235.226
-Invalid masks: 168.76.*, *.76.235.226
-EOS
- pasteids => <<EOS,
-The digits in the paste URL after the host and port. eg. in
-http://nopaste.snit.ch:8000/22 the pasteid is 22
-EOS
- uptime => <<EOS,
-Display how long the program has been running and how much CPU it has
-consumed.
-EOS
- );
-
-# easy to enter, make it suitable to send
-for my $key (keys %helptext) {
- $helptext{$key} =~ tr/\n / /s;
- $helptext{$key} =~ s/\s+$//;
-}
-
-# Return this module's configuration.
-
-use Bot::Pastebot::Conf qw(SCALAR LIST REQUIRED);
-
-my %conf = (
- irc => {
- _class => __PACKAGE__,
- name => SCALAR | REQUIRED,
- server => LIST | REQUIRED,
- nick => LIST | REQUIRED,
- uname => SCALAR | REQUIRED,
- iname => SCALAR | REQUIRED,
- away => SCALAR | REQUIRED,
- flags => SCALAR,
- join_cfg_only => SCALAR,
- channel => LIST | REQUIRED,
- quit => SCALAR | REQUIRED,
- cuinfo => SCALAR | REQUIRED,
- cver => SCALAR | REQUIRED,
- ccinfo => SCALAR | REQUIRED,
- localaddr => SCALAR,
- },
-);
-
-sub get_conf { return %conf }
-
-#------------------------------------------------------------------------------
-
-sub initialize {
-
- # Build a map from IRC name to web server name I could add an extra
- # key to the irc sections but that would be redundant
-
- my %irc_to_web;
- foreach my $webserver (get_names_by_type('web_server')) {
- my %conf = get_items_by_name($webserver);
- $irc_to_web{$conf{irc}} = $webserver;
- }
-
- foreach my $server (get_names_by_type('irc')) {
- my %conf = get_items_by_name($server);
-
- my $web_alias = $irc_to_web{$server};
- my $irc = POE::Component::IRC->spawn();
-
- POE::Session->create(
- inline_states => {
- _start => sub {
- my ($kernel, $heap, $session) = @_[KERNEL, HEAP, SESSION];
-
- $kernel->alias_set( "irc_client_$server" );
- $irc->yield( register => 'all' );
-
- $heap->{server_index} = 0;
-
- # Keep-alive timer.
- $kernel->delay( autoping => 300 );
-
- $kernel->yield( 'connect' );
- },
-
- autoping => sub {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- $irc->yield( userhost => $heap->{my_nick})
- unless $heap->{seen_traffic};
- $heap->{seen_traffic} = 0;
- $kernel->delay( autoping => 300 );
- },
-
- connect => sub {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
-
- my $chosen_server = $conf{server}->[$heap->{server_index}];
- my $chosen_port = 6667;
- if ($chosen_server =~ s/[\s\:]+(\S+)\s*$//) {
- $chosen_port = $1;
- }
-
- # warn "server($chosen_server) port($chosen_port)";
-
- $heap->{nick_index} = 0;
- $heap->{my_nick} = $conf{nick}->[$heap->{nick_index}];
-
- $irc->yield(
- connect => {
- Debug => 1,
- Nick => $heap->{my_nick},
- Server => $chosen_server,
- Port => $chosen_port,
- Username => $conf{uname},
- Ircname => $conf{iname},
- LocalAddr => $conf{localaddr},
- }
- );
-
- $heap->{server_index}++;
- $heap->{server_index} = 0 if $heap->{server_index} >= @{$conf{server}};
- },
-
- join => sub {
- my ($kernel, $channel) = @_[KERNEL, ARG0];
- $irc->yield( join => $channel );
- },
-
- irc_msg => sub {
- my ($kernel, $heap, $sender, $msg) = @_[KERNEL, HEAP, ARG0, ARG2];
-
- my ($nick) = $sender =~ /^([^!]+)/;
- print "Message $msg from $nick\n";
-
- $msg = remove_colors($msg);
-
- if ($msg =~ /^\s*help(?:\s+(\w+))?\s*$/) {
- my $what = $1 || 'help';
- if ($helptext{$what}) {
- $irc->yield( privmsg => $nick, $helptext{$what} );
- }
- }
- elsif ($msg =~ /^\s*ignore\s/) {
- unless ($msg =~ /^\s*ignore\s+(\S+)(?:\s+(\S+))?\s*$/) {
- $irc->yield(
- privmsg => $nick, "Usage: ignore <wildcard> [<channels>]"
- );
- return;
- }
- my ($mask, $channels) = ($1, $2);
- unless (
- $mask =~ /^-?\d+(\.(\*|\d+)){3}$/ || $mask eq '-'
- ) {
- $irc->yield(
- privmsg => $nick, "Invalid wildcard. Try: help wildcards"
- );
- return;
- }
- my @igchans;
- if ($channels) {
- @igchans = split ',', lc $channels;
- }
- else {
- @igchans = map lc, channels($conf{name});
- }
- # only the channels the user is an operator on
- @igchans = grep {
- exists $heap->{users}{$_}{$nick}{mode} and
- $heap->{users}{$_}{$nick}{mode} =~ /@/
- } @igchans;
- @igchans or return;
-
- if ($mask eq '-') {
- for my $chan (@igchans) {
- clear_channel_ignores($conf{name}, $chan);
- print "Nick '$nick' deleted all ignores on $chan\n";
- }
- $irc->yield(
- privmsg => $nick => "Removed all ignores on @igchans"
- );
- }
- elsif ($mask =~ /^-(.*)$/) {
- my $clearmask = $1;
- for my $chan (@igchans) {
- clear_ignore($conf{name}, $chan, $clearmask);
- }
- $irc->yield(
- privmsg => $nick => "Removed ignore $clearmask on @igchans"
- );
- }
- else {
- for my $chan (@igchans) {
- set_ignore($conf{name}, $chan, $mask);
- }
- $irc->yield(
- privmsg => $nick => "Added ignore mask $mask on @igchans"
- );
- }
- }
- elsif ($msg =~ /^\s*ignores\s/) {
- unless ($msg =~ /^\s*ignores\s+(\#\S+)\s*$/) {
- $irc->yield( privmsg => $nick, "Usage: ignores <channel>" );
- return;
- }
- my $channel = lc $1;
- my @masks = get_ignores($conf{name}, $channel);
- unless (@masks) {
- $irc->yield( privmsg => $nick, "No ignores on $channel" );
- return;
- }
- my $text = join " ", @masks;
- substr($text, 100) = '...' unless length $text < 100;
- $irc->yield( privmsg => $nick, "Ignores on $channel are: $text" );
- }
- elsif ($msg =~ /^\s*delete\s/) {
- unless ($msg =~ /^\s*delete\s+(\d+)\s*$/) {
- $irc->yield( privmsg => $nick, "Usage: delete <pasteid>" );
- return;
- }
- my $pasteid = $1;
- my $paste_chan = fetch_paste_channel($pasteid);
-
- if (defined $paste_chan) {
- if ($heap->{users}{$paste_chan}{$nick}{mode} =~ /@/) {
- delete_paste($conf{name}, $paste_chan, $pasteid, $nick)
- or print "It didn't delete!\n";
- $irc->yield( privmsg => $nick => "Deleted paste $pasteid" );
- }
- else {
- $irc->yield(
- privmsg => $nick =>
- "Paste $pasteid was sent to $paste_chan - " .
- "you aren't a channel operator on $paste_chan"
- );
- }
- }
- else {
- $irc->yield( privmsg => $nick => "No such paste" );
- }
- }
- elsif ($msg =~ /^\s*uptime\s*$/) {
- my ($user_time, $system_time) = (times())[0,1];
- my $wall_time = (time() - $^T) || 1;
- my $load_average = sprintf(
- "%.4f", ($user_time+$system_time) / $wall_time
- );
- $irc->yield(
- privmsg => $nick,
- "I was started on " . scalar(gmtime($^T)) . " GMT. " .
- "I've been active for " . format_elapsed($wall_time, 2) . ". " .
- sprintf(
- "I have used about %.2f%% of a CPU during my lifespan.",
- (($user_time+$system_time)/$wall_time) * 100
- )
- );
- }
- },
-
- # negative on /whois
- irc_401 => sub {
- my ($kernel, $heap, $msg) = @_[KERNEL, HEAP, ARG1];
-
- my ($nick) = split ' ', $msg;
- delete $heap->{work}{lc $nick};
- },
-
- # Nick is in use
- irc_433 => sub {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
-
- $heap->{nick_index}++;
- my $newnick = $conf{nick}->[$heap->{nick_index} % @{$conf{nick}}];
- if ($heap->{nick_index} >= @{$conf{nick}}) {
- $newnick .= $heap->{nick_index} - @{$conf{nick}};
- $kernel->delay( ison => 120 );
- }
- $heap->{my_nick} = $newnick;
-
- warn "Nickclash, now trying $newnick\n";
- $irc->yield( nick => $newnick );
- },
-
- ison => sub {
- $irc->yield( ison => @{$conf{nick}} );
- },
-
- # ISON reply
- irc_303 => sub {
- my ($kernel, $heap, $nicklist) = @_[KERNEL, HEAP, ARG1];
-
- my @nicklist = split " ", lc $nicklist;
- for my $totry (@{$conf{nick}}) {
- unless (grep $_ eq lc $totry, @nicklist) {
- $irc->yield( nick => $totry );
- return;
- }
- }
- $kernel->delay( ison => 120 );
- },
-
- _stop => sub {
- my $kernel = $_[KERNEL];
- $irc->yield( quit => $conf{quit} );
- },
-
- _default => sub {
- my ($state, $event, $args, $heap) = @_[STATE, ARG0, ARG1, HEAP];
- $args ||= [ ];
- print "default $state = $event (@$args)\n";
- $heap->{seen_traffic} = 1;
- return 0;
- },
-
- irc_001 => sub {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
-
- if (defined $conf{flags}) {
- $irc->yield( mode => $heap->{my_nick} => $conf{flags} );
- }
- $irc->yield( away => $conf{away} );
-
- foreach my $channel (@{$conf{channel}}) {
- $kernel->yield( join => "\#$channel" );
- }
-
- $heap->{server_index} = 0;
- },
-
- announce => sub {
- my ($kernel, $heap, $channel, $message) =
- @_[KERNEL, HEAP, ARG0, ARG1];
- $irc->yield( privmsg => $channel => $message );
- },
-
- irc_ctcp_version => sub {
- my ($kernel, $sender) = @_[KERNEL, ARG0];
- my $who = (split /!/, $sender)[0];
- print "ctcp version from $who\n";
- $irc->yield( ctcpreply => $who, "VERSION $conf{cver}" );
- },
-
- irc_ctcp_clientinfo => sub {
- my ($kernel, $sender) = @_[KERNEL, ARG0];
- my $who = (split /!/, $sender)[0];
- print "ctcp clientinfo from $who\n";
- $irc->yield( ctcpreply => $who, "CLIENTINFO $conf{ccinfo}" );
- },
-
- irc_ctcp_userinfo => sub {
- my ($kernel, $sender) = @_[KERNEL, ARG0];
- my $who = (split /!/, $sender)[0];
- print "ctcp userinfo from $who\n";
- $irc->yield( ctcpreply => $who, "USERINFO $conf{cuinfo}" );
- },
-
- irc_invite => sub {
- my ($kernel, $who, $where) = @_[KERNEL, ARG0, ARG1];
- $where =~ s/^#//;
- if ( $conf{join_cfg_only} &&
- 1 > grep $_ eq $where, @{$conf{channel}} ) {
- print "$who invited me to $where, but i'm not allowed\n";
- }
- else {
- $kernel->yield( join => "#$where" )
- }
- },
-
- irc_join => sub {
- my ($kernel, $heap, $who, $where) = @_[KERNEL, HEAP, ARG0, ARG1];
- my ($nick) = $who =~ /^([^!]+)/;
- if (lc ($nick) eq lc($heap->{my_nick})) {
- add_channel($conf{name}, $where);
- $irc->yield( who => $where );
- }
- @{$heap->{users}{$where}{$nick}}{qw(ident host)} =
- (split /[!@]/, $who, 8)[1, 2];
- },
-
- irc_kick => sub {
- my ($kernel, $heap, $who, $where, $nick, $reason)
- = @_[KERNEL, HEAP, ARG0..ARG3];
- print "$nick was kicked from $where by $who: $reason\n";
- delete $heap->{users}{$where}{$nick};
- if (lc($nick) eq lc($heap->{my_nick})) {
- remove_channel($conf{name}, $where);
- delete $heap->{users}{$where};
- }
- # $kernel->delay( join => 15 => $where );
- },
-
- irc_quit => sub {
- my ($kernel, $heap, $who, $what) = @_[KERNEL, HEAP, ARG0, ARG1];
-
- my ($nick) = $who =~ /^([^!]+)/;
- for (keys %{$heap->{users}}) {
- delete $heap->{users}{$_}{$nick};
- }
- },
-
- irc_part => sub {
- my ($kernel, $heap, $who, $where) = @_[KERNEL, HEAP, ARG0, ARG1];
-
- my ($nick) = $who =~ /^([^!]+)/;
- delete $heap->{users}{$where}{$nick};
- },
-
- # who reply
- irc_352 => sub {
- my ($kernel, $heap, $what) = @_[KERNEL, HEAP, ARG1];
-
- my @reply = split " ", $what, 8;
- @{$heap->{users}{$reply[0]}{$reply[4]}}{qw(ident host mode real)} = (
- $reply[1], $reply[2], $reply[5], $reply[7]
- );
- },
-
- irc_mode => sub {
- my ($kernel, $heap, $issuer, $location, $modestr, @targets)
- = @_[KERNEL, HEAP, ARG0..$#_];
-
- my $set = "+";
- for (split //, $modestr) {
- $set = $_ if ($_ eq "-" or $_ eq "+");
- if (/[bklovehI]/) { # mode has argument
- my $target = shift @targets;
- if ($_ eq "o") {
- if ($set eq "+") {
- $heap->{users}{$location}{$target}{mode} .= '@'
- unless $heap->{users}{$location}{$target}{mode} =~ /\@/;
- }
- else {
- $heap->{users}{$location}{$target}{mode} =~ s/\@//;
- }
- }
- }
- }
- },
-
- # end of /names
- irc_315 => sub {},
- # end of /who
- irc_366 => sub {},
-
- irc_disconnected => sub {
- my ($kernel, $heap, $server) = @_[KERNEL, HEAP, ARG0];
- print "Lost connection to server $server.\n";
- clear_channels($conf{name});
- delete $heap->{users};
- $kernel->delay( connect => 60 );
- },
-
- irc_error => sub {
- my ($kernel, $heap, $error) = @_[KERNEL, HEAP, ARG0];
- print "Server error occurred: $error\n";
- clear_channels($conf{name});
- delete $heap->{users};
- $kernel->delay( connect => 60 );
- },
-
- irc_socketerr => sub {
- my ($kernel, $heap, $error) = @_[KERNEL, HEAP, ARG0];
- print "IRC client ($server): socket error occurred: $error\n";
- clear_channels($conf{name});
- delete $heap->{users};
- $kernel->delay( connect => 60 );
- },
-
- irc_public => sub {
- my ($kernel, $heap, $who, $where, $msg) = @_[KERNEL, HEAP, ARG0..ARG2];
- $who = (split /!/, $who)[0];
- $where = $where->[0];
- print "<$who:$where> $msg\n";
-
- $heap->{seen_traffic} = 1;
-
- # Do something with input here?
- # If so, remove colors from it first.
- },
- },
- );
- }
-}
-
-# Helper function. Display a number of seconds as a formatted period
-# of time. NOT A POE EVENT HANDLER.
-
-sub format_elapsed {
- my ($secs, $precision) = @_;
- my @fields;
-
- # If the elapsed time can be measured in weeks.
- if (my $part = int($secs / 604800)) {
- $secs %= 604800;
- push(@fields, $part . 'w');
- }
-
- # If the remaining time can be measured in days.
- if (my $part = int($secs / 86400)) {
- $secs %= 86400;
- push(@fields, $part . 'd');
- }
-
- # If the remaining time can be measured in hours.
- if (my $part = int($secs / 3600)) {
- $secs %= 3600;
- push(@fields, $part . 'h');
- }
-
- # If the remaining time can be measured in minutes.
- if (my $part = int($secs / 60)) {
- $secs %= 60;
- push(@fields, $part . 'm');
- }
-
- # If there are any seconds remaining, or the time is nothing.
- if ($secs || !@fields) {
- push(@fields, $secs . 's');
- }
-
- # Reduce precision, if requested.
- pop(@fields) while $precision and @fields > $precision;
-
- # Combine the parts.
- join(' ', @fields);
-}
-
-# Helper functions. Remove color codes from a message.
-
-sub remove_colors {
- my $msg = shift;
-
- # Indigoid supplied these regexps to extract colors.
- $msg =~ s/[\x02\x0F\x11\x12\x16\x1d\x1f]//g; # Regular attributes.
- $msg =~ s/\x03[0-9,]*//g; # mIRC colors.
- $msg =~ s/\x04[0-9a-f]+//ig; # Other colors.
-
- return $msg;
-}
-
-#------------------------------------------------------------------------------
-1;
View
175 trunk/lib/Bot/Pastebot/Conf.pm
@@ -1,175 +0,0 @@
-# $Id$
-
-# Configuration reading and holding.
-
-package Bot::Pastebot::Conf;
-
-use strict;
-use Carp qw(croak);
-
-use base qw(Exporter);
-our @EXPORT_OK = qw(
- get_names_by_type get_items_by_name load
- SCALAR LIST REQUIRED
-);
-
-sub SCALAR () { 0x01 }
-sub LIST () { 0x02 }
-sub REQUIRED () { 0x04 }
-
-my ($section, $section_line, %item, %config);
-
-sub flush_section {
- my ($conf_file, $conf_definition) = @_;
-
- if (defined $section) {
-
- foreach my $item_name (sort keys %{$conf_definition->{$section}}) {
- my $item_type = $conf_definition->{$section}->{$item_name};
-
- if ($item_type & REQUIRED) {
- die(
- "conf error: section `$section' ",
- "requires item `$item_name' ",
- "at $conf_file line $section_line\n"
- ) unless exists $item{$item_name};
- }
- }
-
- die(
- "conf error: section `$section' ",
- "item `$item{name}' is redefined at $conf_file line $section_line\n"
- ) if exists $config{$item{name}};
-
- my $name = $item{name};
- $config{$name} = { %item, type => $section };
- }
-}
-
-# Parse some configuration.
-
-sub get_conf_file {
- use Getopt::Std;
-
- my %opts;
- getopts("f:", \%opts);
-
- my $conf_file = $opts{"f"};
- my @conf;
- if (defined $conf_file) {
- @conf = ($conf_file);
- }
- else {
- my $f = "pastebot.conf";
- @conf = (
- "./$f", "$ENV{HOME}/$f", "/usr/local/etc/pastebot/$f", "/etc/pastebot/$f"
- );
-
- foreach my $try ( @conf ) {
- next unless -f $try;
- $conf_file = $try;
- last;
- }
- }
-
- unless (defined $conf_file and -f $conf_file) {
- die(
- "\nconf error: Cannot read configuration file [$conf_file], tried: @conf"
- );
- }
-
- return $conf_file;
-}
-
-sub load {
- my ($class, $conf_file, $conf_definition) = @_;
-
- open(MPH, "<", $conf_file) or
- die "\nconf error: Cannot open configuration file [$conf_file]: $!";
-
- while (<MPH>) {
- chomp;
- s/\s*\#.*$//;
- next if /^\s*$/;
-
- # Section item.
- if (/^\s+(\S+)\s+(.*?)\s*$/) {
-
- die(
- "conf error: ",
- "can't use an indented item ($1) outside of an unindented section ",
- "at $conf_file line $.\n"
- ) unless defined $section;
-
- die(
- "conf error: item `$1' does not belong in section `$section' ",
- "at $conf_file line $.\n"
- ) unless exists $conf_definition->{$section}->{$1};
-
- if (exists $item{$1}) {
- if (ref($item{$1}) eq 'ARRAY') {
- push @{$item{$1}}, $2;
- }
- else {
- die "conf error: option $1 redefined at $conf_file line $.\n";
- }
- }
- else {
- if ($conf_definition->{$section}->{$1} & LIST) {
- $item{$1} = [ $2 ];
- }
- else {
- $item{$1} = $2;
- }
- }
- next;
- }
-
- # Section leader.
- if (/^(\S+)\s*$/) {
-
- # A new section ends the previous one.
- flush_section($conf_file, $conf_definition);
-
- $section = $1;
- $section_line = $.;
- undef %item;
-
- # Pre-initialize any lists in the section.
- while (my ($item_name, $item_flags) = each %{$conf_definition->{$section}}) {
- if ($item_flags & LIST) {
- $item{$item_name} = [];
- }
- }
-
- next;
- }
-
- die "conf error: syntax error in $conf_file at line $.\n";
- }
-
- flush_section($conf_file);
-
- close MPH;
-}
-
-sub get_names_by_type {
- my $type = shift;
- my @names;
-
- while (my ($name, $item) = each %config) {
- next unless $item->{type} eq $type;
- push @names, $name;
- }
-
- return @names if @names;
- croak "no configuration type matching \"$type\"";
-}
-
-sub get_items_by_name {
- my $name = shift;
- return () unless exists $config{$name};
- return %{$config{$name}};
-}
-
-1;
View
325 trunk/lib/Bot/Pastebot/Data.pm
@@ -1,325 +0,0 @@
-# $Id$
-
-# Data management.
-
-package Bot::Pastebot::Data;
-
-use warnings;
-use strict;
-
-use Carp qw(croak);
-use POE;
-use Storable;
-use Bot::Pastebot::Conf qw( get_names_by_type get_items_by_name );
-
-use base qw(Exporter);
-
-our @EXPORT_OK = qw(
- store_paste fetch_paste delete_paste list_paste_ids
- delete_paste_by_id fetch_paste_channel clear_channel_ignores
- set_ignore clear_ignore get_ignores is_ignored channels add_channel
- remove_channel clear_channels
-);
-
-# Paste data members.
-
-sub PASTE_TIME () { 0 }
-sub PASTE_SUMMARY () { 1 }
-sub PASTE_ID () { 2 }
-sub PASTE_NETWORK () { 3 }
-sub PASTE_CHANNEL () { 4 }
-sub PASTE_HOST () { 5 }
-
-my $id_sequence = 0;
-my %paste_cache;
-my %ignores; # $ignores{$ircnet}{lc $channel} = [ mask, mask, ... ];
-my %channels;
-
-# Return this module's configuration.
-
-use Bot::Pastebot::Conf qw(SCALAR REQUIRED);
-
-my %conf = (
- pastes => {
- _class => __PACKAGE__,
- name => SCALAR | REQUIRED,
- check => SCALAR,
- expire => SCALAR,
- count => SCALAR,
- throttle => SCALAR,
- store => SCALAR | REQUIRED,
- },
-);
-
-sub get_conf { return %conf }
-
-# Return a list of all paste IDs.
-
-sub list_paste_ids {
- return keys %paste_cache;
-}
-
-
-{
- my $store = ''; # Static variable in pastestore()
-
- sub pastestore {
-
- # already set, return value
-
- $store and return $store;
-
- my @names = get_names_by_type('pastes');
- return unless @names;
- my %conf = get_items_by_name($names[0]);
- $store = $conf{store};
- }
-}
-
-# Remove pastes that are too old (if applicable).
-
-sub check_paste_count {
- my @names = get_names_by_type('pastes');
- return unless @names;
- my %conf = get_items_by_name($names[0]);
- return unless %conf && $conf{'count'};
- return if (scalar keys %paste_cache < $conf{'count'});
- my $oldest = (
- sort {
- $paste_cache{$a}->[PASTE_TIME] > $paste_cache{$b}->[PASTE_TIME]
- } keys %paste_cache
- )[0];
- delete_paste_by_id($oldest);
-}
-
-# Save paste, returning an ID.
-
-sub store_paste {
- my ($id, $summary, $paste, $ircnet, $channel, $ipaddress) = @_;
- check_paste_count();
-
- my $new_id = ++$id_sequence;
- $paste_cache{$new_id} = [
- time(), # PASTE_TIME
- $summary, # PASTE_SUMMARY
- $id, # PASTE_ID
- $ircnet, # PASTE_NETWORK
- lc($channel), # PASTE_CHANNEL
- $ipaddress, # PASTE_HOST
- ];
-
- my $dir = pastestore();
-
- store \%paste_cache, "$dir/Index";
-
- open BODY, ">", "$dir/$new_id" or warn "I cannot store paste $new_id: $!";
- binmode(BODY);
- print BODY $paste;
- close BODY;
-
- return $new_id;
-}
-
-# Fetch paste by ID.
-
-sub fetch_paste {
- my $id = shift;
- my $paste = $paste_cache{$id};
- return(undef, undef, undef) unless defined $paste;
-
- my $dir = pastestore();
-
- unless(open BODY, "<", "$dir/$id") {
- warn "Error opening paste $id: $!";
- return(undef, undef, undef);
- }
- local $/ = undef;
-
- return(
- $paste->[PASTE_ID],
- $paste->[PASTE_SUMMARY],
- <BODY>
- );
-}
-
-# Fetch the channel a paste was meant for.
-
-sub fetch_paste_channel {
- my $id = shift;
- return $paste_cache{$id}->[PASTE_CHANNEL];
-}
-
-sub delete_paste_by_id {
- my $id = shift;
- delete $paste_cache{$id};
-
- my $dir = pastestore;
-
- unlink "$dir/$id" or warn "Problem removing paste $id: $!";
-
- store \%paste_cache, "$dir/Index";
-}
-
-# Delete a possibly sensitive or offensive paste.
-
-sub delete_paste {
- my ($ircnet, $channel, $id, $bywho) = @_;
-
- my $dir = pastestore();
-
- if (
- $paste_cache{$id}[PASTE_NETWORK] eq $ircnet &&
- $paste_cache{$id}[PASTE_CHANNEL] eq lc $channel
- ) {
- # place the blame where it belongs
- unless (open BODY, ">", "$dir/$id") {
- warn "Error deleting body for paste $id: $!";
- return;
- }
- print BODY "Deleted by $bywho";
- }
- else {
- return;
- }
-}
-
-# Manage channel/IRC network based ignores of http requestors.
-
-sub _convert_mask {
- my $mask = shift;
-
- $mask =~ s/\./\\./g;
- $mask =~ s/\*/\\d+/g;
-
- $mask;
-}
-
-sub is_ignored {
- my ($ircnet, $channel, $host) = @_;
-
- $ignores{$ircnet}{lc $channel} && @{$ignores{$ircnet}{lc $channel}}
- or return;
-
- for my $mask (@{$ignores{$ircnet}{lc $channel}}) {
- $host =~ /^$mask$/ and return 1;
- }
-
- return;
-}
-
-sub set_ignore {
- my ($ircnet, $channel, $mask) = @_;
-
- $mask = _convert_mask($mask);
-
- # remove any existing mask - so it's not fast
- @{$ignores{$ircnet}{lc $channel}} =
- grep $_ ne $mask, @{$ignores{$ircnet}{lc $channel}};
- push @{$ignores{$ircnet}{lc $channel}}, $mask;
- store \%ignores, "ignorelist";
-}
-
-sub clear_ignore {
- my ($ircnet, $channel, $mask) = @_;
-
- $mask = _convert_mask($mask);
-
- @{$ignores{$ircnet}{lc $channel}} =
- grep $_ ne $mask, @{$ignores{$ircnet}{lc $channel}};
- store \%ignores, "ignorelist";
-}
-
-sub get_ignores {
- my ($ircnet, $channel) = @_;
-
- $ignores{$ircnet}{lc $channel} or return;
-
- my @masks = @{$ignores{$ircnet}{lc $channel}};
-
- for (@masks) {
- s/\\d\+/*/g;
- s/\\././g;
- }
-
- @masks;
-}
-
-sub clear_channel_ignores {
- my ($ircnet, $channel) = @_;
-
- $ignores{$ircnet}{lc $channel} = [];
- store \%ignores, "ignorelist";
-}
-
-# Channels we're on
-
-sub channels {
- my $network = lc(shift);
- return sort keys %{$channels{$network}};
-}
-
-sub clear_channels {
- my $network = lc(shift);
- %{$channels{$network}} = ();
- return if keys %{$channels{$network}}; # Should never happen
- return 1;
-}
-
-sub add_channel {
- my ($network, $channel) = @_;
- $network = lc($network);
- $channel = lc($channel);
- $channels{$network}{$channel} = 1;
-}
-
-sub remove_channel {
- my ($network, $channel) = @_;
- $network = lc($network);
- $channel = lc($channel);
- delete $channels{$network}{$channel}; # returns automatically
-}
-
-# Init stuff
-
-sub initialize {
- my $dir = pastestore();
-
- unless (-d $dir) {
- use File::Path;
- eval { mkpath $dir };
- if ($@) {
- die "Couldn't create directory $dir: $@";
- }
- }
-
- if (-e "$dir/Index") {
- %paste_cache = %{retrieve "$dir/Index"};
- $id_sequence = (sort keys %paste_cache)[-1];
- }
- if (-e "ignorelist") {
- %ignores = %{retrieve 'ignorelist'};
- }
-
- my @pastes = get_names_by_type('pastes');
- if (@pastes) {
- my %conf = get_items_by_name($pastes[0]);
- if ($conf{'check'} && $conf{'expire'}) {
- POE::Session->create(
- inline_states => {
- _start => sub { $_[KERNEL]->delay( ticks => $conf{'check'} ); },
- ticks => sub {
- for (keys %paste_cache) {
- next unless (
- (time - $paste_cache{$_}->[PASTE_TIME]) > $conf{'expire'}
- );
- delete_paste_by_id($_);
- }
- $_[KERNEL]->delay( ticks => $conf{'check'} );
- },
- },
- );
- }
- }
-}
-
-1;
View
675 trunk/lib/Bot/Pastebot/Server/Http.pm
@@ -1,675 +0,0 @@
-# $Id$
-
-# The web server portion of our program.
-
-package Bot::Pastebot::Server::Http;
-
-use warnings;
-use strict;
-
-use Socket;
-use HTTP::Negotiate;
-use HTTP::Response;
-
-use POE::Session;
-use POE::Component::Server::TCP;
-use POE::Filter::HTTPD;
-use File::ShareDir qw(dist_dir);
-
-use Bot::Pastebot::Conf qw( get_names_by_type get_items_by_name );
-use Bot::Pastebot::WebUtil qw(
- static_response parse_content parse_cookie dump_content html_encode
- is_true cookie
-);
-use Bot::Pastebot::Data qw( channels store_paste fetch_paste is_ignored );
-
-use Perl::Tidy;
-
-# Dumps the request to stderr.
-sub DUMP_REQUEST () { 0 }
-
-sub WEB_SERVER_TYPE () { "web_server" }
-
-sub PAGE_FOOTER () {
- (
- "<div align=right><font size='-1'>" .
- "<a href='http://sf.net/projects/pastebot/'>Pastebot</a>" .
- " is powered by " .
- "<a href='http://poe.perl.org/'>POE</a>.</font></div>"
- )
-}
-
-# Return this module's configuration.
-
-use Bot::Pastebot::Conf qw(SCALAR REQUIRED);
-
-my %conf = (
- web_server => {
- _class => __PACKAGE__,
- name => SCALAR | REQUIRED,
- iface => SCALAR,
- ifname => SCALAR,
- port => SCALAR | REQUIRED,
- irc => SCALAR | REQUIRED,
- proxy => SCALAR,
- iname => SCALAR,
- static => SCALAR,
- },
-);
-
-sub get_conf { return %conf }
-
-#------------------------------------------------------------------------------
-# A web server.
-
-# Start an HTTPD session. Note that this handler receives both the
-# local bind() address ($my_host) and the public server address
-# ($my_ifname). It uses $my_ifname to build HTML that the outside
-# world can see.
-
-sub httpd_session_started {
- my (
- $heap,
- $socket, $remote_address, $remote_port,
- $my_name, $my_host, $my_port, $my_ifname, $my_isrv,
- $proxy, $my_iname, $my_static,
- ) = @_[HEAP, ARG0..$#_];
-
- # TODO: I think $my_host is obsolete. Maybe it can be removed, and
- # $my_ifname can be used exclusively?
-
- $heap->{my_host} = $my_host;
- $heap->{my_port} = $my_port;
- $heap->{my_name} = $my_name;
- $heap->{my_inam} = $my_ifname;
- $heap->{my_iname} = $my_iname;
- $heap->{my_isrv} = $my_isrv;
- $heap->{my_proxy} = $proxy;
- $heap->{my_static} = $my_static;
-
- $heap->{remote_addr} = inet_ntoa($remote_address);
- $heap->{remote_port} = $remote_port;
-
- $heap->{wheel} = new POE::Wheel::ReadWrite(
- Handle => $socket,
- Driver => new POE::Driver::SysRW,
- Filter => new POE::Filter::HTTPD,
- InputEvent => 'got_query',
- FlushedEvent => 'got_flush',
- ErrorEvent => 'got_error',
- );
-}
-
-# An HTTPD response has flushed. Stop the session.
-sub httpd_session_flushed {
- delete $_[HEAP]->{wheel};
-}
-
-# An HTTPD session received an error. Stop the session.
-sub httpd_session_got_error {
- my ($session, $heap, $operation, $errnum, $errstr) = @_[
- SESSION, HEAP, ARG0, ARG1, ARG2
- ];
- warn(
- "connection session ", $session->ID,
- " got $operation error $errnum: $errstr\n"
- );
- delete $heap->{wheel};
-}
-
-# Process HTTP requests.
-sub httpd_session_got_query {
- my ($kernel, $heap, $request) = @_[KERNEL, HEAP, ARG0];
-
- ### Log the request.
-
- # Space-separated list:
- # Remote address (client address)
- # -
- # -
- # [GMT date in brackets: DD/Mon/CCYY:HH:MM:SS -0000]
- # "GET url HTTP/x.y" <-- in quotes
- # response code
- # response size
- # referer
- # user-agent string
-
- ### Responded with an error. Send it directly.
-
- if ($request->isa("HTTP::Response")) {
- $heap->{wheel}->put($request);
- return;
- }
-
- ### These requests don't require authentication.
-
- my $url = $request->url() . '';
-
- # strip multiple // to prevent errors
- $url =~ s,//+,/,;
-
- ### Fetch the highlighted style sheet.
-
- if ($url eq '/style') {
- my $response = static_response( "$heap->{my_static}/highlights.css", { } );
- $heap->{wheel}->put( $response );
- return;
- }
-
- ### Fetch some kind of data.
-
- if ($url =~ m{^/static/(.+?)\s*$}) {
- # TODO - Better path support?
- my $filename = $1;
- $filename =~ s{/\.+}{/}g; # Remove ., .., ..., etc.
- $filename =~ s{/+}{/}g; # Combine // into /
- $filename = "$heap->{my_static}/$filename";
-
- my ($code, $type, $content);
-
- if (-e $filename) {
- if (open(FILE, "<$filename")) {
- $code = 200;
- local $/;
- $content = <FILE>;
- close FILE;
-
- # TODO - Better type support.
- if ($filename =~ /\.(gif|jpe?g|png)$/i) {
- $type = lc($1);
- $type = "jpeg" if $type eq "jpg";
- $type = "image/$1";
- }
- }
- else {
- $code = 500;
- $type = "text/html";
- $content = (
- "<html><head><title>File Error</title></head>" .
- "<body>Error opening $filename: $!</body></html>"
- );
- }
- }
- else {
- $code = 404;
- $type = "text/html";
- $content = (
- "<html><head><title>404 File Not Found</title></head>" .
- "<body>File $filename does not exist.</body></html>"
- );
- }
-
- my $response = HTTP::Response->new($code);
- $response->push_header('Content-type', $type);
- $response->content($content);
- $heap->{wheel}->put( $response );
- return;
- }
-
- ### Store paste.
-
- if ($url =~ m,/paste$,) {
- my $content = parse_content($request->content());
-
- if (defined $content->{paste} and length $content->{paste}) {
- my $channel = $content->{channel};
- defined $channel or $channel = "";
- $channel =~ tr[\x00-\x1F\x7F][]d;
-
- my $remote_addr = $heap->{remote_addr};
- if ($heap->{my_proxy} && $remote_addr eq $heap->{my_proxy}) {
- # apache sets the X-Forwarded-For header to a list of the
- # IP addresses that were forwarded from/to
- my $forwarded = $request->headers->header('X-Forwarded-For');
- if ($forwarded) {
- ($remote_addr) = $forwarded =~ /([^,\s]+)$/;
- }
- # else must be local?
- }
-
- my $error = "";
- if (length $channel) {
- # See if it matches.
- if (is_ignored($heap->{my_isrv}, $channel, $remote_addr)) {
- $error = (
- "<p><b><font size='+1' color='#800000'>" .
- "Your IP address has been blocked from pasting to $channel." .
- "</font></b></p>"
- );
- $channel = "";
- }
- }
-
- # Goes as a separate block.
- if (length $channel) {
- unless (grep $_ eq $channel, channels($heap->{my_isrv})) {
- $error = (
- "<p><b><font size='+1' color='#800000'>" .
- "I'm not on $channel." .
- "</font></b></p>"
- );
- $channel = "";
- }
- }
-
- my $nick = $content->{nick};
- $nick = "" unless defined $nick;
- $nick =~ tr[\x00-\x1F\x7F][ ]s;
- $nick =~ s/\s+/ /g;
- $nick =~ s/^\s+//;
- $nick =~ s/\s+$//;
- $nick = html_encode($nick);
-
- if (length $nick) {
- $nick = qq("$nick");
- }
- else {
- $nick = "Someone";
- }
-
- $nick .= " at $remote_addr";
-
- # <CanyonMan> how about adding a form field with a "Subject"
- # line ?
-
- my $summary = $content->{summary};
- $summary = "" unless defined $summary;
- $summary =~ tr[\x00-\x1F\x7F][ ]s;
- $summary =~ s/\s+/ /g;
- $summary =~ s/^\s+//;
- $summary =~ s/\s+$//;
-
- # <TorgoX> [...] in the absence of anything in the subject, it
- # falls back to [the first 30 characters of what's pasted]
-
- my $paste = $content->{paste};
- unless (length($summary)) {
- $summary = $paste;
- $summary =~ s/\s+/ /g;
- $summary =~ s/^\s+//;
- $summary = substr($summary, 0, 30);
- $summary =~ s/\s+$//;
- }
-
- $summary = "something" unless length $summary;
- my $html_summary = html_encode($summary);
-
- my $id = store_paste(
- $nick, $html_summary, $paste,
- $heap->{my_isrv}, $channel, $remote_addr
- );
- my $paste_link;
- if (defined $heap->{my_iname}) {
- $paste_link = (
- $heap->{my_iname} .
- (
- ($heap->{my_iname} =~ m,/$,)
- ? $id
- : "/$id"
- )
- );
- }
- else {
- $paste_link = "http://$heap->{my_inam}:$heap->{my_port}/$id";
- }
-
- # show number of lines in paste in channel announce
- my $paste_lines = 0;
- $paste_lines++ for $paste =~ m/^.*$/mg;
-
- $paste = fix_paste($paste, 0, 0, 0, 0);
-
- my $response = static_response(
- "$heap->{my_static}/paste-answer.html",
- { paste_id => $id,
- error => $error,
- paste_link => $paste_link,
- nick => $nick,
- summary => $summary,
- paste => $paste,
- footer => PAGE_FOOTER,
- }
- );
-
- if ($channel and $channel =~ /^\#/) {
- $kernel->post(
- "irc_client_$heap->{my_isrv}" => announce =>
- $channel,
- "$nick pasted \"$summary\" ($paste_lines line" .
- ($paste_lines == 1 ? '' : 's') . ") at $paste_link"
- );
- }
- else {
- warn "channel $channel was strange";
- }
-
- $heap->{wheel}->put( $response );
- return;
- }
-
- # Error goes here.
- }
-
- ### Fetch paste.
-
- if ($url =~ m{^/(\d+)(?:\?(.*?)\s*)?$}) {
- my ($num, $params) = ($1, $2);
- my ($nick, $summary, $paste) = fetch_paste($num);
-
- if (defined $paste) {
-
- my $cookie = parse_cookie($request->headers->header('Cookie'));
- my $query = parse_content($params);
-
- ### Make the paste pretty.
-
- my $ln = exists $query ->{ln} ? is_true($query ->{ln}) :
- exists $cookie->{ln} ? is_true($cookie->{ln}) : 0;
- my $tidy = exists $query ->{tidy} ? is_true($query ->{tidy}) :
- exists $cookie->{tidy} ? is_true($cookie->{tidy}) : 0;
- my $hl = exists $query ->{hl} ? is_true($query ->{hl}) :
- exists $cookie->{hl} ? is_true($cookie->{hl}) : 0;
- my $tx = exists $query ->{tx} ? is_true($query ->{tx}) :
- exists $cookie->{tx} ? is_true($cookie->{tx}) : 0;
- my $wr = exists $query ->{wr} ? is_true($query ->{wr}) :
- exists $cookie->{wr} ? is_true($cookie->{wr}) : 0;
- my $store = is_true($query->{store});
-
- my $variants = [
- ['html', 1.000, 'text/html', undef, 'us-ascii', 'en', undef],
- ['text', 0.950, 'text/plain', undef, 'us-ascii', 'en', undef],
- ];
- my $choice = choose($variants, $request);
- $tx = 1 if $choice && $choice eq 'text';
-
- $paste = fix_paste($paste, $ln, $tidy, $hl, $wr) unless $tx;
-
- # Spew the paste.
-
- my $response;
- if ($tx) {
- $response = HTTP::Response->new(200);
- $response->push_header( 'Content-type', 'text/plain' );
- $response->content($paste);
- }
- else {
- $response = static_response(
- "$heap->{my_static}/paste-lookup.html",
- { bot_name => $heap->{my_name},
- paste_id => $num,
- nick => $nick,
- summary => $summary,
- paste => $paste,
- footer => PAGE_FOOTER,
- tidy => ( $tidy ? "checked" : "" ),
- hl => ( $hl ? "checked" : "" ),
- ln => ( $ln ? "checked" : "" ),
- tx => ( $tx ? "checked" : "" ),
- wr => ( $wr ? "checked" : "" ),
- }
- );
- if ($store) {
- $response->push_header('Set-Cookie'=>cookie(tidy=>$tidy, $request));
- $response->push_header('Set-Cookie' => cookie(hl => $hl, $request));
- $response->push_header('Set-Cookie' => cookie(wr => $wr, $request));
- $response->push_header('Set-Cookie' => cookie(ln => $ln, $request));
- }
- }
-
- $heap->{wheel}->put( $response );
- return;
- }
-
- my $response = HTTP::Response->new(404);
- $response->push_header( 'Content-type', 'text/html' );
- $response->content(
- "<html>" .
- "<head><title>Paste Not Found</title></head>" .
- "<body><p>Paste not found.</p></body>" .
- "</html>"
- );
- $heap->{wheel}->put( $response );
- return;
- }
-
- ### Root page.
-
- # 2003-12-22 - RC - Added _ and - as legal characters for channel
- # names. What else?
- if ($url =~ m,^/([\_\-\w]+)?,) {
-
- # set default channel from request URL, if possible
- my $prefchan = $1;
- if (defined $prefchan) {
- $prefchan =~ s/^#*/#/;
- }
- else {
- $prefchan = '';
- }
-
- # Dynamically build the channel options from the configuration
- # file's list.
- my @channels = channels($heap->{my_isrv});
- unshift @channels, '';
-
- @channels = map {
- qq(<option value="$_")
- . ($_ eq $prefchan ? ' selected' : '')
- . '>'
- . ($_ eq '' ? '(none)' : $_)
- . '</option>'
- } sort @channels;
-
- # Build content.
-
- my $response = static_response(
- "$heap->{my_static}/paste-form.html",
- { bot_name => $heap->{my_name},
- channels => "@channels",
- footer => PAGE_FOOTER,
- }
- );
- $heap->{wheel}->put($response);
- return;
- }
-
- ### Default handler dumps everything it can about the request.
-
- my $response = HTTP::Response->new( 200 );
- $response->push_header( 'Content-type', 'text/html' );
-
- # Many of the headers dumped here are undef. We turn off warnings
- # here so the program doesn't constantly squeal.
-
- local $^W = 0;
-
- $response->content(
- "<html><head><title>Strange Request Dump</title></head>" .
- "<body>" .
- "<p>" .
- "Your request was strange. " .
- "Here is everything I could figure out about it:" .
- "</p>" .
- "<table border=1>" .
-
- join(
- "",
- map {
- "<tr><td><header></td><td>" . $request->$_() . "</td></tr>"
- } qw(
- authorization authorization_basic content_encoding
- content_language content_length content_type content date
- expires from if_modified_since if_unmodified_since
- last_modified method protocol proxy_authorization
- proxy_authorization_basic referer server title url user_agent
- www_authenticate
- )
- ) .
-
- join(
- "",
- map {
- "<tr><td><header></td><td>" . $request->header($_) . "</td></tr>"
- } qw(
- Accept Connection Host
- username opaque stale algorithm realm uri qop auth nonce
- cnonce nc response
- )
- ) .
-
- "</table>" .
-
- dump_content($request->content()) .
-
- "<p>Request as string=" . $request->as_string() . "</p>" .
-
- "</body></html>"
- );
-
- # A little debugging here.
- if (DUMP_REQUEST) {
- my $request_as_string = $request->as_string();
- warn unpack('H*', $request_as_string), "\n";
- warn "Request has CR.\n" if $request_as_string =~ /\x0D/;
- warn "Request has LF.\n" if $request_as_string =~ /\x0A/;
- }
-
- $heap->{wheel}->put( $response );
- return;
-}
-
-# Start the HTTPD server.
-
-sub initialize {
- foreach my $server (get_names_by_type(WEB_SERVER_TYPE)) {
- my %conf = get_items_by_name($server);
- my %ircconf = get_items_by_name($conf{irc});
-
- my $static = $conf{static};
- unless (defined $static) {
- $static = dist_dir("Bot-Pastebot");
- }
-
- POE::Component::Server::TCP->new(
- Port => $conf{port},
- (
- (defined $conf{iface})
- ? ( Address => $conf{iface} )
- : ()
- ),
- # TODO - Can we use the discrete callbacks?
- Acceptor => sub {
- POE::Session->create(
- inline_states => {
- _start => \&httpd_session_started,
- got_flush => \&httpd_session_flushed,
- got_query => \&httpd_session_got_query,
- got_error => \&httpd_session_got_error,
- },
-
- # Note the use of ifname here in ARG6. This gives the
- # responding session knowledge of its host name for
- # building HTML responses. Most of the time it will be
- # identical to iface, but sometimes there may be a reverse
- # proxy, firewall, or NATD between the address we bind to
- # and the one people connect to. In that case, ifname is
- # the address the outside world sees, and iface is the one
- # we've bound to.
-
- args => [
- @_[ARG0..ARG2], $server,
- $conf{iface}, $conf{port}, $conf{ifname}, $conf{irc},
- $conf{proxy}, $conf{iname}, $static
- ],
- );
- },
- );
- }
-}
-
-### Fix paste for presentability.
-
-sub fix_paste {
- my ($paste, $line_nums, $tidied, $highlighted, $wrapped) = @_;
-
- ### If the code is tidied, then tidy it.
-
- if ($tidied) {
- my $tidy_version = "";
- eval {
- Perl::Tidy::perltidy(
- source => \$paste,
- destination => \$tidy_version,
- argv => [ '-q', '-nanl', '-fnl' ],
- );
- };
- if ($@) {
- $paste = "Could not tidy this paste (try turning tidying off): $@";
- }
- else {
- $paste = $tidy_version;
- }
- }
-
- ### If the code is to be highlighted, then highlight it.
-
- if ($highlighted) {
- my @html_args = qw( -q -html -pre );
- push @html_args, "-nnn" if $line_nums;
-
- my $highlighted = "";
- eval {
- Perl::Tidy::perltidy(
- source => \$paste,
- destination => \$highlighted,
- argv => \@html_args,
- );
- };
- if ($@) {
- $highlighted = (
- "Could not highlight the paste (try turning highlighting off): $@"
- );
- }
- return $highlighted;
- }
-
- ### Code's not highlighted. HTML escaping time. Forgive me.
-
- # Prepend line numbers to each line.
-
- if ($line_nums) {
- my $total_lines = 0;
- $total_lines++ while ($paste =~ m/^/gm);
- my $line_number_width = length($total_lines);
- $line_number_width = 4 if $line_number_width < 4; # To match Perl::Tidy.
-
- my $line_number = 0;
- while ($paste =~ m/^/gm) {
- my $pos = pos($paste);
- substr($paste, pos($paste), 0) = sprintf(
- "\%${line_number_width}d ", ++$line_number
- );
- pos($paste) = $pos + 1;
- }
- }
-
- $paste = html_encode($paste);
-
- # Normalize newlines. Translate whichever format to just \n, and
- # limit the number of consecutive newlines to two.
-
- $paste =~ s/(\x0d\x0a?|\x0a\x0d?)/\n/g;
- $paste =~ s/\n\n+/\n\n/;
-
- # Buhbye.
-
- unless ($wrapped) {
- substr($paste, 0, 0) = "<pre>";
- $paste .= "</pre>";
- }
-
- return $paste;
-}
-
-#------------------------------------------------------------------------------
-1;
View
244 trunk/lib/Bot/Pastebot/WebUtil.pm
@@ -1,244 +0,0 @@
-# $Id$
-
-# Rocco's POE web server helper functions. Do URL en/decoding. Load
-# static pages, and do template things with them.
-
-package Bot::Pastebot::WebUtil;
-
-use warnings;
-use strict;
-
-use CGI::Cookie;
-use Text::Template;
-
-use base qw(Exporter);
-our @EXPORT_OK = qw(
- url_decode url_encode parse_content parse_cookie static_response
- dump_content dump_query_as_response base64_decode html_encode
- is_true cookie
-);
-
-#------------------------------------------------------------------------------
-# Build two URL-encoding maps. Map non-printable characters to
-# hexified ordinal values, and map hexified ordinal values back to
-# non-printable characters.
-
-my (%raw_to_url, %url_to_raw);
-
-# Nonprintable characters
-for (my $ord = 0; $ord < 256; $ord++) {
- my $character = chr($ord);
- my $hex = lc(unpack('H2', $character));
-
- # Map characters to their hex values, including the escape.
- $raw_to_url{ $character } = '%' . $hex;
-
- # Map hex codes (lower- and uppercase) to characters.
- $url_to_raw{ $hex } = $character;
- $url_to_raw{ uc $hex } = $character;
-}
-
-# Return a cookie string for a Set-Cookie header. The request argument is
-# used to figure out domain.
-sub cookie {
- my ($name, $value, $request) = @_;
-
- return CGI::Cookie->new(
- -name => $name,
- -value => $value,
- -expires => '+36M',
- -domain => (split /:/, $request->headers->header('Host'))[0],
- -path => '/',
- )->as_string;
-}
-
-# Decode url-encoded data. This code was shamelessly stolen from
-# Lincoln Stein's CGI.pm module. Translate plusses to spaces, and
-# then translate %xx sequences into their corresponding characters.
-# Avoid /e on the regexp because "eval" is close to "evil".
-sub url_decode {
- my $data = shift;
- return undef unless defined $data;
- $data =~ tr[+][ ];
- $data =~ s/%([0-9a-fA-F]{2})/$url_to_raw{$1}/g;
- return $data;
-}
-
-# Url-encode data. This code was shamelessly stolen from Lincoln
-# Stein's CGI.pm module. Translate nonprintable characters to %xx
-# sequences, and spaces to plusses. Avoid /e too.
-sub url_encode {
- my $data = shift;
- return undef unless defined $data;
- $data =~ s/([^a-zA-Z0-9_.:=\&\#\+\?\/-])/$raw_to_url{$1}/g;
- return $data;
-}
-
-# HTML-encode data. More theft from CGI.pm. Translates the
-# blatantly "bad" html characters.
-sub html_encode {
- my $data = shift;