zlax/ljr
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

init

Browse Source
This commit is contained in:
ivan
2019-02-06 00:49:12 +03:00
commit 8dbb1bb605
4796 changed files with 506072 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

195
wcmtools/perlbal/CHANGES Executable file
View File

@@ -0,0 +1,195 @@
-- byte range support for both webserver mode and reproxy-file mode
Giao Phan <giao@guba.com>. so clients can resume large transfers.
-- test suite
-- IO::AIO support (brad)
-- change response code to client to 200 on reproxy-file from backend
-- 'nodes' command now takes as an optional argument a specific ip:port to
dump the node stats for
-- AIO abstraction layer (Perlbal::AIO) which can currently do either
Linux::AIO or "none" (doing everything sync). also in future File::FDpasser
and other OS-specific modes [brad]
-- add buffer_backend_connect to do in memory buffering of data before we
request a backend; assists slow clients without tying up a mod_perl
-- fix spinning issue when webnodes unavailable; should now not consume 100%
CPU in those cases
-- revamp verbose functionality; by default it's still of, but if you specify
VERBOSE ON in the config file, it turns it on for management connections
by default. management connections, when specifying VERBOSE ON/OFF, will
now set the flag only for that connection.
-- new command for config file; VERBOSE ON/OFF; can be used to enable or
disable confirmation of all commands such as SET, SERVER, CREATE, etc.
by default, it's off for config files, but on for management connections.
-- add generation count to services that increments every time a pool is
switched. this data is now stored on backends when they're spawned as
well, and when we allocate a backend we verify the generation so old ones
are thrown away.
-- allow setting of nodefile on pools to 'none' or 'null' or 'undef' or just
an empty set of quotes ("", '') in order to stop using node files
-- automatically set use count to 0 on new nodes coming in from nodefile
-- made auto-vivification of pulls throw warnings, and made Perlbal die if it
tries to vivify a pool and the user has previously manually declared a pool
-- updated pool commands to be more flexible (POOL pool ADD node, etc)
-- add pools; a way of having different sets of nodes and instantly switching
between them, so traffic stops going to old nodes; see the example config
file for usage
-- work partially without Linux::AIO (does sync stat of node file in reverse
proxy mode, and webserver mode doesn't work) --brad
1.2 (2005-03-07)
-- add new stats command 'nodes' that shows information on each node that we've
been connecting to -- last connect time, last attempt time, a breakdown of
the last 500 status codes returned, etc
-- add ability to use new Danga::Socket profiling; 'profile on', 'profile data'
to see the info so far, and 'profile off' to disable it
-- graceful shutdown now flags sockets that are busy to die so they die when
they're done with their current connection
-- sockets in persist_wait now get closed immediately during a graceful shutdown
-- fix handling of OPTIONS responses; used to do its own state clearing but
it now uses the next_request method as it should
-- fix bug with determination of keep-alive in http 1.1 case specifying
a connection: close header
-- added 'uptime' management command to track how long Perlbal has been up
-- new config commands: HEADER INSERT <svc> <header>: <value> and HEADER
REMOVE <svc> <header> which will insert and remove headers from user
requests before they're sent to backend proxy nodes.
-- add dependency to Net::Netmask; now you can specify trusted_upstream_proxies
on a service (SET service.trusted_upstream_proxies = 10.0.0.0/8, etc)
which will allow requests from that range to set X-Forwarded-For, X-Host,
and X-Forwarded-Host headers.
-- fixed a bug that caused connections to hang when the backend responded
before the user was done sending data
-- reset some variables that weren't being reset: read_buf, read_ahead, read_size
-- "proc" management command shows user and system CPU usage for Perlbal
this run, as well as a delta since the last time you ran "proc"
-- added Perlbal::XS interface for modules to use; also 'xs' management
command to see the status of XS modules
-- bug in PalImg caused crash on files with no length (or when another
error occurs that causes no data to be sent to new_gif_palette function)
-- ReproxyManager would sometimes let closed backends back into the pool
and hand them off to clients, fixed to check for that
-- new policy: you don't muck around with the internals of other classes.
notably, clients don't change the internals of a backend and backends
don't change the internals of a client. this was causing all sorts of
problems because nobody was cleaning up properly. (especially with regard
to "who is my backend's client" type questions.)
-- fixed up code that did its own keep-alive checks to use the HTTPHeaders
functions so that in the future every part of the code stays up to date
-- Perlbal::Socket now has the option to keep track of all objects that
are created. new command to management interface 'leaks' will show
all objects currently in memory. turn this functionality on by enabling
the TRACK_OBJECTS constant in Perlbal::Socket.
-- split keep-alive logic into request and response methods and cleared
up how that works
-- rewrote reproxy URI support. new class Perlbal::ReproxyManager does all
of the work relating to reproxies. it's basically a service class but
stripped down and dealing with single endpoints instead of pools. much
much much more robust under heavy load. (Junior, Brad)
-- now that we support persistent connections, the 'queues' command didn't
have an accurate time; added ClientProxy member last_request_time so
we can accurately tell how long requests have been waiting for
-- Danga::Socket got an overhaul; close and steal_socket now share a lot
of code by calling _cleanup. some more paranoia on making sure the
object isn't already closed when we try to do things.
-- lots more paranoia in close events and event_err handling for backends
-- added tracking mode for helping look for leaked objects; records a
backtrace of every object created. "server track_obj = 0/1" to enable
or disable it, and then "tracking" in a management interface to see.
-- made Perlbal::objctor/objdtor take an object as their first parameter.
much faster than using caller().
-- fix Highpri plugin to not check hosts for high priority values when
the host isn't defined
-- made Palimg plugin far more paranoid about errors, and also uses new
ClientHTTPBase scratch area for keeping track of data instead of using
headers (which are generally slower)
-- fixed bug in HTTPHeaders that set_version would inadvertently
run into when used on a header created through new_response
-- ClientProxy class now supports persistence; set persist_client on
the proxy service in order to enable it.
-- Palimg plugin now supports fallback to web server mode if the
requested URI doesn't fit our desired pattern
-- did some cleanup; made a bunch of HTTPHeaders accesses use the
accessor methods instead of referencing into the object's private
store of data
-- fixed a crash caused by calling getsockname/getpeername on sockets
that have been undefined after having been stolen during an internal
redirect to another webserver
-- fixed _simple_response to not return a body if we're serving
to a HEAD request
-- bug fix: don't send Not-Modified responses to requests for dynamic
directory listings. it was messing up persistent connections
since the directory serving code didn't get passed down whether we
were sending a body or not. and not modifies on directories are hard:
modify time isn't altogether useful. (file sizes could change)
this still does not-modifieds on indirect index.html directory
requests, because _serve_request ends up eventually calling
_serve_request on a different URI. (brad)
-- added BSD::Resource as dependency to Makefile.PL (brad)
-- fixed 304 Not Modified responses to not send Content-Length
and Content-Type headers. (jr)
1.01 (2004-10-22)
-- when internally redirecting a URL, perlbal advertises
that it supports persisent HTTP connections now,
and caches those sockets for 5 seconds. (not configurable)
useful under load, otherwise you waste all local ports
on a machine
-- ditch dependence on IO::SendFile. do it ourselves (1 line)
with perl's syscall function
-- add doc/* and conf/* to MANIFEST file
1.00
-- initial packaged release

36
wcmtools/perlbal/MANIFEST Executable file
View File

@@ -0,0 +1,36 @@
Makefile.PL
MANIFEST
CHANGES
perlbal
lib/Perlbal.pm
lib/Perlbal/BackendHTTP.pm
lib/Perlbal/ClientHTTP.pm
lib/Perlbal/ClientHTTPBase.pm
lib/Perlbal/ClientManage.pm
lib/Perlbal/ClientProxy.pm
lib/Perlbal/HTTPHeaders.pm
lib/Perlbal/Service.pm
lib/Perlbal/Socket.pm
lib/Perlbal/StatsListener.pm
lib/Perlbal/TCPListener.pm
lib/Perlbal/Test.pm
lib/Perlbal/Plugin/Palimg.pm
lib/Perlbal/Plugin/Queues.pm
lib/Perlbal/Plugin/Stats.pm
lib/Perlbal/Plugin/Highpri.pm
lib/Perlbal/ReproxyManager.pm
META.yml Module meta-data (added by MakeMaker)
doc/Classes.txt
doc/README.txt
doc/Hooks.txt
doc/Reproxying.txt
doc/todo.txt
conf/nodelist.dat
conf/perlbal.conf
t/00-use.t
t/10-testharness.t
t/12-headers.t
t/15-webserver.t
t/20-put.t
t/30-reverseproxy.t

14
wcmtools/perlbal/MANIFEST.SKIP Executable file
View File

@@ -0,0 +1,14 @@
^#
\bCVS\b
^MANIFEST\.
^Makefile$
~$
\.html$
\.old$
^blib/
_blib$
^MakeMaker-\d
^\.exists
\bdebian\b
\btest\b

16
wcmtools/perlbal/META.yml Executable file
View File

@@ -0,0 +1,16 @@
# http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: Perlbal
version: 1.01
version_from:
installdirs: vendor
requires:
BSD::Resource: 0
Danga::Socket: 1.25
File::Find: 0
Linux::AIO: 1.3
Net::Netmask: 0
Test::More: 0
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17

49
wcmtools/perlbal/Makefile.PL Executable file
View File

@@ -0,0 +1,49 @@
#!/usr/bin/perl
#
# Perl Makefile for Perlbal
# $Id: Makefile.PL,v 1.7 2005/03/08 00:30:09 bradfitz Exp $
#
# Invoke with 'perl Makefile.PL'
#
# See ExtUtils::MakeMaker (3) for more information on how to influence
# the contents of the Makefile that is written
#
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'Perlbal',
VERSION => '1.2',
AUTHOR => 'Brad Fitzpatrick <brad@danga.com>',
ABSTRACT_FROM => 'perlbal',
(
exists($ENV{DANGABUILD_MODULESONLY}) ?
() :
(EXE_FILES => [ 'perlbal' ]),
),
PREREQ_PM => {
'Linux::AIO' => '1.3',
'Danga::Socket' => '1.36',
'BSD::Resource' => 0,
'Net::Netmask' => 0,
'Test::More' => 0,
'File::Find' => 0,
},
dist => {
CI => "cvs commit",
RCS_LABEL => 'cvs tag RELEASE_$(VERSION_SYM)',
SUFFIX => ".gz",
DIST_DEFAULT => 'all tardist',
COMPRESS => "gzip",
},
(
exists($ENV{DANGABUILD_DAEMONONLY}) ?
(PM => {}, PMLIBDIRS => []):
(),
),
);

9
wcmtools/perlbal/conf/nodelist.dat Executable file
View File

@@ -0,0 +1,9 @@
# whitespace and comments allowed
10.1.0.10 # test machine
#10.1.0.10:8083 # test machine
# can include port numbers, but defaults to 80 if not provided:
# 10.1.0.4:80

167
wcmtools/perlbal/conf/perlbal.conf Executable file
View File

@@ -0,0 +1,167 @@
# comments work
SERVER max_connections = 10000
# + 4 (stdin,out,err,epoll)
# load some plugins
#LOAD stats
#LOAD queues
#LOAD palimg
#SET buffer_size = 250k
#SET min_rate = 2k
#SET min_rate_check = 10s
#SET user = nobody.nogroup
# globally, no more than 20 connections to each reproxy host
#SERVER max_reproxy_connections = 20
# but only 5 connections at a time to 10.1.0.11:7500
#SERVER max_reproxy_connections(10.1.0.11:7500) = 5
# pools are the best way to define what nodes are in a reverse proxy service
CREATE POOL web_proxy_pool
# add some nodes to the pool
POOL ADD web_proxy_pool 10.0.0.1:80
POOL ADD web_proxy_pool 10.0.0.2:80
# remove a node we didn't want (typically this is useful in the management
# console and not the config file)
POOL REMOVE web_proxy_pool 10.0.0.1:80
# the balance method defines how we pick nodes... random just randomly selects
# a node from the pool. NOTE: if you set nodefile AND set nodes above, the
# nodefile will override the nodes if it exists. if the nodefile is not found,
# the above nodes will be used. it is not required that you set a nodefile and
# configure nodes in this file. one or the other is fine.
SET web_proxy_pool.balance_method = random
SET web_proxy_pool.nodefile = conf/nodelist.dat
# another way of getting node information... not as useful nowadays, as random
# with verify_backend is the best way to go
#SET web_proxy.balance_method = sendstats
#SET web_proxy.sendstats.listen = 10.1.0.255:4446
CREATE SERVICE web_proxy # word
SET web_proxy.role = reverse_proxy
SET web_proxy.listen = 0.0.0.0:8080
# define our pool. this can be changed at run time without any interruption
# of service.
SET web_proxy.pool = web_proxy_pool
# Setup some plugins on this service
#SET web_proxy.plugins = stats, queues
# Define an IP block where we know upstream proxies exist. This allows
# them to set X-Forwarded-For, X-Host, and X-Forwarded-Host headers and
# causes us not to purge them.
SET web_proxy.trusted_upstream_proxies = 10.0.0.0/24
# How many extra backend connections to keep connected in advance
# in anticipation of incoming clients? 2 or 3 should be plenty..
# it's just a buffer.
SET web_proxy.connect_ahead = 2
# When set to some value above 0, and the incoming request has content-length,
# Perlbal will buffer up to this many bytes in memory before requesting a
# backend connection. This is useful when you know you're going to be getting
# slow uploads and you don't want them tying up the nodes until you have
# enough data. As soon as this value is reached, no matter how much data
# we're expecting, we will request a backend.
SET web_proxy.buffer_backend_connect = 250000
# persistent backends are connections that will stay open to the backend
# for more than one request. if you have it enabled, you can then set
# max_backend_uses to determine how many times to use a backend connection
# before we close it ourselves. 0 means use it until the server closes it.
SET web_proxy.persist_backend = on
SET web_proxy.max_backend_uses = 10
# if you want to limit the number of open persistent connections that perlbal
# will maintain, set this. the default is 2. if you have more than this
# number of bored backends, perlbal will begin closing them.
SET web_proxy.backend_persist_cache = 2
# often, the operating system kernel will accept a pending connection
# request as soon as the request comes in but before the connection is
# actually being handled by the web server. with this turned on, perlbal
# will send an OPTIONS request to the backend and wait for it to respond
# before letting any clients use this backend.
SET web_proxy.verify_backend = on
# users with this cookie containing this subset string get to cut in line.
# obviously, the backend application should check that the user's class
# matches their advertised cookie and not give them the page they want
# if they're cutting in line without warrant:
SET web_proxy.high_priority_cookie = fastq
SET web_proxy.high_priority_cookie_contents = 1
# given the above high priority queuing system, sometimes if the high
# priority queue is really busy, the standard queue will suffer from
# resource starvation. the queue relief system helps prevent this. when
# there are queue_relief_size or more connections in the standard queue,
# newly available backends have a queue_relief_chance percent chance of
# taking a request from the standard priority queue instead of the high
# priority queue. this can be adjusted to work well with your site. set
# queue_relief_size to 0 to disable the system entirely.
SET web_proxy.queue_relief_size = 2000
SET web_proxy.queue_relief_chance = 30 # 0-100, in percent
# you can define header transformations to be performed on the request
# headers the users sends before they're forwarded on to the backend.
HEADER REMOVE web_proxy Referer # remove the Referer header
HEADER INSERT web_proxy X-Foo: 1 # and add X-Foo to requests to the backend
HEADER INSERT web_proxy X-Bar: baz # also add X-Bar and set to baz
#SET web_proxy.serve_top_directories = /static/, /doc/server/,
ENABLE web_proxy
CREATE SERVICE web # word
#SET web.plugins = stats
SET web.role = web_server
SET web.listen = 0.0.0.0:8081
SET web.docroot = /usr/share/
# if this option is on, users will be prevented with a list of files in
# directories they have navigated to. CAUTION: listing directories is
# a blocking operation and is not recommended for busy sites.
SET web.dirindexing = 1
# this defaults to index.html; if you navigate straight to a directory then
# perlbal will try to find files with these names in that directory, one at
# a time. if nothing is found, it will fall back to creating a directory
# list (if that's on) or return a 200 and say directory listing disabled
SET web.index_files = index.html, default.htm
# if this is on, the web server will support persistent connections to the
# client requesting the data.
SET web.persist_client = 1
ENABLE web
CREATE SERVICE mgmt
SET mgmt.role = management
SET mgmt.listen = 0.0.0.0:8065
ENABLE mgmt
# create a palimg service that will handle pallette altering GIFs and PNGs
#CREATE SERVICE web_palimg
#SET web_palimg.plugins = stats, palimg
#SET web_palimg.listen = 0.0.0.0:8083
#SET web_palimg.docroot = /usr/share/
# It will search in /usr/share/palimg/ for images.
#ENABLE web_palimg
# and now create an upload service that lets people PUT files to it
#CREATE SERVICE upload
#SET upload.role = web_server
#SET upload.enable_put = yes
#SET upload.max_upload_size = 150000
# Maximum file size of 150,000 bytes. Set to 0 for no limit.
#SET upload.listen = 0.0.0.0:8084
#SET upload.docroot = /usr/share/upload/
# All files will be put into /usr/share/upload/ as a base.
#ENABLE upload

5
wcmtools/perlbal/debian/changelog Executable file
View File

@@ -0,0 +1,5 @@
perlbal (1.01-1) unstable; urgency=low
* Initial Release
-- Jay Bonci <jaybonci@debian.org> Fri, 14 Jan 2005 06:02:34 -0500

1
wcmtools/perlbal/debian/compat Executable file
View File

@@ -0,0 +1 @@
4

30
wcmtools/perlbal/debian/control Executable file
View File

@@ -0,0 +1,30 @@
Source: perlbal
Section: perl
Priority: optional
Maintainer: Jay Bonci <jaybonci@debian.org>
Build-Depends-Indep: debhelper (>= 4.1.40), perl (>= 5.8.4), libbsd-resource-perl, liblinux-aio-perl (>= 1.3), libdanga-socket-perl, libwww-perl, libnet-netmask-perl
Standards-Version: 3.6.1.0
Package: perlbal
Architecture: all
Depends: ${perl:Depends}, libbsd-resource-perl, liblinux-aio-perl (>= 1.3), libdanga-socket-perl, libwww-perl, libnet-netmask-perl
Recomends: libperlbal-perl
Suggests: perlbal-doc
Description: reverse-proxy load balancer and webserver
Perlbal is a poll/epoll based system that supports multiple personalities
dictated by what port a request comes in on. It supports the creation of an
unlimited number of services that can each have their own entirely
independent configurations.
Package: libperlbal-perl
Architecture: all
Depends: ${perl:Depends}, libbsd-resource-perl, liblinux-aio-perl (>= 1.3), libdanga-socket-perl, libwww-perl, libnet-netmask-perl
Description: supporting perl libraries for perlbal
This package contains the module files (but not the daemon) for use with
perlbal, the reverse-proxy load balancer and webserver.
Package: perlbal-doc
Architecture: all
Description: documentation for perlbal
This package contains documentation and implementation notes for use with
perlbal, the reverse-proxy load balancer and webserver.

25
wcmtools/perlbal/debian/copyright Executable file
View File

@@ -0,0 +1,25 @@
This package was debianized by Jay Bonci <jay@bonci.com> on
Fri Jan 14 06:06:23 EST 2005
It was downloaded from: http://www.danga.com/perlbal
Upstream Author:
Brad Fitzpatrick, <brad@danga.com>
Mark Smith, <marksmith@danga.com>
Copyright:
This program is free software; you can redistribute it and/or modify
it under the terms of either:
a) the GNU General Public License as published by the Free
Software Foundation; either version 1, or (at your option) any
later version, or
b) the "Artistic License"
See:
/usr/share/common-licenses/Artistic
/usr/share/common-licenses/GPL
For more information regarding these licensing options

1
wcmtools/perlbal/debian/perlbal-doc.docs Executable file
View File

@@ -0,0 +1 @@
doc/*

73
wcmtools/perlbal/debian/perlbal.init Executable file
View File

@@ -0,0 +1,73 @@
#! /bin/sh
#
# skeleton example file to build /etc/init.d/ scripts.
# This file should be used to construct scripts for /etc/init.d.
#
# Written by Miquel van Smoorenburg <miquels@cistron.nl>.
# Modified for Debian
# by Ian Murdock <imurdock@gnu.ai.mit.edu>.
#
# Version: @(#)skeleton 1.9 26-Feb-2001 miquels@cistron.nl
#
PATH=/usr/local/sbin:/usr/local/bin:/sbin:/bin:/usr/sbin:/usr/bin
DAEMON=/usr/bin/perlbal
NAME=perlbal
DESC=Perlbal
PIDFILE=/var/run/$NAME.pid
USER=root
test -x $DAEMON || exit 0
set -e
case "$1" in
start)
echo -n "Starting $DESC: "
if [ -e $PIDFILE ]
then
if [ -d /proc/`cat $PIDFILE`/ ]
then
echo "$NAME already running."
exit 0;
else
rm -f $PIDFILE
fi
fi
start-stop-daemon --start --quiet --exec $DAEMON --pidfile $PIDFILE -b -m --name $NAME --user $USER
echo "$NAME."
;;
stop)
echo -n "Stopping $DESC: "
start-stop-daemon --stop --quiet --oknodo --pidfile $PIDFILE --name $NAME --user $USER
echo "$NAME."
rm -f $PIDFILE
;;
restart|force-reload)
#
# If the "reload" option is implemented, move the "force-reload"
# option to the "reload" entry above. If not, "force-reload" is
# just the same as "restart".
#
echo -n "Restarting $DESC: "
start-stop-daemon --stop --quiet --oknodo --pidfile $PIDFILE --name $NAME --user $USER
rm -f $PIDFILE
sleep 1
start-stop-daemon --start --quiet --exec $DAEMON --pidfile $PIDFILE -b -m --name $NAME --user $USER
echo "$NAME."
;;
*)
N=/etc/init.d/$NAME
# echo "Usage: $N {start|stop|restart|reload|force-reload}" >&2
echo "Usage: $N {start|stop|restart|force-reload}" >&2
exit 1
;;
esac
exit 0

15
wcmtools/perlbal/debian/perlbal.postinst Executable file
View File

@@ -0,0 +1,15 @@
#!/bin/sh
if [ ! -e /etc/perlbal/perlbal.conf ]
then
mkdir -p /etc/perlbal
cp /usr/share/perlbal/perlbal.conf.default /etc/perlbal/perlbal.conf
fi
if [ ! -e /etc/perlbal/nodelist.dat ]
then
mkdir -p /etc/perlbal
cp /usr/share/perlbal/nodelist.dat.default /etc/perlbal/nodelist.dat
fi
#DEBHELPER#

12
wcmtools/perlbal/debian/perlbal.postrm Executable file
View File

@@ -0,0 +1,12 @@
#!/bin/sh
if [ "$1" = "purge" ]
then
rm -f /etc/perlbal/perlbal.conf
rm -f /etc/perlbal/nodelist.dat
rmdir --ignore-fail-on-non-empty /etc/perlbal
fi
rm -f /var/run/perlbal.pid
#DEBHELPER#

72
wcmtools/perlbal/debian/rules Executable file
View File

@@ -0,0 +1,72 @@
#!/usr/bin/make -f
# Sample debian/rules that uses debhelper.
# GNU copyright 1997 to 1999 by Joey Hess.
# Uncomment this to turn on verbose mode.
#export DH_VERBOSE=1
# This is the debhelper compatibility version to use.
# export DH_COMPAT=4
#PACKAGE=`pwd | sed -e "s/.*\/\\(.*\\)-.*/\\1/"`
ENV=/usr/bin/env
PERL=/usr/bin/perl
MODULESPACKAGE=libperlbal-perl
DAEMONPACKAGE=perlbal
CONFDIR=$(CURDIR)/debian/$(DAEMONPACKAGE)/usr/share/perlbal
BM=blib.modules
BD=blib.daemon
build:
dh_testdir
# Add here commands to compile the package.
$(ENV) DANGABUILD_MODULESONLY=1 $(PERL) Makefile.PL verbose INSTALLDIRS=vendor INST_LIB=$(BM)
cp Makefile Makefile.modules
$(ENV) DANGABUILD_DAEMONONLY=1 $(PERL) Makefile.PL verbose INSTALLDIRS=vendor INST_LIB=$(BD) INST_SCRIPT=$(BD)
cp Makefile Makefile.daemon
clean:
dh_testdir
dh_testroot
-$(MAKE) -f Makefile.modules clean
-$(MAKE) -f Makefile.daemon clean
rm -f Makefile.old Makefile.modules Makefile.daemon
rm -rf $(BD) $(BM)
dh_clean
install:
dh_testdir
dh_testroot
dh_clean -k
dh_installdirs
$(MAKE) -f Makefile.modules PREFIX=$(CURDIR)/debian/$(MODULESPACKAGE)/usr OPTIMIZE="-O2 -g -Wall" test install
$(MAKE) -f Makefile.daemon PREFIX=$(CURDIR)/debian/$(DAEMONPACKAGE)/usr OPTIMIZE="-O2 -g -Wall" install
-find $(CURDIR)/debian -type d | xargs rmdir -p --ignore-fail-on-non-empty
install -d $(CONFDIR)
install -m 644 conf/perlbal.conf $(CONFDIR)/perlbal.conf.default
install -m 644 conf/nodelist.dat $(CONFDIR)/nodelist.dat.default
binary-arch:;
binary-indep: build install
dh_testdir
dh_testroot
dh_installdocs
dh_installman
dh_installinit
dh_installchangelogs CHANGES
dh_link
dh_strip
dh_compress
dh_fixperms
dh_installdeb
dh_perl
dh_gencontrol
dh_md5sums
dh_builddeb
binary: binary-indep binary-arch
.PHONY: build clean binary-indep binary-arch binary install configure

2
wcmtools/perlbal/debian/watch Executable file
View File

@@ -0,0 +1,2 @@
version=2
http://www.danga.com/dist/Perlbal/Perlbal-([0-9].*)\.tar.gz

72
wcmtools/perlbal/doc/Classes.txt Executable file
View File

@@ -0,0 +1,72 @@
Perlbal Classes -- a brief introduction/overview.
Socket -- descends from Danga::Socket
Adds on to the base class to provide some functionality specifically
useful for creating HTTP sockets.
TCPListener -- descends from Perlbal::Socket
Very lightweight and fast connection accept class. Takes incoming
connections as fast as possible and passes them off, instantiating one of
the various Client* classes to handle it.
BackendHTTP -- descends from Perlbal::Socket
This class handles connections to the backend web nodes for getting data
back to the user. This class is used by other classes such as ClientProxy
to send a request to an internal node.
HTTPHeaders --
Header management. Parses headers (request and response) and stores data
for further user. Also manages validation of the request line so that it
conforms to HTTP specifications.
ClientHTTPBase -- descends from Perlbal::Socket
Provides base functionality to ClientHTTP and ClientProxy. Notably, the
ability to efficiently send files to the remote user. Also handles most of
the state logic for statistics and such.
ClientHTTP -- descends from Perlbal::ClientHTTPBase
Very simple and lightweight class. Handles sending files to the user
without much overhead. Most of the functionality is contained in the parent
class, and this class doesn't implement much new stuff.
ClientProxy -- descends from Perlbal::ClientHTTPBase
Takes an incoming connection from a user and connects to a backend node
(BackendHTTP) and relays the request. The backend can then either tell the
proxy to reproxy and load a file from disk, or return a file directly, or
just return a status message.
ClientManage -- descends from Perlbal::Socket
Simple interface that provides a way for users to use the management
interface of Perlbal. You can connect to the management port (as defined
in the config file) with a web browser or regular telnet.
Service --
A service is a particular item that Perlbal is doing. Services can have
a role which defines how they behave. Each service can also have a bunch
of parameters set to further adjust its behavior. By itself, the Service
class handles maintaining pools of backend connections and managing statistics
about itself.
StatsListener -- descends from Perlbal::Socket
This class listens for UDP broadcasts from the web nodes describing how
many available children they have. This information is then used to pick an
endpoint for a backend connection to be made to in order to handle a user's
incoming request.
{{ INTERNET }}
|
v
[Service]<===>[TCPListener]
___/ | \___
v v v
[ClientManage] [ClientHTTP] [ClientProxy]
^
|
v
[BackendHTTP]
So connections come in from wherever and get to the TCPListener. It uses
Service objects to determine what kind of Client* to spawn. The Client
classes then handle crafting the response for the user.

106
wcmtools/perlbal/doc/Hooks.txt Executable file
View File

@@ -0,0 +1,106 @@
Perlbal Hooks --
-- INTRODUCTION --
Basically, a hook is a bit of code that is run at certain stages in the
requests that Perlbal handles. There are all kinds of hooks available and
they all do different things. Some are only applicable to some of the
roles and others are applicable only to certain classes. Each hook is
described in detail below, but first a description of the basics of a hook.
In general, you define a hook by calling the "register_hook" method on a
Perlbal::Service object. You specify what hook you are interested in and
provide a reference to a subroutine that will be called with the parameters
particular to that hook.
There are three types of hooks:
--- Global hooks
These are hooks that are defined on a global scale. They are set like so:
Perlbal::register_global_hook('foo', sub { return 0; });
That would define a global hook named foo that would return 0 when it's
called. (Return codes from hooks will be explained below.)
--- Service handler hooks
A handler hook is attached to a particular service. These hooks are called
one at a time, starting from the top of the hook list on a service, until
one hook returns 1. At that point, no further hooks are called. For
example:
$service->register_hook('bar', sub {
# do something
return 1;
});
When this hook runs, it would return 1, signalling to Perlbal that it had
done what it needed to do and that Perlbal shouldn't call any further
hooks. You can use this type of hook to create sets of plugins that all
handle different types of requests, and when one hook had handled a request
it wouldn't continue telling other hooks about the request.
--- Service general hooks
These hooks are defined the same way as above, but general hooks are all
run. The return code is ignored. This can be useful for putting in code
that records statistics about an action or something to that effect.
-- HOOKS --
The following hooks are defined in the Perlbal distribution:
GENERAL end_proxy_request Perlbal::ClientProxy
This hook is called when the ClientProxy object is being closed.
HANDLER start_proxy_request Perlbal::ClientProxy
Called as soon as we've read in headers from a user but right before we've
requested a backend connection. If a true value is returned, Perlbal will
not request a backend.
HANDLER start_file_reproxy Perlbal::ClientProxy, $filename_ref
Called when we've been told to reproxy a file. If you return a true
value, Perlbal will not perform any operations on the file and will simply
return. You can also change the file in the scalar ref passed as the
second parameter.
HANDLER backend_client_assigned Perlbal::BackendHTTP
Happens right after a backend is given a client, but before we've talked to
the backend and asked it to do something. If you return a true value, the
process is stopped and you will manually have to send the client's request
to the backend, etc.
HANDLER start_web_request Perlbal::ClientHTTP
When a 'web' service has gotten headers and is about to serve it... return
a true value to cancel the default handling of web requests.
HANDLER start_send_file Perlbal::ClientHTTPBase
Called when we've opened a file and are about to start sending it to the
user using sendfile. Return a true value to cancel the default sending.
HANDLER start_serve_request Perlbal::ClientHTTPBase, $uri_ref
Called when we're about to serve a local file, before we've done any
work. You can change the file served by modifying $uri_ref, and cancel the
process by returning a true value.
HANDLER backend_response_received Perlbal::BackendHTTP
Called as soon as response headers are read from the backend. If you
return a true value, will stop all handling at that point.
HANDLER handle_put Perlbal::ClientHTTP
Called whenever we have data to write to a file being PUT. Return a true
value to cause Perlbal to not actually save the file or do anything with
it.
HANDLER setup_put Perlbal::ClientHTTP
Called as soon as we've gotten headers requesting a PUT. Cancels the
default work if you return a true value. Careful: this function sets up
a file descriptor for use in writes in handle_put, so if you're going to
override setup_put you will probably want to override handle_put.
HANDLER make_high_priority Perlbal::ClientProxy
Called when a request is received and right before we're about to determine
if this request is high priority or not. Return a true value to make the
request high priority; false to leave it alone. Note that this is only
called when the request isn't already high priority due to cookie priority
scheduling, which is done inside Perlbal's Service module.

10
wcmtools/perlbal/doc/README.txt Executable file
View File

@@ -0,0 +1,10 @@
Perlbal is not yet documented.
See the website, conf/ directory for examples, and post questions on
the mailing list for now.
Website:
http://www.danga.com/perlbal/
Mailing list:
http://lists.danga.com/mailman/listinfo/perlbal

47
wcmtools/perlbal/doc/Reproxying.txt Executable file
View File

@@ -0,0 +1,47 @@
Perlbal supports the concept of reproxying. Basically, this gives it the
ability to ask a backend node for a file and get back a specific header
that says "this file is really over there, get it there." Perlbal will
then load that file or URL and send it to the user transparently, without
them ever knowing that they got reproxied to another location.
This can be useful for having URLs that get mapped to files on disk without
giving users enough information to map out your directory structure. For
example, you can create a file structure such as:
/home/pics/$userid/$pic
Then you can have URLs such as:
http://foo.com/mysite/users/$userid/picture/$pic
When this URL gets passed to the backend web node, it could return a simple
response that includes this header:
X-REPROXY-FILE: /home/pics/$userid/$pic
Perlbal will then use asynchronous IO to send the file to the user without
slowing down Perlbal at all.
This support also extens to URLs that can be located anywhere Perlbal has
access to. It's the same syntax, nearly:
X-REPROXY-URL: http://foo.com:80/resource.html
You can also specify multiple URLs:
X-REPROXY-URL: http://foo.com:80/resource.html http://baz.com:8080/res.htm
Just specify any number of space separated URLs. Perlbal will request them
one by one until one returns a response code of 200. At that point Perlbal
will proxy the response back to the user just like normal.
Note that the user's headers are NOT passed through to the web server. To
the target server, it looks simply like Perlbal is requesting the resource
for itself. This behavior may change at some point.
One final note: the server that returns the reproxy header can also return
a X-REPROXY-EXPECTED-SIZE header. If present, Perlbal will consider
a reproxy a failure if the file returned by the target system is of a
different size than what the expected size header says. On failure,
Perlbal tries the next URI in the list. If it's a file being reproxied, a
404 is returned if the file size is different.

29
wcmtools/perlbal/doc/todo.txt Executable file
View File

@@ -0,0 +1,29 @@
* Keep track of how many times we couldn't do keep-alive from the backend. This
happens if the backend server is doing chunked encoding or doesn't provide a
content length.
* Allow option to say O_EXCL for PUTs
* Investigate/fix error with "no mapping for fd" when a socket abruptly closes
during the connect process. (Run ab against perlbal, then Ctrl+C it.)
* Investigate when BackendHTTP fails on a call to get_res_headers?
* Fix shutdown graceful to close off persistent clients and bored backends (reproxy too?)
* Document the 'reproxy bored' queue [old...new] self cleaning on the old side, but
uses the new side when it needs a connection
* Investigate why Perlbal is slow to accept connections
* Lots of work can be done to reduce system calls:
- coalesce epoll_ctl calls
- make socket by hand without IO::Socket::INET
- edge-triggered epoll in Danga::Socket
- don't cork twice on reproxy & send
* Support dictionary (scratch hash) per service
- can configure keys to send to backends
- backends can set keys in dictionary (so they propogate to other backends, etc)
* Allow configurable response code that means "backend dead; replay request"

864
wcmtools/perlbal/lib/Perlbal.pm Executable file
View File

@@ -0,0 +1,864 @@
#!/usr/bin/perl
#
package Perlbal;
use constant DEBUG => $ENV{PERLBAL_DEBUG} || 0;
use constant DEBUG_OBJ => $ENV{PERLBAL_DEBUG_OBJ} || 0;
use constant TRACK_STATES => $ENV{PERLBAL_TRACK_STATES} || 0; # if on, track states for "state changes" command
use strict;
use warnings;
use IO::Socket;
use IO::Handle;
use IO::File;
# Try and use IO::AIO or Linux::AIO, if it's around.
BEGIN {
$Perlbal::OPTMOD_IO_AIO = eval "use IO::AIO (); 1;";
$Perlbal::OPTMOD_LINUX_AIO = eval "use Linux::AIO '1.3'; 1;";
}
$Perlbal::AIO_MODE = "none";
$Perlbal::AIO_MODE = "ioaio" if $Perlbal::OPTMOD_IO_AIO;
$Perlbal::AIO_MODE = "linux" if $Perlbal::OPTMOD_LINUX_AIO;
use Sys::Syslog;
use Getopt::Long;
use BSD::Resource;
use Carp qw(cluck croak);
use Errno qw(EBADF);
use POSIX ();
use Perlbal::AIO;
use Perlbal::HTTPHeaders;
use Perlbal::Service;
use Perlbal::Socket;
use Perlbal::TCPListener;
use Perlbal::StatsListener;
use Perlbal::ClientManage;
use Perlbal::ClientHTTPBase;
use Perlbal::ClientProxy;
use Perlbal::ClientHTTP;
use Perlbal::BackendHTTP;
use Perlbal::ReproxyManager;
use Perlbal::Pool;
END {
Linux::AIO::max_parallel(0)
if $Perlbal::OPTMOD_LINUX_AIO;
IO::AIO::max_parallel(0)
if $Perlbal::OPTMOD_IO_AIO;
}
$SIG{'PIPE'} = "IGNORE"; # handled manually
our(%hooks); # hookname => subref
our(%service); # servicename -> Perlbal::Service
our(%pool); # poolname => Perlbal::Pool
our(%plugins); # plugin => 1 (shows loaded plugins)
our($last_error);
our $vivify_pools = 1; # if on, allow automatic creation of pools
our $foreground = 1; # default to foreground
our $track_obj = 0; # default to not track creation locations
our $reqs = 0; # total number of requests we've done
our $starttime = time(); # time we started
our ($lastutime, $laststime, $lastreqs) = (0, 0, 0); # for deltas
# setup XS status data structures
our %XSModules; # ( 'headers' => 'Perlbal::XS::HTTPHeaders' )
# now include XS files
eval "use Perlbal::XS::HTTPHeaders;"; # if we have it, load it
# setup a USR1 signal handler that tells us to dump some basic statistics
# of how we're doing to the syslog
$SIG{'USR1'} = sub {
my $dumper = sub { Perlbal::log('info', $_[0]); };
foreach my $svc (values %service) {
run_manage_command("show service $svc->{name}", $dumper);
}
run_manage_command('states', $dumper);
run_manage_command('queues', $dumper);
};
sub error {
$last_error = shift;
return 0;
}
# Object instance counts, for debugging and leak detection
our(%ObjCount); # classname -> instances
our(%ObjTotal); # classname -> instances
our(%ObjTrack); # "$objref" -> creation location
sub objctor {
if (DEBUG_OBJ) {
my $ref = ref $_[0];
$ref .= "-$_[1]" if $_[1];
$ObjCount{$ref}++;
$ObjTotal{$ref}++;
# now, if we're tracing leaks, note this object's creation location
if ($track_obj) {
my $i = 1;
my @list;
while (my $sub = (caller($i++))[3]) {
push @list, $sub;
}
$ObjTrack{"$_[0]"} = [ time, join(', ', @list) ];
}
}
}
sub objdtor {
if (DEBUG_OBJ) {
my $ref = ref $_[0];
$ref .= "-$_[1]" if $_[1];
$ObjCount{$ref}--;
# remove tracking for this object
if ($track_obj) {
delete $ObjTrack{"$_[0]"};
}
}
}
sub register_global_hook {
$hooks{$_[0]} = $_[1];
return 1;
}
sub unregister_global_hook {
delete $hooks{$_[0]};
return 1;
}
sub run_global_hook {
my $ref = $hooks{$_[0]};
return $ref->(@_) if defined $ref;
return undef;
}
sub service_names {
return sort keys %service;
}
sub service {
my $class = shift;
return $service{$_[0]};
}
sub pool {
my $class = shift;
return $pool{$_[0]};
}
# returns 1 if command succeeded, 0 otherwise
sub run_manage_command {
my ($cmd, $out, $verbose) = @_; # $out is output stream closure
$cmd =~ s/\#.*//;
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
$cmd =~ s/\s+/ /g;
my $orig = $cmd; # save original case for some commands
$cmd =~ s/^([^=]+)/lc $1/e; # lowercase everything up to an =
return 1 unless $cmd =~ /\S/;
$out ||= sub {};
my $err = sub {
$out->("ERROR: $_[0]");
return 0;
};
my $ok = sub {
$out->("OK") if $verbose;
return 1;
};
if ($cmd =~ /^obj$/) {
foreach (sort keys %ObjCount) {
$out->("$_ = $ObjCount{$_} (tot=$ObjTotal{$_})");
}
$out->('.');
return 1;
}
if ($cmd eq "shutdown") {
Linux::AIO::max_parallel(0) if $Perlbal::OPTMOD_LINUX_AIO;
IO::AIO::max_parallel(0) if $Perlbal::OPTMOD_IO_AIO;
exit(0);
}
if ($cmd =~ /^xs(?:\s+(\w+)\s+(\w+))?$/) {
if ($1 && $2) {
# command? verify
my ($cmd, $module) = ($1, $2);
return $err->('Known XS modules: ' . join(', ', sort keys %XSModules) . '.')
unless $XSModules{$module};
# okay, so now enable or disable this module
if ($cmd eq 'enable') {
my $res = eval "return $XSModules{$module}::enable();";
return $err->("Unable to enable module.")
unless $res;
$out->("Module enabled.");
} elsif ($cmd eq 'disable') {
my $res = eval "return $XSModules{$module}::disable();";
return $err->("Unable to disable module.")
unless $res;
$out->("Module disabled.");
} else {
return $err->('Usage: xs [ <enable|disable> <module> ]');
}
} else {
# no commands, so just check status
$out->('XS module status:', '');
foreach my $module (sort keys %XSModules) {
my $class = $XSModules{$module};
my $enabled = eval "return \$${class}::Enabled;";
my $status = defined $enabled ? ($enabled ? "installed, enabled" :
"installed, disabled") : "not installed";
$out->(" $module: $status");
}
$out->(' No modules available.') unless %XSModules;
$out->('');
$out->("To enable a module: xs enable <module>");
$out->("To disable a module: xs disable <module>");
}
$out->('.');
return 1;
}
if ($cmd =~ /^fd/) {
# called in list context on purpose, but we want the hard limit
my (undef, $max) = getrlimit(RLIMIT_NOFILE);
my $ct = 0;
# first try procfs if one exists, as that's faster than iterating
if (opendir(DIR, "/proc/self/fd")) {
my @dirs = readdir(DIR);
$ct = scalar(@dirs) - 2; # don't count . and ..
closedir(DIR);
} else {
# isatty() is cheap enough to do on everything
foreach (0..$max) {
my $res = POSIX::isatty($_);
$ct++ if $res || ($! != EBADF);
}
}
$out->("max $max");
$out->("cur $ct");
$out->('.');
return 1;
}
if ($cmd =~ /^proc/) {
my $ru = getrusage();
my ($ut, $st) = ($ru->utime, $ru->stime);
my ($udelta, $sdelta) = ($ut - $lastutime, $st - $laststime);
my $rdelta = $reqs - $lastreqs;
$out->('time: ' . time());
$out->('pid: ' . $$);
$out->("utime: $ut (+$udelta)");
$out->("stime: $st (+$sdelta)");
$out->("reqs: $reqs (+$rdelta)");
($lastutime, $laststime, $lastreqs) = ($ut, $st, $reqs);
$out->('.');
return 1;
}
if ($cmd =~ /^nodes?(?:\s+(\d+.\d+.\d+.\d+)(?::(\d+))?)?$/) {
my ($ip, $port) = ($1, $2 || 80);
my $spec_ipport = $ip ? "$ip:$port" : undef;
my $ref = \%Perlbal::BackendHTTP::NodeStats;
my $dump = sub {
my $ipport = shift;
foreach my $key (keys %{$ref->{$ipport}}) {
if (ref $ref->{$ipport}->{$key} eq 'ARRAY') {
my %temp;
$temp{$_}++ foreach @{$ref->{$ipport}->{$key}};
foreach my $tkey (keys %temp) {
$out->("$ipport $key $tkey $temp{$tkey}");
}
} else {
$out->("$ipport $key $ref->{$ipport}->{$key}");
}
}
};
# dump a node, or all nodes
if ($spec_ipport) {
$dump->($spec_ipport);
} else {
foreach my $ipport (keys %$ref) {
$dump->($ipport);
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^prof\w*\s+(on|off|data)/) {
my $which = $1;
if ($which eq 'on') {
if (Danga::Socket->EnableProfiling) {
$out->('Profiling enabled.');
} else {
$out->('Unable to enable profiling. Please ensure you have the BSD::Resource module installed.');
}
} elsif ($which eq 'off') {
Danga::Socket->DisableProfiling;
$out->('Profiling disabled.');
} elsif ($which eq 'data') {
my $href = Danga::Socket->ProfilingData;
foreach my $key (sort keys %$href) {
my ($utime, $stime, $calls) = @{$href->{$key}};
$out->(sprintf("%s %0.5f %0.5f %d %0.7f %0.7f",
$key, $utime, $stime, $calls, $utime / $calls, $stime / $calls));
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^uptime/) {
$out->("starttime $starttime");
$out->("uptime " . (time() - $starttime));
$out->('.');
return 1;
}
if ($cmd =~ /^track/) {
my $now = time();
my @list;
foreach (keys %ObjTrack) {
my $age = $now - $ObjTrack{$_}->[0];
push @list, [ $age, "${age}s $_: $ObjTrack{$_}->[1]" ];
}
# now output based on sorted age
foreach (sort { $a->[0] <=> $b->[0] } @list) {
$out->($_->[1]);
}
$out->('.');
return 1;
}
if ($cmd eq 'shutdown graceful') {
# set connect ahead to 0 for all services so they don't spawn extra backends
foreach my $svc (values %service) {
$svc->{connect_ahead} = 0;
}
# tell all sockets we're doing a graceful stop
my $sf = Perlbal::Socket->get_sock_ref;
foreach my $k (keys %$sf) {
my Perlbal::Socket $v = $sf->{$k};
$v->die_gracefully();
}
# register a post loop callback that will end the event loop when we only have
# a single socket left, the AIO socket
Perlbal::Socket->SetPostLoopCallback(sub {
my ($descmap, $otherfds) = @_;
# Ghetto: duplicate the code we already had for our postloopcallback
Perlbal::Socket::run_callbacks();
# see what we have here; make sure we have no Clients and no unbored Backends
foreach my $sock (values %$descmap) {
my $ref = ref $sock;
return 1 if $ref =~ /^Perlbal::Client/ && $ref ne 'Perlbal::ClientManage';
return 1 if $sock->isa('Perlbal::BackendHTTP') && $sock->{state} ne 'bored';
}
return 0; # end the event loop and thus we exit perlbal
});
# so they know something happened
$out->('.');
return 1;
}
if ($cmd =~ /^socks(?: (\w+))?$/) {
my $mode = $1 || "all";
my $sf = Perlbal::Socket->get_sock_ref;
if ($mode eq "summary") {
my %count;
my $write_buf = 0;
my $open_files = 0;
while (my $k = each %$sf) {
my Perlbal::Socket $v = $sf->{$k};
$count{ref $v}++;
$write_buf += $v->{write_buf_size};
if ($v->isa("Perlbal::ClientHTTPBase")) {
my Perlbal::ClientHTTPBase $cv = $v;
$open_files++ if $cv->{'reproxy_fh'};
}
}
foreach (sort keys %count) {
$out->(sprintf("%5d $_", $count{$_}));
}
$out->();
$out->(sprintf("Aggregate write buffer: %.1fk", $write_buf / 1024));
$out->(sprintf(" Open files: %d", $open_files));
} elsif ($mode eq "all") {
my $now = time;
$out->(sprintf("%5s %6s", "fd", "age"));
foreach (sort { $a <=> $b } keys %$sf) {
my $sock = $sf->{$_};
my $age = $now - $sock->{create_time};
$out->(sprintf("%5d %5ds %s", $_, $age, $sock->as_string));
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^backends$/) {
my $sf = Perlbal::Socket->get_sock_ref;
my %nodes; # { "Backend" => int count }
foreach my $sock (values %$sf) {
if ($sock->isa("Perlbal::BackendHTTP")) {
my Perlbal::BackendHTTP $cv = $sock;
$nodes{"$cv->{ipport}"}++;
}
}
# now print out text
foreach my $node (sort keys %nodes) {
$out->("$node " . $nodes{$node});
}
$out->('.');
return 1;
}
if ($cmd =~ /^noverify$/) {
# shows the amount of time left for each node marked as noverify
my $now = time;
foreach my $ipport (keys %Perlbal::BackendHTTP::NoVerify) {
my $until = $Perlbal::BackendHTTP::NoVerify{$ipport} - $now;
$out->("$ipport $until");
}
$out->('.');
return 1;
}
if ($cmd =~ /^pending$/) {
# shows pending backend connections by service, node, and age
my %pend; # { "service" => { "ip:port" => age } }
my $now = time;
foreach my $svc (values %service) {
foreach my $ipport (keys %{$svc->{pending_connects}}) {
my Perlbal::BackendHTTP $be = $svc->{pending_connects}->{$ipport};
next unless defined $be;
$pend{$svc->{name}}->{$ipport} = $now - $be->{create_time};
}
}
foreach my $name (sort keys %pend) {
foreach my $ipport (sort keys %{$pend{$name}}) {
$out->("$name $ipport $pend{$name}{$ipport}");
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^states(?:\s+(.+))?$/) {
my $sf = Perlbal::Socket->get_sock_ref;
my $svc;
if (defined $1) {
$svc = $service{$1};
return $err->("Service not found.")
unless defined $svc;
}
my %states; # { "Class" => { "State" => int count; } }
foreach my $sock (values %$sf) {
my $state = $sock->state;
next unless defined $state;
if (defined $svc) {
next unless $sock->isa('Perlbal::ClientProxy') ||
$sock->isa('Perlbal::BackendHTTP') ||
$sock->isa('Perlbal::ClientHTTP');
next unless $sock->{service} == $svc;
}
$states{ref $sock}->{$state}++;
}
# now print out text
foreach my $class (sort keys %states) {
foreach my $state (sort keys %{$states{$class}}) {
$out->("$class $state " . $states{$class}->{$state});
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^queues$/) {
my $now = time;
foreach my $svc (values %service) {
next unless $svc->{role} eq 'reverse_proxy';
my ($age, $count) = (0, scalar(@{$svc->{waiting_clients}}));
my Perlbal::ClientProxy $oldest = $svc->{waiting_clients}->[0];
$age = $now - $oldest->{last_request_time} if defined $oldest;
$out->("$svc->{name}-normal.age $age");
$out->("$svc->{name}-normal.count $count");
($age, $count) = (0, scalar(@{$svc->{waiting_clients_highpri}}));
$oldest = $svc->{waiting_clients_highpri}->[0];
$age = $now - $oldest->{last_request_time} if defined $oldest;
$out->("$svc->{name}-highpri.age $age");
$out->("$svc->{name}-highpri.count $count");
}
$out->('.');
return 1;
}
if ($cmd =~ /^state changes$/) {
my $hr = Perlbal::Socket->get_statechange_ref;
my %final; # { "state" => count }
while (my ($obj, $arref) = each %$hr) {
$out->("$obj: " . join(', ', @$arref));
$final{$arref->[-1]}++;
}
foreach my $k (sort keys %final) {
$out->("$k $final{$k}");
}
$out->('.');
return 1;
}
# iterates over active objects. if you specify an argument, it is treated as code
# with $_ being the reference to the object.
if ($cmd =~ /^leaks(?:\s+(.+))?$/) {
# shows objects that we think might have been leaked
my $ref = Perlbal::Socket::get_created_objects_ref;
foreach (@$ref) {
next unless $_; # might be undef!
if ($1) {
my $rv = eval "$1";
return $err->("$@") if $@;
next unless defined $rv;
$out->($rv);
} else {
$out->($_->as_string);
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^show service (\w+)$/) {
my $sname = $1;
my Perlbal::Service $svc = $service{$sname};
return $err->("Unknown service") unless $svc;
$svc->stats_info($out);
$out->('.');
return 1;
}
if ($cmd =~ /^server (\S+) ?= ?(.+)$/) {
my ($key, $val) = ($1, $2);
if ($key =~ /^max_reproxy_connections(?:\((.+)\))?/) {
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
my $hostip = $1;
if (defined $hostip) {
$Perlbal::ReproxyManager::ReproxyMax{$hostip} = $val+0;
} else {
$Perlbal::ReproxyManager::ReproxyGlobalMax = $val+0;
}
} elsif ($key eq "max_connections") {
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
my $rv = setrlimit(RLIMIT_NOFILE, $val, $val);
unless (defined $rv && $rv) {
if ($> == 0) {
$err->("Unable to set limit.");
} else {
$err->("Need to be root to increase max connections.");
}
}
} elsif ($key eq "nice_level") {
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
my $rv = POSIX::nice($val);
$err->("Unable to renice: $!")
unless defined $rv;
} elsif ($key eq "aio_threads") {
return $err->("Expected numeric parameter") unless $val =~ /^-?\d+$/;
Linux::AIO::min_parallel($val)
if $Perlbal::OPTMOD_LINUX_AIO;
IO::AIO::min_parallel($val)
if $Perlbal::OPTMOD_IO_AIO;
} elsif ($key =~ /^track_obj/) {
return $err->("Expected 1 or 0") unless $val eq '1' || $val eq '0';
$track_obj = $val + 0;
%ObjTrack = () if $val; # if we're turning it on, clear it out
} elsif ($key eq "aio_mode") {
return $err->("Unknown AIO mode") unless $val =~ /^none|linux|ioaio$/;
return $err->("Linux::AIO not available") if $val eq "linux" && ! $Perlbal::OPTMOD_LINUX_AIO;
return $err->("IO::AIO not available") if $val eq "ioaio" && ! $Perlbal::OPTMOD_IO_AIO;
$Perlbal::AIO_MODE = $val;
return $ok->();
}
return $ok->();
}
if ($cmd =~ /^reproxy_state/) {
Perlbal::ReproxyManager::dump_state($out);
return $ok->();
}
if ($cmd =~ /^create service (\w+)$/) {
my $name = $1;
return $err->("service '$name' already exists") if $service{$name};
return $err->("pool '$name' already exists") if $pool{$name};
$service{$name} = Perlbal::Service->new($name);
return $ok->();
}
if ($cmd =~ /^create pool (\w+)$/) {
my $name = $1;
return $err->("pool '$name' already exists") if $pool{$name};
return $err->("service '$name' already exists") if $service{$name};
$vivify_pools = 0;
$pool{$name} = Perlbal::Pool->new($name);
return $ok->();
}
# pool add <pool> <ipport>
# pool <pool> add <ipport>
# ... or 'remove' instead of 'add'
if ($cmd =~ /^pool (\w+) (\w+) (\d+.\d+.\d+.\d+)(?::(\d+))?$/) {
my ($cmd, $name, $ip, $port) = ($1, $2, $3, $4 || 80);
if ($name =~ /^(?:add|remove)$/) {
($cmd, $name) = ($name, $cmd);
}
my $pl = $pool{$name};
return $err->("Pool '$name' not found") unless $pl;
$pl->$cmd($ip, $port);
return $ok->();
}
if ($cmd =~ /^show pool(?:\s+(\w+))?$/) {
my $pool = $1;
if ($pool) {
my $pl = $pool{$pool};
return $err->("pool '$pool' does not exist") unless $pl;
foreach my $node (@{ $pl->nodes }) {
my $ipport = "$node->[0]:$node->[1]";
$out->($ipport . " " . $pl->node_used($ipport));
}
} else {
foreach my $name (sort keys %pool) {
my Perlbal::Pool $pl = $pool{$name};
$out->("$name nodes $pl->{node_count}");
$out->("$name services $pl->{use_count}");
}
}
$out->('.');
return 1;
}
if ($cmd =~ /^show service$/) {
foreach my $name (sort keys %service) {
my $svc = $service{$name};
$out->("$name $svc->{listen} " . ($svc->{enabled} ? "ENABLED" : "DISABLED"));
}
$out->('.');
return 1;
}
if ($cmd =~ /^set (\w+)\.([\w\.]+) ?= ?(.+)$/) {
my ($name, $key, $val) = ($1, $2, $3);
if (my Perlbal::Service $svc = $service{$name}) {
return $svc->set($key, $val, $out, $verbose);
} elsif (my Perlbal::Pool $pl = $pool{$name}) {
return $pl->set($key, $val, $out, $verbose);
}
return $err->("service/pool '$name' does not exist");
}
if ($orig =~ /^header\s+(\w+)\s+(\w+)\s+(.+?)(?:\s*:\s*(.+))?$/i) {
my ($mode, $name, $header, $val) = (lc $1, lc $2, $3, $4);
return $err->("format: header <insert|remove> <service> <header>[: <value>]")
unless $mode =~ /^(?:insert|remove)$/;
my $svc = $service{$name};
return $err->("service '$name' does not exist") unless $svc;
return $ok->()
if $svc->header_management($mode, $header, $val, $out);
}
if ($cmd =~ /^(disable|enable) (\w+)$/) {
my ($verb, $name) = ($1, $2);
my $svc = $service{$name};
return $err->("service '$name' does not exist") unless $svc;
return $ok->()
if $svc->$verb($out);
}
if ($cmd =~ /^(un)?load (\w+)$/) {
my $un = $1 ? $1 : '';
my $fn = $2;
if (length $fn) {
# since we lowercase our input, uppercase the first character here
$fn = uc($1) . lc($2) if $fn =~ /^(.)(.*)$/;
eval "use Perlbal::Plugin::$fn; Perlbal::Plugin::$fn->${un}load;";
return $err->($@) if $@;
$plugins{$fn} = $un ? 0 : 1;
}
return $ok->();
}
if ($cmd =~ /^plugins$/) {
foreach my $svc (values %service) {
next unless @{$svc->{plugin_order}};
$out->(join(' ', $svc->{name}, @{$svc->{plugin_order}}));
}
$out->('.');
return 1;
}
# call any hooks if they've been defined
my $lcmd = $cmd =~ /^(.+?)\s+/ ? $1 : $cmd;
my $rval = run_global_hook("manage_command.$lcmd", $cmd);
return $out->($rval, '.') if defined $rval;
return $err->("unknown command: $cmd");
}
sub load_config {
my ($file, $writer) = @_;
open (F, $file) or die "Error opening config file ($file): $!\n";
my $verbose = 0;
while (<F>) {
if ($_ =~ /^verbose (on|off)/i) {
$verbose = (lc $1 eq 'on' ? 1 : 0);
next;
}
return 0 unless run_manage_command($_, $writer, $verbose);
}
close(F);
return 1;
}
sub daemonize {
my($pid, $sess_id, $i);
# note that we're not in the foreground (for logging purposes)
$foreground = 0;
# required before fork: (as of Linux::AIO 1.1, but may change)
Linux::AIO::max_parallel(0)
if $Perlbal::OPTMOD_LINUX_AIO;
IO::AIO::max_parallel(0)
if $Perlbal::OPTMOD_IO_AIO;
## Fork and exit parent
if ($pid = fork) { exit 0; }
## Detach ourselves from the terminal
croak "Cannot detach from controlling terminal"
unless $sess_id = POSIX::setsid();
## Prevent possibility of acquiring a controling terminal
$SIG{'HUP'} = 'IGNORE';
if ($pid = fork) { exit 0; }
## Change working directory
chdir "/";
## Clear file creation mask
umask 0;
## Close open file descriptors
close(STDIN);
close(STDOUT);
close(STDERR);
## Reopen stderr, stdout, stdin to /dev/null
open(STDIN, "+>/dev/null");
open(STDOUT, "+>&STDIN");
open(STDERR, "+>&STDIN");
}
sub run {
# setup for logging
openlog('perlbal', 'pid', 'daemon');
Perlbal::log('info', 'beginning run');
# number of AIO threads. the number of outstanding requests isn't
# affected by this
Linux::AIO::min_parallel(3) if $Perlbal::OPTMOD_LINUX_AIO;
IO::AIO::min_parallel(3) if $Perlbal::OPTMOD_IO_AIO;
# register Linux::AIO's pipe which gets written to from threads
# doing blocking IO
if ($Perlbal::OPTMOD_LINUX_AIO) {
Perlbal::Socket->AddOtherFds(Linux::AIO::poll_fileno() =>
\&Linux::AIO::poll_cb)
}
if ($Perlbal::OPTMOD_IO_AIO) {
Perlbal::Socket->AddOtherFds(IO::AIO::poll_fileno() =>
\&IO::AIO::poll_cb);
}
Danga::Socket->SetLoopTimeout(1000);
Danga::Socket->SetPostLoopCallback(sub {
Perlbal::Socket::run_callbacks();
return 1;
});
# begin the overall loop to try to capture if Perlbal dies at some point
# so we can have a log of it
eval {
# wait for activity
Perlbal::Socket->EventLoop();
};
# closing messages
if ($@) {
Perlbal::log('crit', "crash log: $_") foreach split(/\r?\n/, $@);
}
Perlbal::log('info', 'ending run');
closelog();
}
sub log {
# simple logging functionality
if ($foreground) {
# syslog acts like printf so we have to use printf and append a \n
shift; # ignore the first parameter (info, warn, critical, etc)
printf(shift(@_) . "\n", @_);
} else {
# just pass the parameters to syslog
syslog(@_);
}
}
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:
1;

101
wcmtools/perlbal/lib/Perlbal/AIO.pm Executable file
View File

@@ -0,0 +1,101 @@
package Perlbal::AIO;
use POSIX qw();
sub aio_stat {
my ($file, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_stat($file, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_stat($file, $cb);
} else {
stat($file);
$cb->();
}
}
sub _fh_of_fd_mode {
my ($fd, $mode) = @_;
return undef unless defined $fd && $fd >= 0;
#TODO: use the write MODE for the given $mode;
my $fh = IO::Handle->new_from_fd($fd, 'r+');
my $num = fileno($fh);
return $fh;
}
sub aio_open {
my ($file, $flags, $mode, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_open($file, $flags, $mode, sub {
my $fd = shift;
my $fh = _fh_of_fd_mode($fd, $mode);
$cb->($fh);
});
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_open($file, $flags, $mode, $cb);
} else {
my $fh;
my $rv = sysopen($fh, $file, $flags, $mode);
$cb->($rv ? $fh : undef);
}
}
sub aio_unlink {
my ($file, $cb) = @_;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_unlink($file, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_unlink($file, $cb);
} else {
my $rv = unlink($file);
$rv = $rv ? 0 : -1;
$cb->($rv);
}
}
sub aio_write {
# 0 1 2 3(data) 4
my ($fh, $offset, $length, undef, $cb) = @_;
return no_fh($cb) unless $fh;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_write($fh, $offset, $length, $_[3], 0, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_write($fh, $offset, $length, $_[3], 0, $cb);
} else {
my $rv = syswrite($fh, $_[3], $length, $offset);
$cb->($rv);
}
}
sub aio_read {
# 0 1 2 3(data) 4
my ($fh, $offset, $length, undef, $cb) = @_;
return no_fh($cb) unless $fh;
if ($Perlbal::AIO_MODE eq "linux") {
Linux::AIO::aio_read($fh, $offset, $length, $_[3], 0, $cb);
} elsif ($Perlbal::AIO_MODE eq "ioaio") {
IO::AIO::aio_read($fh, $offset, $length, $_[3], 0, $cb);
} else {
my $rv = sysread($fh, $_[3], $length, $offset);
$cb->($rv);
}
}
sub no_fh {
my $cb = shift;
my $i = 1;
my $stack_trace = "";
while (my ($pkg, $filename, $line, $subroutine, $hasargs,
$wantarray, $evaltext, $is_require, $hints, $bitmask) = caller($i++)) {
$stack_trace .= " at $filename:$line $subroutine\n";
}
Perlbal::log("crit", "Undef \$fh: $stack_trace");
$cb->(undef);
return undef;
}
1;

570
wcmtools/perlbal/lib/Perlbal/BackendHTTP.pm Executable file
View File

@@ -0,0 +1,570 @@
######################################################################
# HTTP connection to backend node
# possible states: connecting, bored, sending_req, wait_res, xfer_res
######################################################################
package Perlbal::BackendHTTP;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('client', # Perlbal::ClientProxy connection, or undef
'service', # Perlbal::Service
'pool', # Perlbal::Pool; whatever pool we spawned from
'ip', # IP scalar
'port', # port scalar
'ipport', # "$ip:$port"
'reportto', # object; must implement reporter interface
'has_attention', # has been accepted by a webserver and
# we know for sure we're not just talking
# to the TCP stack
'waiting_options', # if true, we're waiting for an OPTIONS *
# response to determine when we have attention
'disconnect_at', # time this connection will be disconnected,
# if it's kept-alive and backend told us.
# otherwise undef for unknown.
# The following only apply when the backend server sends
# a content-length header
'content_length', # length of document being transferred
'content_length_remain', # bytes remaining to be read
'use_count', # number of requests this backend's been used for
'generation', # int; counts what generation we were spawned in
);
use Socket qw(PF_INET IPPROTO_TCP SOCK_STREAM);
use Perlbal::ClientProxy;
# if this is made too big, (say, 128k), then perl does malloc instead
# of using its slab cache.
use constant BACKEND_READ_SIZE => 61449; # 60k, to fit in a 64k slab
# keys set here when an endpoint is found to not support persistent
# connections and/or the OPTIONS method
our %NoVerify; # { "ip:port" => next-verify-time }
our %NodeStats; # { "ip:port" => { ... } }; keep statistics about nodes
# constructor for a backend connection takes a service (pool) that it's
# for, and uses that service to get its backend IP/port, as well as the
# client that will be using this backend connection. final parameter is
# an options hashref that contains some options:
# reportto => object obeying reportto interface
sub new {
my ($class, $svc, $ip, $port, $opts) = @_;
$opts ||= {};
my $sock;
socket $sock, PF_INET, SOCK_STREAM, IPPROTO_TCP;
unless ($sock && defined fileno($sock)) {
Perlbal::log('crit', "Error creating socket: $!");
return undef;
}
IO::Handle::blocking($sock, 0);
connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($ip));
my $self = fields::new($class);
$self->SUPER::new($sock);
Perlbal::objctor($self);
$self->{ip} = $ip; # backend IP
$self->{port} = $port; # backend port
$self->{ipport} = "$ip:$port"; # often used as key
$self->{service} = $svc; # the service we're serving for
$self->{pool} = $opts->{pool}; # what pool we came from.
$self->{reportto} = $opts->{reportto} || $svc; # reportto if specified
$self->state("connecting");
# mark another connection to this ip:port
$NodeStats{$self->{ipport}}->{attempts}++;
$NodeStats{$self->{ipport}}->{lastattempt} = $self->{create_time};
# setup callback in case we get stuck in connecting land
Perlbal::Socket::register_callback(15, sub {
if ($self->state eq 'connecting' || $self->state eq 'verifying_backend') {
# shouldn't still be connecting/verifying ~15 seconds after create
$self->close('callback_timeout');
}
return 0;
});
# for header reading:
$self->{req_headers} = undef;
$self->{res_headers} = undef; # defined w/ headers object once all headers in
$self->{headers_string} = ""; # blank to start
$self->{read_buf} = []; # scalar refs of bufs read from client
$self->{read_ahead} = 0; # bytes sitting in read_buf
$self->{read_size} = 0; # total bytes read from client
$self->{client} = undef; # Perlbal::ClientProxy object, initially empty
# until we ask our service for one
$self->{has_attention} = 0;
$self->{use_count} = 0;
$self->{generation} = $opts->{generation};
bless $self, ref $class || $class;
$self->watch_write(1);
return $self;
}
sub close {
my Perlbal::BackendHTTP $self = shift;
# don't close twice
return if $self->{closed};
# this closes the socket and sets our closed flag
$self->SUPER::close(@_);
# tell our client that we're gone
if (my $client = $self->{client}) {
$client->backend(undef);
$self->{client} = undef;
}
# tell our owner that we're gone
if (my $reportto = $self->{reportto}) {
$reportto->note_backend_close($self);
$self->{reportto} = undef;
}
}
# return our defined generation counter with no parameter,
# or set our generation if given a parameter
sub generation {
my Perlbal::BackendHTTP $self = $_[0];
return $self->{generation} unless $_[1];
return $self->{generation} = $_[1];
}
# return what ip and port combination we're using
sub ipport {
my Perlbal::BackendHTTP $self = $_[0];
return $self->{ipport};
}
# called by service when it's got a client for us, or by ourselves
# when we asked for a client.
# returns true if client assignment was accepted.
sub assign_client {
my Perlbal::BackendHTTP $self = shift;
my Perlbal::ClientProxy $client = shift;
return 0 if $self->{client};
# set our client, and the client's backend to us
$self->{service}->mark_node_used($self->{ipport});
$self->{client} = $client;
$self->state("sending_req");
$self->{client}->backend($self);
my Perlbal::HTTPHeaders $hds = $client->{req_headers}->clone;
$self->{req_headers} = $hds;
# Use HTTP/1.0 to backend (FIXME: use 1.1 and support chunking)
$hds->set_version("1.0");
my $persist = $self->{service}{persist_backend};
$hds->header("Connection", $persist ? "keep-alive" : "close");
$hds->header("X-Proxy-Capabilities", "reproxy-file");
# decide whether we trust the upstream or not
my $trust = $self->{service}->{always_trusted}; # set to default auto-trust level
if ($self->{service} && $self->{service}->{trusted_upstreams}) {
$trust = 1
if $self->{service}->{trusted_upstreams}->match($client->peer_ip_string);
}
# if we're not going to trust the upstream, reset these for security reasons
unless ($trust) {
$hds->header("X-Forwarded-For", $client->peer_ip_string);
$hds->header("X-Host", undef);
$hds->header("X-Forwarded-Host", undef);
}
$self->tcp_cork(1);
$client->state('backend_req_sent');
$self->{content_length} = undef;
$self->{content_length_remain} = undef;
# run hooks
return 1 if $self->{service}->run_hook('backend_client_assigned', $self);
# now cleanup the headers before we send to the backend
$self->{service}->munge_headers($hds) if $self->{service};
$self->write($hds->to_string_ref);
$self->write(sub {
$self->tcp_cork(0);
if (my $client = $self->{client}) {
# start waiting on a reply
$self->watch_read(1);
$self->state("wait_res");
$client->state('wait_res');
# make the client push its overflow reads (request body)
# to the backend
$client->drain_read_buf_to($self);
# and start watching for more reads
$client->watch_read(1);
}
});
return 1;
}
# Backend
sub event_write {
my Perlbal::BackendHTTP $self = shift;
print "Backend $self is writeable!\n" if Perlbal::DEBUG >= 2;
my $now = time();
delete $NoVerify{$self->{ipport}} if
defined $NoVerify{$self->{ipport}} &&
$NoVerify{$self->{ipport}} < $now;
if (! $self->{client} && $self->{state} eq "connecting") {
# not interested in writes again until something else is
$self->watch_write(0);
$NodeStats{$self->{ipport}}->{connects}++;
$NodeStats{$self->{ipport}}->{lastconnect} = $now;
if (defined $self->{service} && $self->{service}->{verify_backend} &&
!$self->{has_attention} && !defined $NoVerify{$self->{ipport}}) {
# the backend should be able to answer this incredibly quickly.
$self->write("OPTIONS * HTTP/1.0\r\nConnection: keep-alive\r\n\r\n");
$self->watch_read(1);
$self->{waiting_options} = 1;
$self->{content_length_remain} = undef;
$self->state("verifying_backend");
} else {
# register our boredom (readiness for a client/request)
$self->state("bored");
$self->{reportto}->register_boredom($self);
}
return;
}
my $done = $self->write(undef);
$self->watch_write(0) if $done;
}
sub verify_failure {
my Perlbal::BackendHTTP $self = shift;
$NoVerify{$self->{ipport}} = time() + 60;
$self->{reportto}->note_bad_backend_connect($self);
$self->close('no_keep_alive');
return;
}
# Backend
sub event_read {
my Perlbal::BackendHTTP $self = shift;
print "Backend $self is readable!\n" if Perlbal::DEBUG >= 2;
if ($self->{waiting_options}) {
if ($self->{content_length_remain}) {
# the HTTP/1.1 spec says OPTIONS responses can have content-lengths,
# but the meaning of the response is reserved for a future spec.
# this just gobbles it up for.
my $bref = $self->read(BACKEND_READ_SIZE);
return $self->verify_failure unless defined $bref;
$self->{content_length_remain} -= length($$bref);
} elsif (my $hd = $self->read_response_headers) {
# see if we have keep alive support
return $self->verify_failure unless $hd->res_keep_alive($self->{req_headers});
$self->{content_length_remain} = $hd->header("Content-Length");
}
# if we've got the option response and read any response data
# if present:
if ($self->{res_headers} && ! $self->{content_length_remain}) {
# other setup to mark being done with options checking
$self->{waiting_options} = 0;
$self->{has_attention} = 1;
$NodeStats{$self->{ipport}}->{verifies}++;
$self->next_request(1); # initial
}
return;
}
my Perlbal::ClientProxy $client = $self->{client};
# with persistent connections, sometimes we have a backend and
# no client, and backend becomes readable, either to signal
# to use the end of the stream, or because a bad request error,
# which I can't totally understand. in any case, we have
# no client so all we can do is close this backend.
return $self->close('read_with_no_client') unless $client;
unless ($self->{res_headers}) {
if (my $hd = $self->read_response_headers) {
# note we got this response code
my $ref = ($NodeStats{$self->{ipport}}->{responsecodes} ||= []);
push @$ref, $hd->response_code;
if (scalar(@$ref) > 500) {
shift @$ref;
}
# call service response received function
return if $self->{reportto}->backend_response_received($self);
# standard handling
$self->state("xfer_res");
$client->state("xfer_res");
$self->{has_attention} = 1;
# RFC 2616, Sec 4.4: Messages MUST NOT include both a
# Content-Length header field and a non-identity
# transfer-coding. If the message does include a non-
# identity transfer-coding, the Content-Length MUST be
# ignored.
my $te = $hd->header("Transfer-Encoding");
if ($te && $te !~ /\bidentity\b/i) {
$hd->header("Content-Length", undef);
}
my Perlbal::HTTPHeaders $rqhd = $self->{req_headers};
# setup our content length so we know how much data to expect, in general
# we want the content-length from the response, but if this was a head request
# we know it's a 0 length message the client wants
if ($rqhd->request_method eq 'HEAD') {
$self->{content_length} = 0;
} else {
$self->{content_length} = $hd->content_length;
}
$self->{content_length_remain} = $self->{content_length} || 0;
if (my $rep = $hd->header('X-REPROXY-FILE')) {
# make the client begin the async IO while we move on
$client->start_reproxy_file($rep, $hd);
$self->next_request;
return;
} elsif (my $urls = $hd->header('X-REPROXY-URL')) {
$client->start_reproxy_uri($self->{res_headers}, $urls);
$self->next_request;
return;
} else {
my $res_source = $client->{primary_res_hdrs} || $hd;
my $thd = $client->{res_headers} = $res_source->clone;
# setup_keepalive will set Connection: and Keep-Alive: headers for us
# as well as setup our HTTP version appropriately
$client->setup_keepalive($thd);
# if we had an alternate primary response header, make sure
# we send the real content-length (from the reproxied URL)
# and not the one the first server gave us
if ($client->{primary_res_hdrs}) {
$thd->header('Content-Length', $hd->header('Content-Length'));
$thd->header('X-REPROXY-FILE', undef);
$thd->header('X-REPROXY-URL', undef);
$thd->header('X-REPROXY-EXPECTED-SIZE', undef);
}
$client->write($thd->to_string_ref);
# if we over-read anything from backend (most likely)
# then decrement it from our count of bytes we need to read
if (defined $self->{content_length}) {
$self->{content_length_remain} -= $self->{read_ahead};
}
$self->drain_read_buf_to($client);
if (defined $self->{content_length} && ! $self->{content_length_remain}) {
# order important: next_request detaches us from client, so
# $client->close can't kill us
$self->next_request;
$client->write(sub { $client->backend_finished; });
}
}
}
return;
}
# if our client's behind more than the max limit, stop buffering
my $buf_size = defined $self->{service} ? $client->{service}->{buffer_size} : $client->{service}->{buffer_size_reproxy_url};
if ($client->{write_buf_size} > $buf_size) {
$self->watch_read(0);
return;
}
my $bref = $self->read(BACKEND_READ_SIZE);
if (defined $bref) {
$client->write($bref);
# HTTP/1.0 keep-alive support to backend. we just count bytes
# until we hit the end, then we know we can send another
# request on this connection
if ($self->{content_length}) {
$self->{content_length_remain} -= length($$bref);
if (! $self->{content_length_remain}) {
# order important: next_request detaches us from client, so
# $client->close can't kill us
$self->next_request;
$client->write(sub { $client->backend_finished; });
}
}
return;
} else {
# backend closed
print "Backend $self is done; closing...\n" if Perlbal::DEBUG >= 1;
$client->backend(undef); # disconnect ourselves from it
$self->{client} = undef; # .. and it from us
$self->close('backend_disconnect'); # close ourselves
$client->write(sub { $client->backend_finished; });
return;
}
}
# if $initial is on, then don't increment use count
sub next_request {
my Perlbal::BackendHTTP $self = $_[0];
my $initial = $_[1];
# don't allow this if we're closed
return if $self->{closed};
# set alive_time so reproxy can intelligently reuse this backend
my $now = time();
$self->{alive_time} = $now;
$NodeStats{$self->{ipport}}->{requests}++ unless $initial;
$NodeStats{$self->{ipport}}->{lastresponse} = $now;
my $hd = $self->{res_headers}; # response headers
# verify that we have keep-alive support
return $self->close('next_request_no_persist')
unless $hd->res_keep_alive($self->{req_headers});
# and now see if we should closed based on the pool we're from
return $self->close('pool_requested_closure')
if $self->{pool} && ! $self->{pool}->backend_should_live($self);
# we've been used
$self->{use_count}++ unless $initial;
# service specific
if (my Perlbal::Service $svc = $self->{service}) {
# keep track of how many times we've been used, and don't
# keep using this connection more times than the service
# is configured for.
if ($svc->{max_backend_uses} && ($self->{use_count} > $svc->{max_backend_uses})) {
return $self->close('exceeded_max_uses');
}
}
# if backend told us, keep track of when the backend
# says it's going to boot us, so we don't use it within
# a few seconds of that time
if (($hd->header("Keep-Alive") || '') =~ /\btimeout=(\d+)/i) {
$self->{disconnect_at} = $now + $1;
} else {
$self->{disconnect_at} = undef;
}
$self->{client} = undef;
$self->state("bored");
$self->watch_write(0);
$self->{req_headers} = undef;
$self->{res_headers} = undef;
$self->{headers_string} = "";
$self->{req_headers} = undef;
$self->{read_size} = 0;
$self->{content_length_remain} = undef;
$self->{content_length} = undef;
$self->{reportto}->register_boredom($self);
return;
}
# Backend: bad connection to backend
sub event_err {
my Perlbal::BackendHTTP $self = shift;
# FIXME: we get this after backend is done reading and we disconnect,
# hence the misc checks below for $self->{client}.
print "BACKEND event_err\n" if
Perlbal::DEBUG >= 2;
if ($self->{client}) {
# request already sent to backend, then an error occurred.
# we don't want to duplicate POST requests, so for now
# just fail
# TODO: if just a GET request, retry?
$self->{client}->close('backend_error');
$self->close('error');
return;
}
if ($self->{state} eq "connecting" ||
$self->{state} eq "verifying_backend") {
# then tell the service manager that this connection
# failed, so it can spawn a new one and note the dead host
$self->{reportto}->note_bad_backend_connect($self, 1);
}
# close ourselves first
$self->close("error");
}
# Backend
sub event_hup {
my Perlbal::BackendHTTP $self = shift;
print "HANGUP for $self\n" if Perlbal::DEBUG;
$self->close("after_hup");
}
sub as_string {
my Perlbal::BackendHTTP $self = shift;
my $ret = $self->SUPER::as_string;
my $name = $self->{sock} ? getsockname($self->{sock}) : undef;
my $lport = $name ? (Socket::sockaddr_in($name))[0] : undef;
$ret .= ": localport=$lport" if $lport;
if (my Perlbal::ClientProxy $cp = $self->{client}) {
$ret .= "; client=$cp->{fd}";
}
$ret .= "; uses=$self->{use_count}; $self->{state}";
if (defined $self->{service} && $self->{service}->{verify_backend}) {
$ret .= "; has_attention=";
$ret .= $self->{has_attention} ? 'yes' : 'no';
}
return $ret;
}
sub die_gracefully {
# see if we need to die
my Perlbal::BackendHTTP $self = shift;
$self->close('graceful_death') if $self->state eq 'bored';
}
sub DESTROY {
Perlbal::objdtor($_[0]);
$_[0]->SUPER::DESTROY;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

339
wcmtools/perlbal/lib/Perlbal/ClientHTTP.pm Executable file
View File

@@ -0,0 +1,339 @@
######################################################################
# HTTP Connection from a reverse proxy client. GET/HEAD only.
# most functionality is implemented in the base class.
######################################################################
package Perlbal::ClientHTTP;
use strict;
use warnings;
use base "Perlbal::ClientHTTPBase";
use fields ('put_in_progress', # 1 when we're currently waiting for an async job to return
'put_fh', # file handle to use for writing data
'put_pos', # file offset to write next data at
'content_length', # length of document being transferred
'content_length_remain', # bytes remaining to be read
);
use HTTP::Date ();
use File::Path;
use Errno qw( EPIPE );
use POSIX qw( O_CREAT O_TRUNC O_WRONLY O_RDONLY ENOENT );
# class list of directories we know exist
our (%VerifiedDirs);
sub new {
my $class = shift;
my $self = fields::new($class);
$self->SUPER::new(@_);
$self->{put_in_progress} = 0;
$self->{put_fh} = undef;
$self->{put_pos} = 0;
return $self;
}
sub close {
my Perlbal::ClientHTTP $self = shift;
# don't close twice
return if $self->{closed};
$self->{put_fh} = undef;
$self->SUPER::close(@_);
}
sub send_response {
my Perlbal::ClientHTTP $self = shift;
$self->watch_read(0);
$self->watch_write(1);
return $self->_simple_response(@_);
}
sub event_read {
my Perlbal::ClientHTTP $self = shift;
# see if we have headers?
if ($self->{req_headers}) {
if ($self->{req_headers}->request_method eq 'PUT') {
# read in data and shove it on the read buffer
if (defined (my $dataref = $self->read($self->{content_length_remain}))) {
# got some data
$self->{read_buf} .= $$dataref;
my $clen = length($$dataref);
$self->{read_size} += $clen;
$self->{content_length_remain} -= $clen;
# handle put if we should
$self->handle_put if $self->{read_size} >= 8192; # arbitrary
# now, if we've filled the content of this put, we're done
unless ($self->{content_length_remain}) {
$self->watch_read(0);
$self->handle_put;
}
} else {
# undefined read, user closed on us
$self->close('remote_closure');
}
} else {
# since we have headers and we're not doing any special
# handling above, let's just disable read notification, because
# we won't do anything with the data
$self->watch_read(0);
}
return;
}
# try and get the headers, if they're all here
my $hd = $self->read_request_headers;
return unless $hd;
# fully formed request received
$self->{requests}++;
# notify that we're about to serve
return if $self->{service}->run_hook('start_web_request', $self);
# see what method it is?
if ($hd->request_method eq 'GET' || $hd->request_method eq 'HEAD') {
# and once we have it, start serving
$self->watch_read(0);
return $self->_serve_request($hd);
} elsif ($self->{service}->{enable_put} && $hd->request_method eq 'PUT') {
# they want to put something, so let's setup and wait for more reads
my $clen = $hd->header('Content-length') + 0;
# return a 400 (bad request) if we got no content length or if it's
# bigger than any specified max put size
return $self->send_response(400, "Content-length of $clen is invalid.")
if !$clen ||
($self->{service}->{max_put_size} &&
$clen > $self->{service}->{max_put_size});
# if we have some data already from a header over-read, handle it by
# flattening it down to a single string as opposed to an array of stuff
if (defined $self->{read_size} && $self->{read_size} > 0) {
my $data = '';
foreach my $rdata (@{$self->{read_buf}}) {
$data .= ref $rdata ? $$rdata : $rdata;
}
$self->{read_buf} = $data;
$self->{content_length} = $clen;
$self->{content_length_remain} = $clen - $self->{read_size};
} else {
# setup to read the file
$self->{read_buf} = '';
$self->{content_length} = $self->{content_length_remain} = $clen;
}
# setup the directory asynchronously
$self->setup_put;
return;
} elsif ($self->{service}->{enable_delete} && $hd->request_method eq 'DELETE') {
# delete a file
$self->watch_read(0);
return $self->setup_delete;
}
# else, bad request
return $self->send_response(400);
}
# called when we're requested to do a delete
sub setup_delete {
my Perlbal::ClientHTTP $self = shift;
# error in filename? (any .. is an error)
my $uri = $self->{req_headers}->request_uri;
return $self->send_response(400, 'Invalid filename')
if $uri =~ /\.\./;
# now we want to get the URI
if ($uri =~ m!^(?:/[\w\-\.]+)+$!) {
# now attempt the unlink
Perlbal::AIO::aio_unlink($self->{service}->{docroot} . '/' . $uri, sub {
my $err = shift;
if ($err == 0 && !$!) {
# delete was successful
return $self->send_response(204);
} elsif ($! == ENOENT) {
# no such file
return $self->send_response(404);
} else {
# failure...
return $self->send_response(400, "$!");
}
});
} else {
# bad URI, don't accept the delete
return $self->send_response(400, 'Invalid filename');
}
}
# called when we've got headers and are about to start a put
sub setup_put {
my Perlbal::ClientHTTP $self = shift;
return if $self->{service}->run_hook('setup_put', $self);
return if $self->{put_fh};
# error in filename? (any .. is an error)
my $uri = $self->{req_headers}->request_uri;
return $self->send_response(400, 'Invalid filename')
if $uri =~ /\.\./;
# now we want to get the URI
if ($uri =~ m!^((?:/[\w\-\.]+)*)/([\w\-\.]+)$!) {
# sanitize uri into path and file into a disk path and filename
my ($path, $filename) = ($1 || '', $2);
# verify minput if necessary
if ($self->{service}->{min_put_directory}) {
my @elems = grep { defined $_ && length $_ } split '/', $path;
return $self->send_response(400, 'Does not meet minimum directory requirement')
unless scalar(@elems) >= $self->{service}->{min_put_directory};
my $minput = '/' . join('/', splice(@elems, 0, $self->{service}->{min_put_directory}));
my $path = '/' . join('/', @elems);
return unless $self->verify_put($minput, $path, $filename);
}
# now we want to open this directory
my $lpath = $self->{service}->{docroot} . '/' . $path;
return $self->attempt_open($lpath, $filename);
} else {
# bad URI, don't accept the put
return $self->send_response(400, 'Invalid filename');
}
}
# verify that a minimum put directory exists
# return value: 1 means the directory is okay, continue
# 0 means we must verify the directory, stop processing
sub verify_put {
my Perlbal::ClientHTTP $self = shift;
my ($minput, $extrapath, $filename) = @_;
my $mindir = $self->{service}->{docroot} . '/' . $minput;
return 1 if $VerifiedDirs{$mindir};
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_open($mindir, O_RDONLY, 0755, sub {
my $fh = shift;
$self->{put_in_progress} = 0;
# if error return failure
return $self->send_response(404, "Base directory does not exist") unless $fh;
CORE::close($fh);
# mindir existed, mark it as so and start the open for the rest of the path
$VerifiedDirs{$mindir} = 1;
return $self->attempt_open($mindir . $extrapath, $filename);
});
return 0;
}
# attempt to open a file
sub attempt_open {
my Perlbal::ClientHTTP $self = shift;
my ($path, $file) = @_;
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_open("$path/$file", O_CREAT | O_TRUNC | O_WRONLY, 0644, sub {
# get the fd
my $fh = shift;
# verify file was opened
$self->{put_in_progress} = 0;
if (! $fh) {
if ($! == ENOENT) {
# directory doesn't exist, so let's manually create it
eval { File::Path::mkpath($path, 0, 0755); };
return $self->system_error("Unable to create directory", "path = $path, file = $file") if $@;
# should be created, call self recursively to try
return $self->attempt_open($path, $file);
} else {
return $self->system_error("Internal error", "error = $!, path = $path, file = $file");
}
}
$self->{put_fh} = $fh;
$self->{put_pos} = 0;
$self->handle_put;
});
}
# method that sends a 500 to the user but logs it and any extra information
# we have about the error in question
sub system_error {
my Perlbal::ClientHTTP $self = shift;
my ($msg, $info) = @_;
# log to syslog
Perlbal::log('warning', "system error: $msg ($info)");
# and return a 500
return $self->send_response(500, $msg);
}
# called when we've got some put data to write out
sub handle_put {
my Perlbal::ClientHTTP $self = shift;
return if $self->{service}->run_hook('handle_put', $self);
return if $self->{put_in_progress};
return unless $self->{put_fh};
return unless $self->{read_size};
# dig out data to write
my ($data, $count) = ($self->{read_buf}, $self->{read_size});
($self->{read_buf}, $self->{read_size}) = ('', 0);
# okay, file is open, write some data
$self->{put_in_progress} = 1;
Perlbal::AIO::aio_write($self->{put_fh}, $self->{put_pos}, $count, $data, sub {
return if $self->{closed};
# see how many bytes written
my $bytes = shift() + 0;
$self->{put_pos} += $bytes;
$self->{put_in_progress} = 0;
# now recursively call ourselves?
if ($self->{read_size}) {
$self->handle_put;
} else {
# we done putting this file?
unless ($self->{content_length_remain}) {
# close it
# FIXME this should be done through AIO
if ($self->{put_fh} && CORE::close($self->{put_fh})) {
$self->{put_fh} = undef;
return $self->send_response(200);
} else {
return $self->system_error("Error saving file", "error in close: $!");
}
}
}
});
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

480
wcmtools/perlbal/lib/Perlbal/ClientHTTPBase.pm Executable file
View File

@@ -0,0 +1,480 @@
######################################################################
# Common HTTP functionality for ClientProxy and ClientHTTP
# possible states:
# reading_headers (initial state, then follows one of two paths)
# wait_backend, backend_req_sent, wait_res, xfer_res, draining_res
# wait_stat, wait_open, xfer_disk
# both paths can then go into persist_wait, which means they're waiting
# for another request from the user
######################################################################
package main;
# loading syscall.ph into package main in case some other module wants
# to use it (like Danga::Socket, or whoever else)
eval { require 'syscall.ph'; 1 } || eval { require 'sys/syscall.ph'; 1 };
package Perlbal::ClientHTTPBase;
use strict;
use warnings;
use base "Perlbal::Socket";
use HTTP::Date ();
use fields ('service', # Perlbal::Service object
'replacement_uri', # URI to send instead of the one requested; this is used
# to instruct _serve_request to send an index file instead
# of trying to serve a directory and failing
'scratch', # extra storage; plugins can use it if they want
# reproxy support
'reproxy_file', # filename the backend told us to start opening
'reproxy_file_size', # size of file, once we stat() it
'reproxy_fh', # if needed, IO::Handle of fd
'reproxy_file_offset', # how much we've sent from the file.
'requests', # number of requests this object has performed for the user
);
use Errno qw( EPIPE ECONNRESET );
use POSIX ();
our $SYS_sendfile = &::SYS_sendfile;
# ghetto hard-coding. should let siteadmin define or something.
# maybe console/config command: AddMime <ext> <mime-type> (apache-style?)
our $MimeType = {qw(
css text/css
doc application/msword
gif image/gif
htm text/html
html text/html
jpg image/jpeg
js application/x-javascript
mp3 audio/mpeg
mpg video/mpeg
png image/png
tif image/tiff
tiff image/tiff
torrent application/x-bittorrent
txt text/plain
zip application/zip
)};
# ClientHTTPBase
sub new {
my ($class, $service, $sock) = @_;
my $self = $class;
$self = fields::new($class) unless ref $self;
$self->SUPER::new($sock); # init base fields
$self->{service} = $service;
$self->{replacement_uri} = undef;
$self->{headers_string} = '';
$self->state('reading_headers');
$self->{requests} = 0;
$self->{scratch} = {};
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
sub close {
my Perlbal::ClientHTTPBase $self = shift;
# don't close twice
return if $self->{closed};
# close the file we were reproxying, if any
CORE::close($self->{reproxy_fh}) if $self->{reproxy_fh};
# now pass up the line
$self->SUPER::close(@_);
}
# given our request headers, determine if we should be sending
# keep-alive header information back to the client
sub setup_keepalive {
my Perlbal::ClientHTTPBase $self = $_[0];
# now get the headers we're using
my Perlbal::HTTPHeaders $hd = $_[1];
my Perlbal::HTTPHeaders $rqhd = $self->{req_headers};
# for now, we enforce outgoing HTTP 1.0
$hd->set_version("1.0");
# do keep alive if they sent content-length or it's a head request
my $do_keepalive = $self->{service}->{persist_client} &&
$rqhd->req_keep_alive($hd);
if ($do_keepalive) {
my $timeout = $self->max_idle_time;
$hd->header('Connection', 'keep-alive');
$hd->header('Keep-Alive', $timeout ? "timeout=$timeout, max=100" : undef);
} else {
$hd->header('Connection', 'close');
$hd->header('Keep-Alive', undef);
}
}
# called when we've finished writing everything to a client and we need
# to reset our state for another request. returns 1 to mean that we should
# support persistence, 0 means we're discarding this connection.
sub http_response_sent {
my Perlbal::ClientHTTPBase $self = $_[0];
# close if we're supposed to
if (!defined $self->{res_headers} ||
$self->{res_headers}->header('Connection') =~ m/\bclose\b/i ||
$self->{do_die}) {
# close if we have no response headers or they say to close
$self->close("no_keep_alive");
return 0;
}
# now since we're doing persistence, uncork so the last packet goes.
# we will recork when we're processing a new request.
$self->tcp_cork(0);
# prepare!
$self->{replacement_uri} = undef;
$self->{headers_string} = '';
$self->{req_headers} = undef;
$self->{res_headers} = undef;
$self->{reproxy_fh} = undef;
$self->{reproxy_file} = undef;
$self->{reproxy_file_size} = 0;
$self->{reproxy_file_offset} = 0;
$self->{read_buf} = [];
$self->{read_ahead} = 0;
$self->{read_size} = 0;
$self->{scratch} = {};
# reset state
$self->state('persist_wait');
# NOTE: because we only speak 1.0 to clients they can't have
# pipeline in a read that we haven't read yet.
$self->watch_read(1);
$self->watch_write(0);
return 1;
}
use Carp qw(cluck);
sub reproxy_fh {
my Perlbal::ClientHTTPBase $self = shift;
# setter
if (@_) {
my ($fh, $size) = @_;
$self->state('xfer_disk');
$self->{reproxy_fh} = $fh;
$self->{reproxy_file_offset} = 0;
$self->{reproxy_file_size} = $size;
# call hook that we're reproxying a file
return $fh if $self->{service}->run_hook("start_send_file", $self);
# turn on writes (the hook might not have wanted us to)
$self->watch_write(1);
return $fh;
}
return $self->{reproxy_fh};
}
sub event_write {
my Perlbal::ClientHTTPBase $self = shift;
# Any HTTP client is considered alive if it's writable
# if it's not writable for 30 seconds, we kill it.
# subclasses can decide what's appropriate for timeout.
$self->{alive_time} = time;
if ($self->{reproxy_fh}) {
my $to_send = $self->{reproxy_file_size} - $self->{reproxy_file_offset};
$self->tcp_cork(1) if $self->{reproxy_file_offset} == 0;
my $sent = syscall($SYS_sendfile,
$self->{fd},
fileno($self->{reproxy_fh}),
0, # NULL offset means kernel moves offset
$to_send);
print "REPROXY Sent: $sent\n" if Perlbal::DEBUG >= 2;
if ($sent < 0) {
return $self->close("epipe") if $! == EPIPE;
return $self->close("connreset") if $! == ECONNRESET;
print STDERR "Error w/ sendfile: $!\n";
$self->close('sendfile_error');
return;
}
$self->{reproxy_file_offset} += $sent;
if ($sent >= $to_send) {
# close the sendfile fd
CORE::close($self->{reproxy_fh});
$self->{reproxy_fh} = undef;
$self->http_response_sent;
}
return;
}
if ($self->write(undef)) {
print "All writing done to $self\n" if Perlbal::DEBUG >= 2;
# we've written all data in the queue, so stop waiting for write
# notifications:
$self->watch_write(0);
}
}
# this gets called when a "web" service is serving a file locally.
sub _serve_request {
my Perlbal::ClientHTTPBase $self = shift;
my Perlbal::HTTPHeaders $hd = shift;
my $rm = $hd->request_method;
unless ($rm eq "HEAD" || $rm eq "GET") {
return $self->_simple_response(403, "Unimplemented method");
}
my $uri = _durl($self->{replacement_uri} || $hd->request_uri);
# don't allow directory traversal
if ($uri =~ /\.\./ || $uri !~ m!^/!) {
return $self->_simple_response(403, "Bogus URL");
}
my Perlbal::Service $svc = $self->{service};
# start_serve_request hook
return 1 if $self->{service}->run_hook('start_serve_request', $self, \$uri);
my $file = $svc->{docroot} . $uri;
# update state, since we're now waiting on stat
$self->state('wait_stat');
Perlbal::AIO::aio_stat($file, sub {
# client's gone anyway
return if $self->{closed};
return $self->_simple_response(404) unless -e _;
my $lastmod = HTTP::Date::time2str((stat(_))[9]);
my $not_mod = ($hd->header("If-Modified-Since") || "") eq $lastmod && -f _;
my $res;
my $not_satisfiable = 0;
my $size = -s _ if -f _;
my ($status, $range_start, $range_end) = $hd->range($size);
if ($not_mod) {
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(304);
} elsif ($status == 416) {
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(416);
$res->header("Content-Range", $size ? "*/$size" : "*");
$not_satisfiable = 1;
} elsif ($status == 206) {
# partial content
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(206);
} else {
$res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response(200);
}
# now set whether this is keep-alive or not
$res->header("Date", HTTP::Date::time2str());
$res->header("Server", "Perlbal");
$res->header("Last-Modified", $lastmod);
if (-f _) {
# advertise that we support byte range requests
$res->header("Accept-Ranges", "bytes");
unless ($not_mod && $not_satisfiable) {
my ($ext) = ($file =~ /\.(\w+)$/);
$res->header("Content-Type",
(defined $ext && exists $MimeType->{$ext}) ? $MimeType->{$ext} : "text/plain");
unless ($status == 206) {
$res->header("Content-Length", $size);
} else {
$res->header("Content-Range", "$range_start-$range_end/$size");
$res->header("Content-Length", $range_end-$range_start + 1);
}
}
# has to happen after content-length is set to work:
$self->setup_keepalive($res);
if ($rm eq "HEAD" || $not_mod || $not_satisfiable) {
# we can return already, since we know the size
$self->tcp_cork(1);
$self->state('xfer_resp');
$self->write($res->to_string_ref);
$self->write(sub { $self->http_response_sent; });
return;
}
# state update
$self->state('wait_open');
Perlbal::AIO::aio_open($file, 0, 0, sub {
my $rp_fh = shift;
# if client's gone, just close filehandle and abort
if ($self->{closed}) {
CORE::close($rp_fh) if $rp_fh;
return;
}
# handle errors
if (! $rp_fh) {
# couldn't open the file we had already successfully stat'ed.
# FIXME: do 500 vs. 404 vs whatever based on $!
return $self->close('aio_open_failure');
}
$self->state('xfer_disk');
$self->tcp_cork(1); # cork writes to self
$self->write($res->to_string_ref);
# seek if partial content
if ($status == 206) {
sysseek($rp_fh, $range_start, &POSIX::SEEK_SET);
$size = $range_end - $range_start + 1;
}
$self->reproxy_fh($rp_fh, $size);
});
} elsif (-d _) {
$self->try_index_files($hd, $res);
}
});
}
sub try_index_files {
my Perlbal::ClientHTTPBase $self = shift;
my ($hd, $res, $filepos) = @_;
# make sure this starts at 0 initially, and fail if it's past the end
$filepos ||= 0;
if ($filepos >= scalar(@{$self->{service}->{index_files} || []})) {
if ($self->{service}->{dirindexing}) {
# open the directory and create an index
my $body;
my $file = $self->{service}->{docroot} . '/' . $hd->request_uri;
$res->header("Content-Type", "text/html");
opendir(D, $file);
foreach my $de (sort readdir(D)) {
if (-d "$file/$de") {
$body .= "<b><a href='$de/'>$de</a></b><br />\n";
} else {
$body .= "<a href='$de'>$de</a><br />\n";
}
}
closedir(D);
$res->header("Content-Length", length($body));
$self->setup_keepalive($res);
$self->state('xfer_resp');
$self->tcp_cork(1); # cork writes to self
$self->write($res->to_string_ref);
$self->write(\$body);
$self->write(sub { $self->http_response_sent; });
} else {
# just inform them that listing is disabled
$self->_simple_response(200, "Directory listing disabled")
}
return;
}
# construct the file path we need to check
my $file = $self->{service}->{index_files}->[$filepos];
my $fullpath = $self->{service}->{docroot} . '/' . $hd->request_uri . '/' . $file;
# now see if it exists
Perlbal::AIO::aio_stat($fullpath, sub {
return if $self->{closed};
return $self->try_index_files($hd, $res, $filepos + 1) unless -f _;
# at this point the file exists, so we just want to serve it
$self->{replacement_uri} = $hd->request_uri . '/' . $file;
return $self->_serve_request($hd);
});
}
sub _simple_response {
my Perlbal::ClientHTTPBase $self = shift;
my ($code, $msg) = @_; # or bodyref
my $res = $self->{res_headers} = Perlbal::HTTPHeaders->new_response($code);
$res->header("Content-Type", "text/html");
my $body;
unless ($code == 204) {
my $en = $res->http_code_english;
$body = "<h1>$code" . ($en ? " - $en" : "") . "</h1>\n";
$body .= $msg if $msg;
$res->header('Content-Length', length($body));
}
$self->setup_keepalive($res);
$self->state('xfer_resp');
$self->tcp_cork(1); # cork writes to self
$self->write($res->to_string_ref);
if (defined $body) {
unless ($self->{req_headers} && $self->{req_headers}->request_method eq 'HEAD') {
# don't write body for head requests
$self->write(\$body);
}
}
$self->write(sub { $self->http_response_sent; });
return 1;
}
# FIXME: let this be configurable?
sub max_idle_time { 30; }
sub event_err { my $self = shift; $self->close('error'); }
sub event_hup { my $self = shift; $self->close('hup'); }
sub as_string {
my Perlbal::ClientHTTPBase $self = shift;
my $ret = $self->SUPER::as_string;
my $name = $self->{sock} ? getsockname($self->{sock}) : undef;
my $lport = $name ? (Socket::sockaddr_in($name))[0] : undef;
$ret .= ": localport=$lport" if $lport;
$ret .= "; reqs=$self->{requests}";
$ret .= "; $self->{state}";
my $hd = $self->{req_headers};
if (defined $hd) {
my $host = $hd->header('Host') || 'unknown';
$ret .= "; http://$host" . $hd->request_uri;
}
return $ret;
}
sub _durl {
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

139
wcmtools/perlbal/lib/Perlbal/ClientManage.pm Executable file
View File

@@ -0,0 +1,139 @@
######################################################################
# Management connection from a client
######################################################################
package Perlbal::ClientManage;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('service',
'buf',
'is_http', # bool: is an HTTP request?
'verbose', # bool: on/off if we should be verbose for management commands
);
# ClientManage
sub new {
my ($class, $service, $sock) = @_;
my $self = $class->SUPER::new($sock);
$self->{service} = $service;
$self->{buf} = ""; # what we've read so far, not forming a complete line
$self->{verbose} = 1;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# ClientManage
sub event_read {
my Perlbal::ClientManage $self = shift;
my $bref;
unless ($self->{is_http}) {
$bref = $self->read(1024);
return $self->close() unless defined $bref;
$self->{buf} .= $$bref;
if ($self->{buf} =~ /^(?:HEAD|GET|POST) /) {
$self->{is_http} = 1;
$self->{headers_string} .= $$bref;
}
}
if ($self->{is_http}) {
my $hd = $self->read_request_headers;
return unless $hd;
$self->handle_http();
return;
}
while ($self->{buf} =~ s/^(.+?)\r?\n//) {
my $line = $1;
# enable user to turn verbose on and off for our connection
if ($line =~ /^verbose (on|off)$/i) {
$self->{verbose} = (lc $1 eq 'on' ? 1 : 0);
$self->write("OK\r\n") if $self->{verbose};
next;
}
if ($line =~ /^quit/) {
$self->close('user_requested_quit');
return;
}
Perlbal::run_manage_command($line, sub {
$self->write(join("\r\n", map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_) . "\r\n");
}, $self->{verbose});
}
}
# ClientManage
sub event_err { my $self = shift; $self->close; }
sub event_hup { my $self = shift; $self->close; }
# HTTP management support
sub handle_http {
my Perlbal::ClientManage $self = shift;
my $uri = $self->{req_headers}->request_uri;
my $body;
my $code = "200 OK";
my $prebox = sub {
my $cmd = shift;
my $alt = shift;
$body .= "<pre><div style='margin-bottom: 5px; background: #ddd'><b>$cmd</b></div>";
Perlbal::run_manage_command($cmd, sub {
my $line = $_[0] || "";
$alt->(\$line) if $alt;
$body .= "$line\n";
});
$body .= "</pre>\n";
};
if ($uri eq "/") {
$body .= "<h1>perlbal management interface</h1><ul>";
$body .= "<li><a href='/socks'>Sockets</a></li>";
$body .= "<li><a href='/obj'>Perl Objects in use</a></li>";
$body .= "<li>Service Details<ul>";
foreach my $sname (Perlbal->service_names) {
my Perlbal::Service $svc = Perlbal->service($sname);
next unless $svc;
$body .= "<li><a href='/service?$sname'>$sname</a> - $svc->{role} ($svc->{listen})</li>\n";
}
$body .= "</ul></li>";
$body .= "</ul>";
} elsif ($uri eq "/socks") {
$prebox->('socks summary');
$prebox->('socks', sub {
${$_[0]} =~ s!service \'(\w+)\'!<a href=\"/service?$1\">$1</a>!;
});
} elsif ($uri eq "/obj") {
$prebox->('obj');
} elsif ($uri =~ m!^/service\?(\w+)$!) {
my $service = $1;
$prebox->("show service $service");
} else {
$code = "404 Not found";
$body .= "<h1>$code</h1>";
}
$body .= "<hr style='margin-top: 10px' /><a href='/'>Perlbal management</a>.\n";
$self->write("HTTP/1.0 $code\r\nContent-type: text/html\r\nContent-Length: " . length($body) .
"\r\n\r\n$body");
$self->write(sub { $self->close; });
return;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

507
wcmtools/perlbal/lib/Perlbal/ClientProxy.pm Executable file
View File

@@ -0,0 +1,507 @@
######################################################################
# HTTP Connection from a reverse proxy client
######################################################################
package Perlbal::ClientProxy;
use strict;
use warnings;
use base "Perlbal::ClientHTTPBase";
use fields (
'backend', # Perlbal::BackendHTTP object (or undef if disconnected)
'backend_requested', # true if we've requested a backend for this request
'reconnect_count', # number of times we've tried to reconnect to backend
'high_priority', # boolean; 1 if we are or were in the high priority queue
'reproxy_uris', # arrayref; URIs to reproxy to, in order
'reproxy_expected_size', # int: size of response we expect to get back for reproxy
'currently_reproxying', # arrayref; the host info and URI we're reproxying right now
'content_length_remain', # int: amount of data we're still waiting for
'responded', # bool: whether we've already sent a response to the user or not
'last_request_time', # int: time that we last received a request
'primary_res_hdrs', # if defined, we are doing a transparent reproxy-URI
# and the headers we get back aren't necessarily
# the ones we want. instead, get most headers
# from the provided res headers object here.
);
use constant READ_SIZE => 4096; # 4k, arbitrary
use constant READ_AHEAD_SIZE => 8192; # 8k, arbitrary
use Errno qw( EPIPE );
use POSIX ();
# ClientProxy
sub new {
my ($class, $service, $sock) = @_;
my $self = $class;
$self = fields::new($class) unless ref $self;
$self->SUPER::new($service, $sock); # init base fields
Perlbal::objctor($self);
$self->{last_request_time} = 0;
$self->{read_buf} = []; # scalar refs of bufs read from client
$self->{read_ahead} = 0; # bytes sitting in read_buf
$self->{read_size} = 0; # total bytes read from client
$self->{backend} = undef;
$self->{high_priority} = 0;
$self->{responded} = 0;
$self->{content_length_remain} = undef;
$self->{backend_requested} = 0;
$self->{reproxy_uris} = undef;
$self->{reproxy_expected_size} = undef;
$self->{currently_reproxying} = undef;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# call this with a string of space separated URIs to start a process
# that will fetch the item at the first and return it to the user,
# on failure it will try the second, then third, etc
sub start_reproxy_uri {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::HTTPHeaders $primary_res_hdrs = $_[1];
my $urls = $_[2];
# at this point we need to disconnect from our backend
$self->{backend} = undef;
# failure if we have no primary response headers
return unless $self->{primary_res_hdrs} ||= $primary_res_hdrs;
# construct reproxy_uri list
if (defined $urls) {
my @uris = split /\s+/, $urls;
$self->{currently_reproxying} = undef;
$self->{reproxy_uris} = [];
foreach my $uri (@uris) {
next unless $uri =~ m!^http://(.+?)(?::(\d+))?(/.*)?$!;
push @{$self->{reproxy_uris}}, [ $1, $2 || 80, $3 || '/' ];
}
}
# if we get in here and we have currently_reproxying defined, then something
# happened and we want to retry that one
if ($self->{currently_reproxying}) {
unshift @{$self->{reproxy_uris}}, $self->{currently_reproxying};
$self->{currently_reproxying} = undef;
}
# if we have no uris in our list now, tell the user 404
return $self->_simple_response(503)
unless @{$self->{reproxy_uris} || []};
# set the expected size if we got a content length in our headers
if ($primary_res_hdrs && (my $expected_size = $primary_res_hdrs->header('X-REPROXY-EXPECTED-SIZE'))) {
$self->{reproxy_expected_size} = $expected_size;
}
# pass ourselves off to the reproxy manager
$self->state('wait_backend');
Perlbal::ReproxyManager::do_reproxy($self);
}
# called by the reproxy manager when we can't get to our requested backend
sub try_next_uri {
my Perlbal::ClientProxy $self = $_[0];
shift @{$self->{reproxy_uris}};
$self->{currently_reproxying} = undef;
$self->start_reproxy_uri();
}
# this is a callback for when a backend has been created and is
# ready for us to do something with it
sub use_reproxy_backend {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# get a URI
my $datref = $self->{currently_reproxying} = shift @{$self->{reproxy_uris}};
unless (defined $datref) {
# return error and close the backend
$be->close('invalid_uris');
return $self->_simple_response(503);
}
# now send request
$self->{backend} = $be;
$be->{client} = $self;
my $headers = "GET $datref->[2] HTTP/1.0\r\nConnection: keep-alive\r\n\r\n";
$be->{req_headers} = Perlbal::HTTPHeaders->new(\$headers);
$be->state('sending_req');
$self->state('backend_req_sent');
$be->write($be->{req_headers}->to_string_ref);
$be->watch_read(1);
$be->watch_write(1);
}
# this is called when a transient backend getting a reproxied URI has received
# a response from the server and is ready for us to deal with it
sub backend_response_received {
my Perlbal::ClientProxy $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# a response means that we are no longer currently waiting on a reproxy, and
# don't want to retry this URI
$self->{currently_reproxying} = undef;
# we fail if we got something that's NOT a 2xx code, OR, if we expected
# a certain size and got back something different
my $code = $be->{res_headers}->response_code + 0;
if ($code < 200 || $code > 299 ||
(defined $self->{reproxy_expected_size} &&
$self->{reproxy_expected_size} != $be->{res_headers}->header('Content-length'))) {
# fall back to an alternate URL
$be->{client} = undef;
$be->close('non_200_reproxy');
$self->try_next_uri;
return 1;
}
return 0;
}
sub start_reproxy_file {
my Perlbal::ClientProxy $self = shift;
my $file = shift; # filename to reproxy
my Perlbal::HTTPHeaders $hd = shift; # headers from backend, in need of cleanup
# at this point we need to disconnect from our backend
$self->{backend} = undef;
# call hook for pre-reproxy
return if $self->{service}->run_hook("start_file_reproxy", $self, \$file);
# set our expected size
if (my $expected_size = $hd->header('X-REPROXY-EXPECTED-SIZE')) {
$self->{reproxy_expected_size} = $expected_size;
}
# start an async stat on the file
$self->state('wait_stat');
Perlbal::AIO::aio_stat($file, sub {
# if the client's since disconnected by the time we get the stat,
# just bail.
return if $self->{closed};
my $size = -s _;
unless ($size) {
# FIXME: POLICY: 404 or retry request to backend w/o reproxy-file capability?
return $self->_simple_response(404);
}
if (defined $self->{reproxy_expected_size} && $self->{reproxy_expected_size} != $size) {
# 404; the file size doesn't match what we expected
return $self->_simple_response(404);
}
# if the thing we're reproxying is indeed a file, advertise that
# we support byteranges on it
if (-f _) {
$hd->header("Accept-Ranges", "bytes");
}
my ($status, $range_start, $range_end) = $self->{req_headers}->range($size);
my $not_satisfiable = 0;
if ($status == 416) {
$hd = Perlbal::HTTPHeaders->new_response(416);
$hd->header("Content-Range", $size ? "*/$size" : "*");
$not_satisfiable = 1;
}
# change the status code to 200 if the backend gave us 204 No Content
$hd->code(200) if $hd->response_code == 204;
# fixup the Content-Length header with the correct size (application
# doesn't need to provide a correct value if it doesn't want to stat())
if ($status == 200) {
$hd->header("Content-Length", $size);
} elsif ($status == 206) {
$hd->header("Content-Range", "$range_start-$range_end/$size");
$hd->header("Content-Length", $range_end - $range_start + 1);
$hd->code(206);
}
# don't send this internal header to the client:
$hd->header('X-REPROXY-FILE', undef);
# rewrite some other parts of the header
$self->setup_keepalive($hd);
# just send the header, now that we cleaned it.
$self->write($hd->to_string_ref);
if ($self->{req_headers}->request_method eq 'HEAD' || $not_satisfiable) {
$self->write(sub { $self->http_response_sent; });
return;
}
$self->state('wait_open');
Perlbal::AIO::aio_open($file, 0, 0 , sub {
my $fh = shift;
# if client's gone, just close filehandle and abort
if ($self->{closed}) {
CORE::close($fh) if $fh;
return;
}
# handle errors
if (! $fh) {
# FIXME: do 500 vs. 404 vs whatever based on $! ?
return $self->_simple_response(500);
}
# seek if partial content
if ($status == 206) {
sysseek($fh, $range_start, &POSIX::SEEK_SET);
$size = $range_end - $range_start + 1;
}
$self->reproxy_fh($fh, $size);
$self->watch_write(1);
});
});
}
# Client
# get/set backend proxy connection
sub backend {
my Perlbal::ClientProxy $self = shift;
return $self->{backend} unless @_;
my $backend = shift;
$self->state('draining_res') unless $backend;
return $self->{backend} = $backend;
}
# our backend enqueues a call to this method in our write buffer, so this is called
# right after we've finished sending all of the results to the user. at this point,
# if we were doing keep-alive, we don't close and setup for the next request.
sub backend_finished {
my Perlbal::ClientProxy $self = shift;
# mark ourselves as having responded (presumeably if we're here,
# the backend has responded already)
$self->{responded} = 1;
# our backend is done with us, so we disconnect ourselves from it
$self->{backend} = undef;
# now, two cases; undefined clr, or defined and zero, or defined and non-zero
if (defined $self->{content_length_remain}) {
# defined, so a POST, close if it's 0 or less
return $self->http_response_sent
if $self->{content_length_remain} <= 0;
} else {
# not defined, so we're ready for another connection?
return $self->http_response_sent;
}
}
# called when we've sent a response to a user fully and we need to reset state
sub http_response_sent {
my Perlbal::ClientProxy $self = $_[0];
# persistence logic is in ClientHTTPBase
return 0 unless $self->SUPER::http_response_sent;
# if we get here we're being persistent, reset our state
$self->{backend_requested} = 0;
$self->{backend} = undef;
$self->{high_priority} = 0;
$self->{reproxy_uris} = undef;
$self->{reproxy_expected_size} = undef;
$self->{currently_reproxying} = undef;
$self->{content_length_remain} = undef;
$self->{primary_res_hdrs} = undef;
$self->{responded} = 0;
return 1;
}
# Client (overrides and calls super)
sub close {
my Perlbal::ClientProxy $self = shift;
my $reason = shift;
# don't close twice
return if $self->{closed};
# signal that we're done
$self->{service}->run_hooks('end_proxy_request', $self);
# kill our backend if we still have one
if (my $backend = $self->{backend}) {
print "Client ($self) closing backend ($backend)\n" if Perlbal::DEBUG >= 1;
$self->backend(undef);
$backend->close($reason ? "proxied_from_client_close:$reason" : "proxied_from_client_close");
} else {
# if no backend, tell our service that we don't care for one anymore
$self->{service}->note_client_close($self);
}
# call ClientHTTPBase's close
$self->SUPER::close($reason);
}
# Client
sub event_write {
my Perlbal::ClientProxy $self = shift;
$self->SUPER::event_write;
# obviously if we're writing the backend has processed our request
# and we are responding/have responded to the user, so mark it so
$self->{responded} = 1;
# trigger our backend to keep reading, if it's still connected
if (my $backend = $self->{backend}) {
# figure out which maximum buffer size to use
my $buf_size = defined $backend->{service} ? $self->{service}->{buffer_size} : $self->{service}->{buffer_size_reproxy_url};
$backend->watch_read(1) if $self->{write_buf_size} < $buf_size;
}
}
# ClientProxy
sub event_read {
my Perlbal::ClientProxy $self = shift;
# mark alive so we don't get killed for being idle
$self->{alive_time} = time;
# used a few times below to trigger the send start
my $request_backend = sub {
return if $self->{backend_requested};
$self->{backend_requested} = 1;
$self->state('wait_backend');
$self->{service}->request_backend_connection($self);
$self->tcp_cork(1); # cork writes to self
};
unless ($self->{req_headers}) {
if (my $hd = $self->read_request_headers) {
print "Got headers! Firing off new backend connection.\n"
if Perlbal::DEBUG >= 2;
return if $self->{service}->run_hook('start_proxy_request', $self);
# if defined we're waiting on some amount of data. also, we have to
# subtract out read_size, which is the amount of data that was
# extra in the packet with the header that's part of the body.
$self->{content_length_remain} = $hd->content_length;
$self->{content_length_remain} -= $self->{read_size}
if defined $self->{content_length_remain};
# note that we've gotten a request
$self->{requests}++;
$self->{last_request_time} = $self->{alive_time};
# request a backend, or start buffering
if ($self->{service}->{buffer_backend_connect} && $self->{content_length_remain}) {
# buffer logic; note we don't do anything here except set our state and move on
$self->state('buffering_request');
} else {
# dispatch to backend
$request_backend->();
}
}
return;
}
# read data and send to backend (or buffer for later sending)
if ($self->{read_ahead} < ($self->{service}->{buffer_backend_connect} || READ_AHEAD_SIZE)) {
my $bref = $self->read(READ_SIZE);
my $backend = $self->backend;
$self->drain_read_buf_to($backend) if $backend;
if (! defined($bref)) {
$self->watch_read(0);
return;
}
my $len = length($$bref);
$self->{read_size} += $len;
$self->{content_length_remain} -= $len
if defined $self->{content_length_remain};
# just dump the read into the nether if we're dangling. that is
# the case when we send the headers to the backend and it responds
# before we're done reading from the client; therefore further
# reads from the client just need to be sent nowhere, because the
# RFC2616 section 8.2.3 says: "the server SHOULD NOT close the
# transport connection until it has read the entire request"
if ($self->{responded}) {
# in addition, if we're now out of data (clr == 0), then we should
# either close ourselves or get ready for another request
return $self->http_response_sent
if defined $self->{content_length_remain} &&
($self->{content_length_remain} <= 0);
# at this point, if the backend has responded then we just return
# as we don't want to send it on to them or buffer it up, which is
# what the code below does
return;
}
if ($backend) {
$backend->write($bref);
} else {
push @{$self->{read_buf}}, $bref;
$self->{read_ahead} += $len;
# this is when we have read all their data
$request_backend->()
if defined $self->{content_length_remain} &&
$self->{content_length_remain} <= 0;
}
} else {
# our buffer is full, so turn off reads for now
$self->watch_read(0);
# we've exceeded our buffer_backend_connect, start getting a backend for us
$request_backend->();
}
}
sub as_string {
my Perlbal::ClientProxy $self = shift;
my $ret = $self->SUPER::as_string;
if ($self->{backend}) {
my $ipport = $self->{backend}->{ipport};
$ret .= "; backend=$ipport";
} else {
$ret .= "; write_buf_size=$self->{write_buf_size}"
if $self->{write_buf_size} > 0;
}
$ret .= "; highpri" if $self->{high_priority};
$ret .= "; responded" if $self->{responded};
$ret .= "; waiting_for=" . $self->{content_length_remain}
if defined $self->{content_length_remain};
$ret .= "; reproxying" if $self->{currently_reproxying};
return $ret;
}
sub DESTROY {
Perlbal::objdtor($_[0]);
$_[0]->SUPER::DESTROY;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

411
wcmtools/perlbal/lib/Perlbal/HTTPHeaders.pm Executable file
View File

@@ -0,0 +1,411 @@
######################################################################
# HTTP header class (both request and response)
######################################################################
package Perlbal::HTTPHeaders;
use strict;
use warnings;
use fields (
'headers', # href; lowercase header -> comma-sep list of values
'origcase', # href; lowercase header -> provided case
'hdorder', # aref; order headers were received (canonical order)
'method', # scalar; request method (if GET request)
'uri', # scalar; request URI (if GET request)
'type', # 'res' or 'req'
'code', # HTTP response status code
'codetext', # status text that for response code
'ver', # version (string) "1.1"
'vernum', # version (number: major*1000+minor): "1.1" => 1001
'responseLine', # first line of HTTP response (if response)
'requestLine', # first line of HTTP request (if request)
);
our $HTTPCode = {
200 => 'OK',
204 => 'No Content',
206 => 'Partial Content',
304 => 'Not Modified',
400 => 'Bad request',
403 => 'Forbidden',
404 => 'Not Found',
416 => 'Request range not satisfiable',
500 => 'Internal Server Error',
501 => 'Not Implemented',
503 => 'Service Unavailable',
};
sub fail {
return undef unless Perlbal::DEBUG >= 1;
my $reason = shift;
print "HTTP parse failure: $reason\n" if Perlbal::DEBUG >= 1;
return undef;
}
sub http_code_english {
my Perlbal::HTTPHeaders $self = shift;
return $HTTPCode->{$self->{code}};
}
sub new_response {
my Perlbal::HTTPHeaders $self = shift;
$self = fields::new($self) unless ref $self;
my $code = shift;
$self->{headers} = {};
$self->{origcase} = {};
$self->{hdorder} = [];
$self->{method} = undef;
$self->{uri} = undef;
my $msg = $HTTPCode->{$code} || "";
$self->{responseLine} = "HTTP/1.0 $code $msg";
$self->{code} = $code;
$self->{type} = "httpres";
Perlbal::objctor($self, $self->{type});
return $self;
}
sub new {
my Perlbal::HTTPHeaders $self = shift;
$self = fields::new($self) unless ref $self;
my ($hstr_ref, $is_response) = @_;
# hstr: headers as a string ref
# is_response: bool; is HTTP response (as opposed to request). defaults to request.
my $absoluteURIHost = undef;
my @lines = split(/\r?\n/, $$hstr_ref);
$self->{headers} = {};
$self->{origcase} = {};
$self->{hdorder} = [];
$self->{method} = undef;
$self->{uri} = undef;
$self->{type} = ($is_response ? "res" : "req");
Perlbal::objctor($self, $self->{type});
# check request line
if ($is_response) {
$self->{responseLine} = (shift @lines) || "";
# check for valid response line
return fail("Bogus response line") unless
$self->{responseLine} =~ m!^HTTP\/(\d+)\.(\d+)\s+(\d+)\s+(.+)$!;
my ($ver_ma, $ver_mi, $code) = ($1, $2, $3);
$self->code($code, $4);
# version work so we know what version the backend spoke
unless (defined $ver_ma) {
($ver_ma, $ver_mi) = (0, 9);
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
} else {
$self->{requestLine} = (shift @lines) || "";
# check for valid request line
return fail("Bogus request line") unless
$self->{requestLine} =~ m!^(\w+) ((?:\*|(?:\S*?)))(?: HTTP/(\d+)\.(\d+))$!;
$self->{method} = $1;
$self->{uri} = $2;
my ($ver_ma, $ver_mi) = ($3, $4);
# now check uri for not being a uri
if ($self->{uri} =~ m!^http://([^/:]+?)(?::\d+)?(/.*)?$!) {
$absoluteURIHost = lc($1);
$self->{uri} = $2 || "/"; # "http://www.foo.com" yields no path, so default to "/"
}
# default to HTTP/0.9
unless (defined $ver_ma) {
($ver_ma, $ver_mi) = (0, 9);
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
}
my $last_header = undef;
foreach my $line (@lines) {
if ($line =~ /^\s/) {
next unless defined $last_header;
$self->{headers}{$last_header} .= $line;
} elsif ($line =~ /^([^\x00-\x20\x7f()<>@,;:\\\"\/\[\]?={}]+):\s*(.*)$/) {
# RFC 2616:
# sec 4.2:
# message-header = field-name ":" [ field-value ]
# field-name = token
# sec 2.2:
# token = 1*<any CHAR except CTLs or separators>
$last_header = lc($1);
if (defined $self->{headers}{$last_header}) {
if ($last_header eq "set-cookie") {
# cookie spec doesn't allow merged headers for set-cookie,
# so instead we do this hack so to_string below does the right
# thing without needing to be arrayref-aware or such. also
# this lets client code still modify/delete this data
# (but retrieving the value of "set-cookie" will be broken)
$self->{headers}{$last_header} .= "\r\nSet-Cookie: $2";
} else {
# normal merged header case (according to spec)
$self->{headers}{$last_header} .= ", $2";
}
} else {
$self->{headers}{$last_header} = $2;
$self->{origcase}{$last_header} = $1;
push @{$self->{hdorder}}, $last_header;
}
} else {
return fail("unknown header line");
}
}
# override the host header if an absolute URI was provided
$self->header('Host', $absoluteURIHost)
if defined $absoluteURIHost;
# now error if no host
return fail("HTTP 1.1 requires host header")
if !$is_response && $self->{vernum} >= 1001 && !$self->header('Host');
return $self;
}
sub _codetext {
my Perlbal::HTTPHeaders $self = shift;
return $self->{codetext} if $self->{codetext};
return $self->http_code_english;
}
sub code {
my Perlbal::HTTPHeaders $self = shift;
my ($code, $text) = @_;
$self->{code} = $code+0;
$self->{codetext} = $text;
}
sub response_code {
my Perlbal::HTTPHeaders $self = $_[0];
return $self->{code};
}
sub request_method {
my Perlbal::HTTPHeaders $self = shift;
return $self->{method};
}
sub request_uri {
my Perlbal::HTTPHeaders $self = shift;
return $self->{uri};
}
sub version_number {
my Perlbal::HTTPHeaders $self = $_[0];
return $self->{vernum} unless $_[1];
return $self->{vernum} = $_[1];
}
sub header {
my Perlbal::HTTPHeaders $self = shift;
my $key = shift;
return $self->{headers}{lc($key)} unless @_;
# adding a new header
my $origcase = $key;
$key = lc($key);
unless (exists $self->{headers}{$key}) {
push @{$self->{hdorder}}, $key;
$self->{origcase}{$key} = $origcase;
}
return $self->{headers}{$key} = shift;
}
sub to_string_ref {
my Perlbal::HTTPHeaders $self = shift;
my $st = join("\r\n",
$self->{requestLine} || $self->{responseLine},
(map { "$self->{origcase}{$_}: $self->{headers}{$_}" }
grep { defined $self->{headers}{$_} }
@{$self->{hdorder}}),
'', ''); # final \r\n\r\n
return \$st;
}
sub clone {
my Perlbal::HTTPHeaders $self = shift;
my $new = fields::new($self);
foreach (qw(method uri type code codetext ver vernum responseLine requestLine)) {
$new->{$_} = $self->{$_};
}
# mark this object as constructed
Perlbal::objctor($new, $new->{type});
$new->{headers} = { %{$self->{headers}} };
$new->{origcase} = { %{$self->{origcase}} };
$new->{hdorder} = [ @{$self->{hdorder}} ];
return $new;
}
sub set_version {
my Perlbal::HTTPHeaders $self = shift;
my $ver = shift;
die "Bogus version" unless $ver =~ /^(\d+)\.(\d+)$/;
my ($ver_ma, $ver_mi) = ($1, $2);
# check for req, as the other can be res or httpres
if ($self->{type} eq 'req') {
$self->{requestLine} = "$self->{method} $self->{uri} HTTP/$ver";
} else {
$self->{responseLine} = "HTTP/$ver $self->{code} " . $self->_codetext;
}
$self->{ver} = "$ver_ma.$ver_mi";
$self->{vernum} = $ver_ma*1000 + $ver_mi;
return $self;
}
# using all available information, attempt to determine the content length of
# the message body being sent to us.
sub content_length {
my Perlbal::HTTPHeaders $self = shift;
# shortcuts depending on our method/code, depending on what we are
if ($self->{type} eq 'req') {
# no content length for head requests
return 0 if $self->{method} eq 'HEAD';
} elsif ($self->{type} eq 'res' || $self->{type} eq 'httpres') {
# no content length in any of these
if ($self->{code} == 304 || $self->{code} == 204 ||
($self->{code} >= 100 && $self->{code} <= 199)) {
return 0;
}
}
# the normal case for a GET/POST, etc. real data coming back
# also, an OPTIONS requests generally has a defined but 0 content-length
if (defined(my $clen = $self->header("Content-Length"))) {
return $clen;
}
# if we get here, nothing matched, so we don't definitively know what the
# content length is. this is usually an error, but we try to work around it.
return undef;
}
# answers the question: "should a response to this person specify keep-alive,
# given the request (self) and the backend response?" this is used in proxy
# mode to determine based on the client's request and the backend's response
# whether or not the response from the proxy (us) should do keep-alive.
sub req_keep_alive {
my Perlbal::HTTPHeaders $self = $_[0];
my Perlbal::HTTPHeaders $res = $_[1];
# get the connection header now (saves warnings later)
my $conn = lc ($self->header('Connection') || '');
# check the client
if ($self->version_number < 1001) {
# they must specify a keep-alive header
return 0 unless $conn =~ /\bkeep-alive\b/i;
}
# so it must be 1.1 which means keep-alive is on, unless they say not to
return 0 if $conn =~ /\bclose\b/i;
# if we get here, the user wants keep-alive and seems to support it,
# so we make sure that the response is in a form that we can understand
# well enough to do keep-alive. FIXME: support chunked encoding in the
# future, which means this check changes.
return 1 if defined $res->header('Content-length') ||
$self->request_method eq 'HEAD';
# fail-safe, no keep-alive
return 0;
}
# answers the question: is the backend expected to stay open. this is a combination
# of the request we sent to it and the response they sent...
sub res_keep_alive {
my Perlbal::HTTPHeaders $self = $_[0];
my Perlbal::HTTPHeaders $req = $_[1];
# get the connection header now (saves warnings later)
my $conn = lc ($self->header('Connection') || '');
# if they said Connection: close, it's always not keep-alive
return 0 if $conn =~ /\bclose\b/i;
# handle the http 1.0/0.9 case which requires keep-alive specified
if ($self->version_number < 1001) {
# must specify keep-alive, and must have a content length OR
# the request must be a head request
return 1 if
$conn =~ /\bkeep-alive\b/i &&
(defined $self->header('Content-length') ||
$req->request_method eq 'HEAD');
return 0;
}
# HTTP/1.1 case. defaults to keep-alive, per spec, unless
# asked for otherwise (checked above)
# FIXME: make sure we handle a HTTP/1.1 response from backend
# with connection: close, no content-length, going to a
# HTTP/1.1 persistent client. we'll have to add chunk markers.
# (not here, obviously)
return 1;
}
# returns (status, range_start, range_end) when given a size
# status = 200 - invalid or non-existent range header. serve normally.
# status = 206 - parsable range is good. serve partial content.
# status = 416 - Range is unsatisfiable
sub range {
my Perlbal::HTTPHeaders $self = $_[0];
my $size = $_[1];
my $not_satisfiable;
my $range = $self->header("Range");
return 200 unless $range && defined $size;
my ($range_start, $range_end) = $range =~ /^bytes=(\d*)-(\d*)$/;
undef $range_start if $range_start eq '';
undef $range_end if $range_end eq '';
return 200 unless defined($range_start) or defined($range_end);
if (defined($range_start) and defined($range_end) and $range_start > $range_end) {
return 416;
} elsif (not defined($range_start) and defined($range_end) and $range_end == 0) {
return 416;
} elsif (defined($range_start) and $size <= $range_start) {
return 416;
}
$range_start = 0 unless defined($range_start);
$range_end = $size - 1 unless defined($range_end) and $range_end < $size;
return (206, $range_start, $range_end);
}
sub DESTROY {
my Perlbal::HTTPHeaders $self = shift;
Perlbal::objdtor($self, $self->{type});
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

124
wcmtools/perlbal/lib/Perlbal/Plugin/Highpri.pm Executable file
View File

@@ -0,0 +1,124 @@
###########################################################################
# plugin that makes some requests high priority. this is very LiveJournal
# specific, as this makes requests to the client protocol be treated as
# high priority requests.
###########################################################################
package Perlbal::Plugin::Highpri;
use strict;
use warnings;
# keep track of services we're loaded for
our %Services;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# create a compiled regexp for very frequent use later
my $uri_check = qr{^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$};
my $host_check = undef;
# setup default extra config info
$svc->{extra_config}->{highpri_uri_check_str} = '^(?:/interface/(?:xmlrpc|flat)|/login\.bml)$';
$svc->{extra_config}->{highpri_host_check_str} = 'undef';
# config setter reference
my $config_set = sub {
my ($out, $what, $val) = @_;
return 0 unless $what && $val;
# setup an error sub
my $err = sub {
$out->("ERROR: $_[0]") if $out;
return 0;
};
# if they said undef, that's not a regexp, that means use none
my $temp;
unless ($val eq 'undef' || $val eq 'none' || $val eq 'null') {
# verify this regex works? do it in an eval because qr will die
# if we give it something invalid
eval {
$temp = qr{$val};
};
return $err->("Invalid regular expression") if $@ || !$temp;
}
# see what they want to set and set it
if ($what =~ /^uri_pattern/i) {
$uri_check = $temp;
$svc->{extra_config}->{highpri_uri_check_str} = $val;
} elsif ($what =~ /^host_pattern/i) {
$host_check = $temp;
$svc->{extra_config}->{highpri_host_check_str} = $val;
} else {
return $err->("Plugin understands: uri_pattern, host_pattern");
}
# 1 for success!
return 1;
};
# register things to take in configuration regular expressions
$svc->register_setter('Highpri', 'uri_pattern', $config_set);
$svc->register_setter('Highpri', 'host_pattern', $config_set);
# more complicated statistics
$svc->register_hook('Highpri', 'make_high_priority', sub {
my Perlbal::ClientProxy $cp = shift;
# check it against our compiled regexp
return 1 if $uri_check &&
$cp->{req_headers}->request_uri =~ /$uri_check/;
if ($host_check) {
my $hostname = $cp->{req_headers}->header('Host');
return 1 if $hostname && $hostname =~ /$host_check/;
}
# doesn't fit, so return 0
return 0;
});
# mark this service as being active in this plugin
$Services{"$svc"} = $svc;
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Highpri');
$svc->unregister_setters('Highpri');
return 1;
}
# load global commands for querying this plugin on what's up
sub load {
# setup a command to see what the patterns are
Perlbal::register_global_hook('manage_command.patterns', sub {
my @res = ("High priority pattern buffer:");
foreach my $svc (values %Services) {
push @res, "SET $svc->{name}.highpri.uri_pattern = $svc->{extra_config}->{highpri_uri_check_str}";
push @res, "SET $svc->{name}.highpri.host_pattern = $svc->{extra_config}->{highpri_host_check_str}";
}
return \@res;
});
return 1;
}
# unload our global commands, clear our service object
sub unload {
Perlbal::unregister_global_hook('manage_command.patterns');
%Services = ();
return 1;
}
1;

293
wcmtools/perlbal/lib/Perlbal/Plugin/Palimg.pm Executable file
View File

@@ -0,0 +1,293 @@
###########################################################################
# Palimg plugin that allows Perlbal to serve palette altered images
###########################################################################
package Perlbal::Plugin::Palimg;
use strict;
use warnings;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# verify that an incoming request is a palimg request
$svc->register_hook('Palimg', 'start_serve_request', sub {
my Perlbal::ClientHTTPBase $obj = $_[0];
return 0 unless $obj;
my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
my $uriref = $_[1];
return 0 unless $uriref;
# if this is palimg, peel off the requested modifications and put in headers
return 0 unless $$uriref =~ m!^/palimg/(.+)\.(\w+)(.*)$!;
my ($fn, $ext, $extra) = ($1, $2, $3);
return 0 unless $extra;
my ($palspec) = $extra =~ m!^/p(.+)$!;
return 0 unless $fn && $palspec;
# must be ok, setup for it
$$uriref = "/palimg/$fn.$ext";
$obj->{scratch}->{palimg} = [ $ext, $palspec ];
return 0;
});
# actually serve a palimg
$svc->register_hook('Palimg', 'start_send_file', sub {
my Perlbal::ClientHTTPBase $obj = $_[0];
return 0 unless $obj &&
(my $palimginfo = $obj->{scratch}->{palimg});
# turn off writes
$obj->watch_write(0);
# create filehandle for reading
my $data = '';
Perlbal::AIO::aio_read($obj->reproxy_fh, 0, 2048, $data, sub {
# got data? undef is error
return $obj->_simple_response(500) unless $_[0] > 0;
# pass down to handler
my Perlbal::HTTPHeaders $hd = $obj->{req_headers};
my $res = PalImg::modify_file(\$data, $palimginfo->[0], $palimginfo->[1]);
return $obj->_simple_response(500) unless defined $res;
return $obj->_simple_response($res) if $res;
# seek into the file now so sendfile starts further in
my $ld = length $data;
sysseek($obj->{reproxy_fh}, $ld, &POSIX::SEEK_SET);
$obj->{reproxy_file_offset} = $ld;
# reenable writes after we get data
$obj->tcp_cork(1); # by setting reproxy_file_offset above, it won't cork, so we cork it
$obj->write($data);
$obj->watch_write(1);
});
return 1;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Palimg');
return 1;
}
# called when we are loaded/unloaded ... someday add some stats viewing
# commands here?
sub load { return 1; }
sub unload { return 1; }
####### PALIMG START ###########################################################################
package PalImg;
sub parse_hex_color
{
my $color = shift;
return [ map { hex(substr($color, $_, 2)) } (0,2,4) ];
}
sub modify_file
{
my ($data, $type, $palspec) = @_;
# palette altering
my %pal_colors;
if (my $pals = $palspec) {
my $hx = "[0-9a-f]";
if ($pals =~ /^g($hx{2,2})($hx{6,6})($hx{2,2})($hx{6,6})$/) {
# gradient from index $1, color $2, to index $3, color $4
my $from = hex($1);
my $to = hex($3);
return 404 if $from == $to;
my $fcolor = parse_hex_color($2);
my $tcolor = parse_hex_color($4);
if ($to < $from) {
($from, $to, $fcolor, $tcolor) =
($to, $from, $tcolor, $fcolor);
}
for (my $i=$from; $i<=$to; $i++) {
$pal_colors{$i} = [ map {
int($fcolor->[$_] +
($tcolor->[$_] - $fcolor->[$_]) *
($i-$from) / ($to-$from))
} (0..2) ];
}
} elsif ($pals =~ /^t($hx{6,6})($hx{6,6})?$/) {
# tint everything towards color
my ($t, $td) = ($1, $2);
$pal_colors{'tint'} = parse_hex_color($t);
$pal_colors{'tint_dark'} = $td ? parse_hex_color($td) : [0,0,0];
} elsif (length($pals) > 42 || $pals =~ /[^0-9a-f]/) {
return 404;
} else {
my $len = length($pals);
return 404 if $len % 7; # must be multiple of 7 chars
for (my $i = 0; $i < $len/7; $i++) {
my $palindex = hex(substr($pals, $i*7, 1));
$pal_colors{$palindex} = [
hex(substr($pals, $i*7+1, 2)),
hex(substr($pals, $i*7+3, 2)),
hex(substr($pals, $i*7+5, 2)),
substr($pals, $i*7+1, 6),
];
}
}
}
if (%pal_colors) {
if ($type eq 'gif') {
return 404 unless PaletteModify::new_gif_palette($data, \%pal_colors);
} elsif ($type eq 'png') {
return 404 unless PaletteModify::new_png_palette($data, \%pal_colors);
}
}
# success
return 0;
}
####### PALIMG END #############################################################################
####### PALETTEMODIFY START ####################################################################
package PaletteModify;
BEGIN {
$PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;";
}
sub common_alter
{
my ($palref, $table) = @_;
my $length = length $table;
my $pal_size = $length / 3;
# tinting image? if so, we're remaking the whole palette
if (my $tint = $palref->{'tint'}) {
my $dark = $palref->{'tint_dark'};
my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ];
$palref = {};
for (my $idx=0; $idx<$pal_size; $idx++) {
for my $c (0..2) {
my $curr = ord(substr($table, $idx*3+$c));
my $p = \$palref->{$idx}->[$c];
$$p = int($dark->[$c] + $diff->[$c] * $curr / 255);
}
}
}
while (my ($idx, $c) = each %$palref) {
next if $idx >= $pal_size;
substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2);
}
return $table;
}
sub new_gif_palette
{
my ($data, $palref) = @_;
# make sure we have data to operate on, or the substrs below die
return unless $$data;
# 13 bytes for magic + image info (size, color depth, etc)
# and then the global palette table (3*256)
my $header = substr($$data, 0, 13+3*256);
# figure out how big global color table is (don't want to overwrite it)
my $pf = ord substr($header, 10, 1);
my $gct = 2 ** (($pf & 7) + 1); # last 3 bits of packaged fields
# final sanity check for size so the substr below doesn't die
return unless length $header >= 13 + 3 * $gct;
substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct));
$$data = $header;
return 1;
}
sub new_png_palette
{
my ($data, $palref) = @_;
# subroutine for reading data
my ($curidx, $maxlen) = (0, length $$data);
my $read = sub {
# put $_[1] data into scalar reference $_[0]
return undef if $_[1] + $curidx > $maxlen;
${$_[0]} = substr($$data, $curidx, $_[1]);
$curidx += $_[1];
return length ${$_[0]};
};
# without this module, we can't proceed.
return 0 unless $PaletteModify::HAVE_CRC;
my $imgdata;
# Validate PNG signature
my $png_sig = pack("H16", "89504E470D0A1A0A");
my $sig;
$read->(\$sig, 8);
return 0 unless $sig eq $png_sig;
$imgdata .= $sig;
# Start reading in chunks
my ($length, $type) = (0, '');
while ($read->(\$length, 4)) {
$imgdata .= $length;
$length = unpack("N", $length);
return 0 unless $read->(\$type, 4) == 4;
$imgdata .= $type;
if ($type eq 'IHDR') {
my $header;
$read->(\$header, $length+4);
my ($width,$height,$depth,$color,$compression,
$filter,$interlace, $CRC)
= unpack("NNCCCCCN", $header);
return 0 unless $color == 3; # unpaletted image
$imgdata .= $header;
} elsif ($type eq 'PLTE') {
# Finally, we can go to work
my $palettedata;
$read->(\$palettedata, $length);
$palettedata = common_alter($palref, $palettedata);
$imgdata .= $palettedata;
# Skip old CRC
my $skip;
$read->(\$skip, 4);
# Generate new CRC
my $crc = String::CRC32::crc32($type . $palettedata);
$crc = pack("N", $crc);
$imgdata .= $crc;
$$data = $imgdata;
return 1;
} else {
my $skip;
# Skip rest of chunk and add to imgdata
# Number of bytes is +4 becauses of CRC
#
for (my $count=0; $count < $length + 4; $count++) {
$read->(\$skip, 1);
$imgdata .= $skip;
}
}
}
return 0;
}
####### PALETTEMODIFY END ######################################################################
1;

54
wcmtools/perlbal/lib/Perlbal/Plugin/Queues.pm Executable file
View File

@@ -0,0 +1,54 @@
###########################################################################
# simple queue length header inclusion plugin
###########################################################################
package Perlbal::Plugin::Queues;
use strict;
use warnings;
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# more complicated statistics
$svc->register_hook('Queues', 'backend_client_assigned', sub {
my Perlbal::BackendHTTP $obj = shift;
my Perlbal::HTTPHeaders $hds = $obj->{req_headers};
my Perlbal::Service $svc = $obj->{service};
return 0 unless defined $hds && defined $svc;
# determine age of oldest (first in line)
my $now = time;
my Perlbal::ClientProxy $cp = $svc->{waiting_clients}->[0];
my $age = defined $cp ? ($now - $cp->{last_request_time}) : 0;
# now do the age of the high priority queue
$cp = $svc->{waiting_clients_highpri}->[0];
my $hpage = defined $cp ? ($now - $cp->{last_request_time}) : 0;
# setup the queue length headers
$hds->header('X-Queue-Count', scalar(@{$svc->{waiting_clients}}));
$hds->header('X-Queue-Age', $age);
$hds->header('X-HP-Queue-Count', scalar(@{$svc->{waiting_clients_highpri}}));
$hds->header('X-HP-Queue-Age', $hpage);
return 0;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Queues');
return 1;
}
# we don't do anything in here
sub load { return 1; }
sub unload { return 1; }
1;

161
wcmtools/perlbal/lib/Perlbal/Plugin/Stats.pm Executable file
View File

@@ -0,0 +1,161 @@
###########################################################################
# basic Perlbal statistics gatherer
###########################################################################
package Perlbal::Plugin::Stats;
use strict;
use warnings;
use Time::HiRes qw(gettimeofday tv_interval);
# setup our package variables
our %statobjs; # { svc_name => [ service, statobj ], svc_name => [ service, statobj ], ... }
# define all stats keys here
our @statkeys = qw( files_sent files_reproxied
web_requests proxy_requests
proxy_requests_highpri );
# called when we're being added to a service
sub register {
my ($class, $svc) = @_;
# create a stats object
my $sobj = Perlbal::Plugin::Stats::Storage->new();
$statobjs{$svc->{name}} = [ $svc, $sobj ];
# simple events we count are done here. when the hook on the left side is called,
# we simply increment the count of the stat ont he right side.
my %simple = qw(
start_send_file files_sent
start_file_reproxy files_reproxied
start_web_request web_requests
);
# create hooks for %simple things
while (my ($hook, $stat) = each %simple) {
eval "\$svc->register_hook('Stats', '$hook', sub { \$sobj->{'$stat'}++; return 0; });";
return undef if $@;
}
# more complicated statistics
$svc->register_hook('Stats', 'backend_client_assigned', sub {
my Perlbal::BackendHTTP $be = shift;
$sobj->{pending}->{"$be->{client}"} = [ gettimeofday() ];
($be->{client}->{high_priority} ? $sobj->{proxy_requests_highpri} : $sobj->{proxy_requests})++;
return 0;
});
$svc->register_hook('Stats', 'backend_response_received', sub {
my Perlbal::BackendHTTP $be = shift;
my Perlbal::ClientProxy $obj = $be->{client};
my $ot = $sobj->{pending}->{"$obj"};
return 0 unless defined $ot;
# now construct data to put in recent
if (defined $obj->{req_headers}) {
my $uri = 'http://' . ($obj->{req_headers}->header('Host') || 'unknown') . $obj->{req_headers}->request_uri;
push @{$sobj->{recent}}, sprintf('%-6.4f %s', tv_interval($ot), $uri);
shift(@{$sobj->{recent}}) if scalar(@{$sobj->{recent}}) > 100; # if > 100 items, lose one
}
return 0;
});
return 1;
}
# called when we're no longer active on a service
sub unregister {
my ($class, $svc) = @_;
# clean up time
$svc->unregister_hooks('Stats');
delete $statobjs{$svc->{name}};
return 1;
}
# called when we are loaded
sub load {
# setup a management command to dump statistics
Perlbal::register_global_hook("manage_command.stats", sub {
my @res;
# create temporary object for stats storage
my $gsobj = Perlbal::Plugin::Stats::Storage->new();
# dump per service
foreach my $svc (keys %statobjs) {
my $sobj = $statobjs{$svc}->[1];
# for now, simply dump the numbers we have
foreach my $key (sort @statkeys) {
push @res, sprintf("%-15s %-25s %12d", $svc, $key, $sobj->{$key});
$gsobj->{$key} += $sobj->{$key};
}
}
# global stats
foreach my $key (sort @statkeys) {
push @res, sprintf("%-15s %-25s %12d", 'total', $key, $gsobj->{$key});
}
return \@res;
});
# recent requests and how long they took
Perlbal::register_global_hook("manage_command.recent", sub {
my @res;
foreach my $svc (keys %statobjs) {
my $sobj = $statobjs{$svc}->[1];
push @res, "$svc $_"
foreach @{$sobj->{recent}};
}
return \@res;
});
return 1;
}
# called for a global unload
sub unload {
# unregister our global hooks
Perlbal::unregister_global_hook('manage_command.stats');
Perlbal::unregister_global_hook('manage_command.recent');
# take out all service stuff
foreach my $statref (values %statobjs) {
$statref->[0]->unregister_hooks('Stats');
}
%statobjs = ();
return 1;
}
# statistics storage object
package Perlbal::Plugin::Stats::Storage;
use fields (
'files_sent', # files sent from disk (includes reproxies and regular web requests)
'files_reproxied', # files we've sent via reproxying (told to by backend)
'web_requests', # requests we sent ourselves (no reproxy, no backend)
'proxy_requests', # regular requests that went to a backend to be served
'proxy_requests_highpri', # same as above, except high priority
'pending', # hashref; { "obj" => time_start }
'recent', # arrayref; strings of recent URIs and times
);
sub new {
my Perlbal::Plugin::Stats::Storage $self = shift;
$self = fields::new($self) unless ref $self;
# 0 initialize everything here
$self->{$_} = 0 foreach @Perlbal::Plugin::Stats::statkeys;
# other setup
$self->{pending} = {};
$self->{recent} = [];
return $self;
}
1;

328
wcmtools/perlbal/lib/Perlbal/Pool.pm Executable file
View File

@@ -0,0 +1,328 @@
######################################################################
# Pool class
######################################################################
package Perlbal::Pool;
use strict;
use warnings;
use Perlbal::BackendHTTP;
# how often to reload the nodefile
use constant NODEFILE_RELOAD_FREQ => 3;
# balance methods we support
use constant BM_SENDSTATS => 1;
use constant BM_ROUNDROBIN => 2;
use constant BM_RANDOM => 3;
use fields (
'name', # string; name of this pool
'use_count', # int; number of services using us
'nodes', # arrayref; [ip, port] values (port defaults to 80)
'node_count', # int; number of nodes
'node_used', # hashref; { ip:port => use count }
'balance_method', # int; BM_ constant from above
# used in sendstats mode
'sendstats.listen', # what IP/port the stats listener runs on
'sendstats.listen.socket', # Perlbal::StatsListener object
# used in nodefile mode
'nodefile', # string; filename to read nodes from
'nodefile.lastmod', # unix time nodefile was last modified
'nodefile.lastcheck', # unix time nodefile was last stated
'nodefile.checking', # boolean; if true AIO is stating the file for us
);
sub new {
my Perlbal::Pool $self = shift;
$self = fields::new($self) unless ref $self;
my ($name) = @_;
$self->{name} = $name;
$self->{use_count} = 0;
$self->{nodes} = [];
$self->{node_count} = 0;
$self->{node_used} = {};
$self->{nodefile} = undef;
$self->{balance_method} = BM_RANDOM;
return $self;
}
sub set {
my Perlbal::Pool $self = shift;
my ($key, $val, $out, $verbose) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
my $ok = sub { $out->("OK") if $verbose; return 1; };
my $set = sub { $self->{$key} = $val; return $ok->(); };
if ($key eq 'nodefile') {
# allow to unset it, which stops us from checking it further,
# but doesn't clear our current list of nodes
if ($val =~ /^(?:none|undef|null|""|'')$/) {
$self->{'nodefile'} = undef;
$self->{'nodefile.lastmod'} = 0;
$self->{'nodefile.checking'} = 0;
$self->{'nodefile.lastcheck'} = 0;
return $ok->();
}
# enforce that it exists from here on out
return $err->("File not found")
unless -e $val;
# force a reload
$self->{'nodefile'} = $val;
$self->{'nodefile.lastmod'} = 0;
$self->{'nodefile.checking'} = 0;
$self->load_nodefile;
$self->{'nodefile.lastcheck'} = time;
return $ok->();
}
if ($key eq "balance_method") {
$val = {
'sendstats' => BM_SENDSTATS,
'random' => BM_RANDOM,
}->{$val};
return $err->("Unknown balance method")
unless $val;
return $set->();
}
if ($key =~ /^sendstats\./) {
return $err->("Can only set sendstats listening address on service with balancing method 'sendstats'")
unless $self->{balance_method} == BM_SENDSTATS;
if ($key eq "sendstats.listen") {
return $err->("Invalid host:port")
unless $val =~ m!^\d+\.\d+\.\d+\.\d+:\d+$!;
if (my $pbs = $self->{"sendstats.listen.socket"}) {
$pbs->close;
}
unless ($self->{"sendstats.listen.socket"} =
Perlbal::StatsListener->new($val, $self)) {
return $err->("Error creating stats listener: $Perlbal::last_error");
}
$self->populate_sendstats_hosts;
}
return $set->();
}
}
sub populate_sendstats_hosts {
my Perlbal::Pool $self = shift;
# tell the sendstats listener about the new list of valid
# IPs to listen from
if ($self->{balance_method} == BM_SENDSTATS) {
my $ss = $self->{'sendstats.listen.socket'};
$ss->set_hosts(map { $_->[0] } @{$self->{nodes}}) if $ss;
}
}
# returns string of balance method
sub balance_method {
my Perlbal::Pool $self = $_[0];
my $methods = {
&BM_SENDSTATS => "sendstats",
&BM_ROUNDROBIN => "round_robin",
&BM_RANDOM => "random",
};
return $methods->{$self->{balance_method}} || $self->{balance_method};
}
sub load_nodefile {
my Perlbal::Pool $self = shift;
return 0 unless $self->{'nodefile'};
if ($Perlbal::OPTMOD_LINUX_AIO) {
return $self->_load_nodefile_async;
} else {
return $self->_load_nodefile_sync;
}
}
sub _parse_nodefile {
my Perlbal::Pool $self = shift;
my $dataref = shift;
my @nodes = split(/\r?\n/, $$dataref);
# prepare for adding nodes
$self->{nodes} = [];
$self->{node_used} = {};
foreach (@nodes) {
s/\#.*//;
if (/(\d+\.\d+\.\d+\.\d+)(?::(\d+))?/) {
my ($ip, $port) = ($1, $2);
$self->{node_used}->{"$ip:$port"} ||= 0; # set to 0 if not set
push @{$self->{nodes}}, [ $ip, $port || 80 ];
}
}
# setup things using new data
$self->{node_count} = scalar @{$self->{nodes}};
$self->populate_sendstats_hosts;
}
sub _load_nodefile_sync {
my Perlbal::Pool $self = shift;
my $mod = (stat($self->{nodefile}))[9];
return if $mod == $self->{'nodefile.lastmod'};
$self->{'nodefile.lastmod'} = $mod;
open NODEFILE, $self->{nodefile} or return;
my $nodes;
{ local $/ = undef; $nodes = <NODEFILE>; }
close NODEFILE;
$self->_parse_nodefile(\$nodes);
}
sub _load_nodefile_async {
my Perlbal::Pool $self = shift;
return if $self->{'nodefile.checking'};
$self->{'nodefile.checking'} = 1;
Perlbal::AIO::aio_stat($self->{nodefile}, sub {
$self->{'nodefile.checking'} = 0;
# this might have gotten unset while we were out statting the file, which
# means that the user has instructed us not to use a node file, and may
# have changed the nodes in the pool, so we should do nothing and return
return unless $self->{'nodefile'};
# ignore if the file doesn't exist
return unless -e _;
my $mod = (stat(_))[9];
return if $mod == $self->{'nodefile.lastmod'};
$self->{'nodefile.lastmod'} = $mod;
# construct a filehandle (we only have a descriptor here)
open NODEFILE, $self->{nodefile}
or return;
my $nodes;
{ local $/ = undef; $nodes = <NODEFILE>; }
close NODEFILE;
$self->_parse_nodefile(\$nodes);
return;
});
return 1;
}
sub add {
my Perlbal::Pool $self = shift;
my ($ip, $port) = @_;
$self->remove($ip, $port); # no dupes
$self->{node_used}->{"$ip:$port"} = 0;
push @{$self->{nodes}}, [ $ip, $port ];
$self->{node_count} = scalar(@{$self->{nodes}});
}
sub remove {
my Perlbal::Pool $self = shift;
my ($ip, $port) = @_;
delete $self->{node_used}->{"$ip:$port"};
@{$self->{nodes}} = grep { "$_->[0]:$_->[1]" ne "$ip:$port" } @{$self->{nodes}};
$self->{node_count} = scalar(@{$self->{nodes}});
}
sub get_backend_endpoint {
my Perlbal::Pool $self = $_[0];
my @endpoint; # (IP,port)
# re-load nodefile if necessary
if ($self->{nodefile}) {
my $now = time;
if ($now > $self->{'nodefile.lastcheck'} + NODEFILE_RELOAD_FREQ) {
$self->{'nodefile.lastcheck'} = $now;
$self->load_nodefile;
}
}
if ($self->{balance_method} == BM_SENDSTATS) {
my $ss = $self->{'sendstats.listen.socket'};
if ($ss && (@endpoint = $ss->get_endpoint)) {
return @endpoint;
}
}
# no nodes?
return () unless $self->{node_count};
# pick one randomly
return @{$self->{nodes}[int(rand($self->{node_count}))]};
}
sub backend_should_live {
my Perlbal::Pool $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# a backend stays alive if we still have users. eventually this whole
# function might do more and actually take into account the individual
# backend, but for now, this suits us.
return 1 if $self->{use_count};
return 0;
}
sub node_count {
my Perlbal::Pool $self = $_[0];
return $self->{node_count};
}
sub nodes {
my Perlbal::Pool $self = $_[0];
return $self->{nodes};
}
sub node_used {
my Perlbal::Pool $self = $_[0];
return $self->{node_used}->{$_[1]};
}
sub mark_node_used {
my Perlbal::Pool $self = $_[0];
$self->{node_used}->{$_[1]}++;
}
sub increment_use_count {
my Perlbal::Pool $self = $_[0];
$self->{use_count}++;
}
sub decrement_use_count {
my Perlbal::Pool $self = $_[0];
$self->{use_count}--;
}
sub name {
my Perlbal::Pool $self = $_[0];
return $self->{name};
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

248
wcmtools/perlbal/lib/Perlbal/ReproxyManager.pm Executable file
View File

@@ -0,0 +1,248 @@
######################################################################
# HTTP connection to backend node
# possible states: connecting, bored, sending_req, wait_res, xfer_res
######################################################################
package Perlbal::ReproxyManager;
use strict;
use warnings;
# class storage to store 'host:ip' => $service objects, for making
# reproxies use a service that you can then track
our $ReproxySelf;
our %ReproxyConnecting; # ( host:ip => $backend ); keeps track of outstanding connections to backend that
# are in the connecting state
our %ReproxyBored; # ( host:ip => [ $backend, ... ] ); list of our bored backends
our %ReproxyQueues; # ( host:ip => [ $clientproxy, ... ] ); queued up requests for this backend
our %ReproxyBackends; # ( host:ip => [ $backend, ... ] ); array of backends we have connected
our %ReproxyMax; # ( host:ip => int ); maximum number of connections to have open at any one time
our $ReproxyGlobalMax; # int; the global cap used if no per-host cap is specified
our $NoSpawn = 0; # bool; when set, spawn_backend immediately returns without running
our $LastCleanup = 0; # int; time we last ran our cleanup logic (FIXME: temp hack)
# singleton new function; returns us if we exist, else creates us
sub get {
return $ReproxySelf if $ReproxySelf;
# doesn't exist, so create it and return it
my $class = shift;
my $self = {};
bless $self, $class;
return $ReproxySelf = $self;
}
# given (clientproxy, primary_res_hdrs), initiate proceedings to process a
# request for a reproxy resource
sub do_reproxy {
my Perlbal::ReproxyManager $self = Perlbal::ReproxyManager->get; # singleton
my Perlbal::ClientProxy $cp = $_[0];
return undef unless $self && $cp;
# get data we use
my $datref = $cp->{reproxy_uris}->[0];
my $ipport = "$datref->[0]:$datref->[1]";
push @{$ReproxyQueues{$ipport} ||= []}, $cp;
# see if we should do cleanup (FIXME: temp hack)
my $now = time();
if ($LastCleanup < $now - 5) {
# remove closed backends from our array. this is O(n) but n is small
# and we're paranoid that just keeping a count would get corrupt over
# time. also removes the backends that have clients that are closed.
@{$ReproxyBackends{$ipport}} = grep {
! $_->{closed} && (! $_->{client} || ! $_->{client}->{closed})
} @{$ReproxyBackends{$ipport}};
$LastCleanup = $now;
}
# now start a new backend
$self->spawn_backend($ipport);
return 1;
}
# part of the reportto interface; this is called when a backend is unable to establish
# a connection with a backend. we simply try the next uri.
sub note_bad_backend_connect {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# decrement counts and undef connecting backend
$ReproxyConnecting{$be->{ipport}} = undef;
# if nobody waiting, doesn't matter if we couldn't get to this backend
return unless @{$ReproxyQueues{$be->{ipport}} || []};
# if we still have some connected backends then ignore this bad connection attempt
return if scalar @{$ReproxyBackends{$be->{ipport}} || []};
# at this point, we have no connected backends, and our connecting one failed
# so we want to tell all of the waiting clients to try their next uri, because
# this host is down.
while (my Perlbal::ClientProxy $cp = shift @{$ReproxyQueues{$be->{ipport}}}) {
$cp->try_next_uri;
}
return 1;
}
# called by a backend when it's ready for a request
sub register_boredom {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# if this backend was connecting
my $ipport = $be->{ipport};
if ($ReproxyConnecting{$ipport} && $ReproxyConnecting{$ipport} == $be) {
$ReproxyConnecting{$ipport} = undef;
$ReproxyBackends{$ipport} ||= [];
push @{$ReproxyBackends{$ipport}}, $be;
}
# sometimes a backend is closed but it tries to register with us anyway... ignore it
# but since this might have been our only one, spawn another
if ($be->{closed}) {
$self->spawn_backend($ipport);
return;
}
# find some clients to use
while (my Perlbal::ClientProxy $cp = shift @{$ReproxyQueues{$ipport} || []}) {
# safety checks
next if $cp->{closed};
# give backend to client
$cp->use_reproxy_backend($be);
return;
}
# no clients if we get here, so push onto bored backend list
push @{$ReproxyBored{$ipport} ||= []}, $be;
# clean up the front of our list if we can (see docs above)
if (my Perlbal::BackendHTTP $bbe = $ReproxyBored{$ipport}->[0]) {
if ($bbe->{alive_time} < time() - 5) {
$NoSpawn = 1;
$bbe->close('have_newer_bored');
shift @{$ReproxyBored{$ipport}};
$NoSpawn = 0;
}
}
return 0;
}
# backend closed, decrease counts, etc
sub note_backend_close {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# remove closed backends from our array. this is O(n) but n is small
# and we're paranoid that just keeping a count would get corrupt over
# time.
@{$ReproxyBackends{$be->{ipport}}} = grep {
! $_->{closed}
} @{$ReproxyBackends{$be->{ipport}}};
# spawn more if needed
$self->spawn_backend($be->{ipport});
}
sub spawn_backend {
return if $NoSpawn;
my Perlbal::ReproxyManager $self = $_[0];
my $ipport = $_[1];
# if we're already connecting, we don't want to spawn another one
if (my Perlbal::BackendHTTP $be = $ReproxyConnecting{$ipport}) {
# see if this one is too old?
if ($be->{create_time} < (time() - 5)) { # older than 5 seconds?
$self->note_bad_backend_connect($be);
$be->close("connection_timeout");
# we return here instead of spawning because closing the backend calls
# note_backend_close which will call spawn_backend again, and at that
# point we won't have a pending connection and can spawn
return;
} else {
# don't spawn more if we're already connecting
return;
}
}
# if nobody waiting, don't spawn extra connections
return unless @{$ReproxyQueues{$ipport} || []};
# don't spawn if we have a bored one already
while (my Perlbal::BackendHTTP $bbe = pop @{$ReproxyBored{$ipport} || []}) {
# don't use keep-alive connections if we know the server's
# just about to kill the connection for being idle
my $now = time();
if ($bbe->{disconnect_at} && $now + 2 > $bbe->{disconnect_at} ||
$bbe->{alive_time} < $now - 5)
{
$NoSpawn = 1;
$bbe->close("too_close_disconnect");
$NoSpawn = 0;
next;
}
# it's good, give it to someone
$self->register_boredom($bbe);
return;
}
# see if we have too many already?
my $max = $ReproxyMax{$ipport} || $ReproxyGlobalMax || 0;
my $count = scalar @{$ReproxyBackends{$ipport} || []};
return if $max && ($count >= $max);
# start one connecting and enqueue
my $be = Perlbal::BackendHTTP->new(undef, split(/:/, $ipport), { reportto => $self })
or return 0;
$ReproxyConnecting{$ipport} = $be;
}
sub backend_response_received {
my Perlbal::ReproxyManager $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
my Perlbal::ClientProxy $cp = $be->{client};
# if no client, close backend and return 1
unless ($cp) {
$be->close("lost_client");
return 1;
}
# pass on to client
return $cp->backend_response_received($be);
}
sub dump_state {
my $out = shift;
return unless $out;
# spits out what we have connecting
while (my ($hostip, $dat) = each %ReproxyConnecting) {
$out->("connecting $hostip 1") if defined $dat;
}
while (my ($hostip, $dat) = each %ReproxyBored) {
$out->("bored $hostip " . scalar(@$dat));
}
while (my ($hostip, $dat) = each %ReproxyQueues) {
$out->("clients_queued $hostip " . scalar(@$dat));
}
while (my ($hostip, $dat) = each %ReproxyBackends) {
$out->("backends $hostip " . scalar(@$dat));
foreach my $be (@$dat) {
$out->("... " . $be->as_string);
}
}
while (my ($hostip, $dat) = each %ReproxyMax) {
$out->("SERVER max_reproxy_connections($hostip) = $dat");
}
$out->("SERVER max_reproxy_connections = " . ($ReproxyGlobalMax || 0));
$out->('.');
}
1;

907
wcmtools/perlbal/lib/Perlbal/Service.pm Executable file
View File

@@ -0,0 +1,907 @@
######################################################################
# Service class
######################################################################
package Perlbal::Service;
use strict;
use warnings;
use Net::Netmask;
use Perlbal::BackendHTTP;
use fields (
'name',
'enabled', # bool
'role', # currently 'reverse_proxy' or 'management'
'listen', # scalar: "$ip:$port"
'pool', # Perlbal::Pool that we're using to allocate nodes if we're in proxy mode
'docroot', # document root for webserver role
'dirindexing', # bool: direcotry indexing? (for webserver role) not async.
'index_files', # arrayref of filenames to try for index files
'listener',
'waiting_clients', # arrayref of clients waiting for backendhttp conns
'waiting_clients_highpri', # arrayref of high-priority clients waiting for backendhttp conns
'waiting_client_count', # number of clients waiting for backendds
'waiting_client_map' , # map of clientproxy fd -> 1 (if they're waiting for a conn)
'pending_connects', # hashref of "ip:port" -> $time (only one pending connect to backend at a time)
'pending_connect_count', # number of outstanding backend connects
'high_priority_cookie', # cookie name to check if client can 'cut in line' and get backends faster
'high_priority_cookie_contents', # aforementioned cookie value must contain this substring
'connect_ahead', # scalar: number of spare backends to connect to in advance all the time
'backend_persist_cache', # scalar: max number of persistent backends to hold onto while no clients
'bored_backends', # arrayref of backends we've already connected to, but haven't got clients
'persist_client', # bool: persistent connections for clients
'persist_backend', # bool: persistent connections for backends
'verify_backend', # bool: get attention of backend before giving it clients (using OPTIONS)
'max_backend_uses', # max requests to send per kept-alive backend (default 0 = unlimited)
'hooks', # hashref: hookname => [ [ plugin, ref ], [ plugin, ref ], ... ]
'plugins', # hashref: name => 1
'plugin_order', # arrayref: name, name, name...
'plugin_setters', # hashref: { plugin_name => { key_name => coderef } }
'extra_config', # hashref: extra config options; name => values
'enable_put', # bool: whether PUT is supported
'max_put_size', # int: max size in bytes of a put file
'min_put_directory', # int: number of directories required to exist at beginning of URIs in put
'enable_delete', # bool: whether DELETE is supported
'buffer_size', # int: specifies how much data a ClientProxy object should buffer from a backend
'buffer_size_reproxy_url', # int: same as above but for backends that are reproxying for us
'spawn_lock', # bool: if true, we're currently in spawn_backends
'queue_relief_size', # int; number of outstanding standard priority
# connections to activate pressure relief at
'queue_relief_chance', # int:0-100; % chance to take a standard priority
# request when we're in pressure relief mode
'trusted_upstreams', # Net::Netmask object containing netmasks for trusted upstreams
'always_trusted', # bool; if true, always trust upstreams
'extra_headers', # { insert => [ [ header, value ], ... ], remove => [ header, header, ... ],
# set => [ [ header, value ], ... ] }; used in header management interface
'generation', # int; generation count so we can slough off backends from old pools
'backend_no_spawn', # { "ip:port" => 1 }; if on, spawn_backends will ignore this ip:port combo
'buffer_backend_connect', # 0 for of, else, number of bytes to buffer before we ask for a backend
);
sub new {
my Perlbal::Service $self = shift;
$self = fields::new($self) unless ref $self;
my ($name) = @_;
$self->{name} = $name;
$self->{enabled} = 0;
$self->{listen} = "";
$self->{persist_client} = 0;
$self->{persist_backend} = 0;
$self->{verify_backend} = 0;
$self->{max_backend_uses} = 0;
$self->{backend_persist_cache} = 2;
$self->{generation} = 0;
$self->{backend_no_spawn} = {};
$self->{buffer_backend_connect} = 0;
$self->{hooks} = {};
$self->{plugins} = {};
$self->{plugin_order} = [];
$self->{enable_put} = 0;
$self->{max_put_size} = 0; # 0 means no max size
$self->{min_put_directory} = 0;
$self->{enable_delete} = 0;
# disable pressure relief by default
$self->{queue_relief_size} = 0;
$self->{queue_relief_chance} = 0;
# set some default maximum buffer sizes
$self->{buffer_size} = 256_000;
$self->{buffer_size_reproxy_url} = 51_200;
# track pending connects to backend
$self->{pending_connects} = {};
$self->{pending_connect_count} = 0;
$self->{bored_backends} = [];
$self->{connect_ahead} = 0;
# waiting clients
$self->{waiting_clients} = [];
$self->{waiting_clients_highpri} = [];
$self->{waiting_client_count} = 0;
# directory handling
$self->{dirindexing} = 0;
$self->{index_files} = [ 'index.html' ];
# don't have an object for this yet
$self->{trusted_upstreams} = undef;
$self->{always_trusted} = 0;
# bare data structure for extra header info
$self->{extra_headers} = { remove => [], insert => [] };
return $self;
}
# run the hooks in a list one by one until one hook returns 1. returns
# 1 or 0 depending on if any hooks handled the request.
sub run_hook {
my Perlbal::Service $self = shift;
my $hook = shift;
if (defined (my $ref = $self->{hooks}->{$hook})) {
# call all the hooks until one returns true
foreach my $hookref (@$ref) {
my $rval = $hookref->[1]->(@_);
return 1 if defined $rval && $rval;
}
}
return 0;
}
# run a bunch of hooks in this service, always returns undef.
sub run_hooks {
my Perlbal::Service $self = shift;
my $hook = shift;
if (defined (my $ref = $self->{hooks}->{$hook})) {
# call all the hooks
$_->[1]->(@_) foreach @$ref;
}
return undef;
}
# define a hook for this service
sub register_hook {
my Perlbal::Service $self = shift;
my ($pclass, $hook, $ref) = @_;
push @{$self->{hooks}->{$hook} ||= []}, [ $pclass, $ref ];
return 1;
}
# remove hooks we have defined
sub unregister_hook {
my Perlbal::Service $self = shift;
my ($pclass, $hook) = @_;
if (defined (my $refs = $self->{hooks}->{$hook})) {
my @new;
foreach my $ref (@$refs) {
# fill @new with hooks that DON'T match
push @new, $ref
unless $ref->[0] eq $pclass;
}
$self->{hooks}->{$hook} = \@new;
return 1;
}
return undef;
}
# remove all hooks of a certain class
sub unregister_hooks {
my Perlbal::Service $self = shift;
foreach my $hook (keys %{$self->{hooks}}) {
# call unregister_hook with this hook name
$self->unregister_hook($_[0], $hook);
}
}
# register a value setter for plugin configuration
sub register_setter {
my Perlbal::Service $self = shift;
my ($pclass, $key, $coderef) = @_;
return unless $pclass && $key && $coderef;
$self->{plugin_setters}->{lc $pclass}->{lc $key} = $coderef;
}
# remove a setter
sub unregister_setter {
my Perlbal::Service $self = shift;
my ($pclass, $key) = @_;
return unless $pclass && $key;
delete $self->{plugin_setters}->{lc $pclass}->{lc $key};
}
# remove a bunch of setters
sub unregister_setters {
my Perlbal::Service $self = shift;
my $pclass = shift;
return unless $pclass;
delete $self->{plugin_setters}->{lc $pclass};
}
# take a backend we've created and mark it as pending if we do not
# have another pending backend connection in this slot
sub add_pending_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
# error if we already have a pending connection for this ipport
if (defined $self->{pending_connects}{$be->{ipport}}) {
Perlbal::log('warning', "Warning: attempting to spawn backend connection that already existed.");
# now dump a backtrace so we know how we got here
my $depth = 0;
while (my ($package, $filename, $line, $subroutine) = caller($depth++)) {
Perlbal::log('warning', " -- [$filename:$line] $package::$subroutine");
}
# we're done now, just return
return;
}
# set this connection up in the pending connection list
$self->{pending_connects}{$be->{ipport}} = $be;
$self->{pending_connect_count}++;
}
# remove a backend connection from the pending connect list if and only
# if it is the actual connection contained in the list; prevent double
# decrementing on accident
sub clear_pending_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
if (defined $self->{pending_connects}{$be->{ipport}} && defined $be &&
$self->{pending_connects}{$be->{ipport}} == $be) {
$self->{pending_connects}{$be->{ipport}} = undef;
$self->{pending_connect_count}--;
}
}
# called by BackendHTTP when it's closed by any means
sub note_backend_close {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
$self->clear_pending_connect($be);
$self->spawn_backends;
}
# called by ClientProxy when it dies.
sub note_client_close {
my Perlbal::Service $self;
my Perlbal::ClientProxy $cp;
($self, $cp) = @_;
if (delete $self->{waiting_client_map}{$cp->{fd}}) {
$self->{waiting_client_count}--;
}
}
sub mark_node_used {
my Perlbal::Service $self = $_[0];
$self->{pool}->mark_node_used($_[1]) if $self->{pool};
}
sub get_client {
my Perlbal::Service $self = shift;
my $ret = sub {
my Perlbal::ClientProxy $cp = shift;
$self->{waiting_client_count}--;
delete $self->{waiting_client_map}{$cp->{fd}};
# before we return, start another round of connections
$self->spawn_backends;
return $cp;
};
# determine if we should jump straight to the high priority queue or
# act as pressure relief on the standard queue
my $hp_first = 1;
if (($self->{queue_relief_size} > 0) &&
(scalar(@{$self->{waiting_clients}}) >= $self->{queue_relief_size})) {
# if we're below the chance level, take a standard queue item
$hp_first = 0
if rand(100) < $self->{queue_relief_chance};
}
# find a high-priority client, or a regular one
my Perlbal::ClientProxy $cp;
while ($hp_first && ($cp = shift @{$self->{waiting_clients_highpri}})) {
if (Perlbal::DEBUG >= 2) {
my $backlog = scalar @{$self->{waiting_clients}};
print "Got from fast queue, in front of $backlog others\n";
}
return $ret->($cp) if ! $cp->{closed};
}
while ($cp = shift @{$self->{waiting_clients}}) {
if (Perlbal::DEBUG >= 2) {
print "Backend requesting client, got normal = $cp->{fd}.\n" unless $cp->{closed};
}
return $ret->($cp) if ! $cp->{closed};
}
return undef;
}
# given a backend, verify it's generation
sub verify_generation {
my Perlbal::Service $self = $_[0];
my Perlbal::BackendHTTP $be = $_[1];
# fast cases: generation count matches, so we just return an 'okay!' flag
return 1 if $self->{generation} == $be->generation;
# if our current pool knows about this ip:port, then we can still use it
if (defined $self->{pool}->node_used($be->ipport)) {
# so we know this is good, in the future we just want to hit the fast case
# and continue, so let's update the generation
$be->generation($self->{generation});
return 1;
}
# if we get here, the backend should be closed
$be->close('invalid_generation');
return 0;
}
# called by backend connection after it becomes writable
sub register_boredom {
my Perlbal::Service $self;
my Perlbal::BackendHTTP $be;
($self, $be) = @_;
# note that this backend is no longer pending a connect,
# if we thought it was before. but not if it's a persistent
# connection asking to be re-used.
unless ($be->{use_count}) {
$self->clear_pending_connect($be);
}
# it is possible that this backend is part of a different pool that we're
# no longer using... if that's the case, we want to close it
return unless $self->verify_generation($be);
# now try to fetch a client for it
my Perlbal::ClientProxy $cp = $self->get_client;
if ($cp) {
if ($be->assign_client($cp)) {
return;
} else {
# don't want to lose client, so we (unfortunately)
# stick it at the end of the waiting queue.
# fortunately, assign_client shouldn't ever fail.
$self->request_backend_connection($cp);
}
}
# don't hang onto more bored, persistent connections than
# has been configured for connect-ahead
if ($be->{use_count}) {
my $current_bored = scalar @{$self->{bored_backends}};
if ($current_bored >= $self->{backend_persist_cache}) {
$be->close('too_many_bored');
return;
}
}
# put backends which are known to be bound to processes
# and not to TCP stacks at the beginning where they'll
# be used first
if ($be->{has_attention}) {
unshift @{$self->{bored_backends}}, $be;
} else {
push @{$self->{bored_backends}}, $be;
}
}
sub note_bad_backend_connect {
my Perlbal::Service $self = shift;
my Perlbal::BackendHTTP $be = shift;
my $retry_time = shift();
# clear this pending connection
$self->clear_pending_connect($be);
# mark this host as dead for a while if we need to
if (defined $retry_time && $retry_time > 0) {
# we don't want other spawn_backends calls to retry
$self->{backend_no_spawn}->{$be->{ipport}} = 1;
# and now we set a callback to ensure we're kicked at the right time
Perlbal::Socket::register_callback($retry_time, sub {
delete $self->{backend_no_spawn}->{$be->{ipport}};
$self->spawn_backends;
});
}
# FIXME: do something interesting (tell load balancer about dead host,
# and fire up a new connection, if warranted)
# makes a new connection, if needed
$self->spawn_backends;
}
sub request_backend_connection {
my Perlbal::Service $self;
my Perlbal::ClientProxy $cp;
($self, $cp) = @_;
my $hi_pri = 0; # by default, low priority
# is there a defined high-priority cookie?
if (my $cname = $self->{high_priority_cookie}) {
# decide what priority class this request is in
my $hd = $cp->{req_headers};
my %cookie;
foreach (split(/;\s+/, $hd->header("Cookie") || '')) {
next unless ($_ =~ /(.*)=(.*)/);
$cookie{_durl($1)} = _durl($2);
}
my $hicookie = $cookie{$cname} || "";
$hi_pri = index($hicookie, $self->{high_priority_cookie_contents}) != -1;
}
# now, call hook to see if this should be high priority
$hi_pri = $self->run_hook('make_high_priority', $cp)
unless $hi_pri; # only if it's not already
$cp->{high_priority} = 1 if $hi_pri;
# before we even consider spawning backends, let's see if we have
# some bored (pre-connected) backends that'd take this client
my Perlbal::BackendHTTP $be;
my $now = time;
while ($be = shift @{$self->{bored_backends}}) {
next if $be->{closed};
# now make sure that it's still in our pool, and if not, close it
next unless $self->verify_generation($be);
# don't use connect-ahead connections when we haven't
# verified we have their attention
if (! $be->{has_attention} && $be->{create_time} < $now - 5) {
$be->close("too_old_bored");
next;
}
# don't use keep-alive connections if we know the server's
# just about to kill the connection for being idle
if ($be->{disconnect_at} && $now + 2 > $be->{disconnect_at}) {
$be->close("too_close_disconnect");
next;
}
# give the backend this client
if ($be->assign_client($cp)) {
# and make some extra bored backends, if configured as such
$self->spawn_backends;
return;
}
}
if ($hi_pri) {
push @{$self->{waiting_clients_highpri}}, $cp;
} else {
push @{$self->{waiting_clients}}, $cp;
}
$self->{waiting_client_count}++;
$self->{waiting_client_map}{$cp->{fd}} = 1;
$self->spawn_backends;
}
# sees if it should spawn one or more backend connections
sub spawn_backends {
my Perlbal::Service $self = shift;
# to spawn we must have a pool
return unless $self->{pool};
# check our lock and set it if we can
return if $self->{spawn_lock};
$self->{spawn_lock} = 1;
# sanity checks on our bookkeeping
if ($self->{pending_connect_count} < 0) {
Perlbal::log('crit', "Bogus: service $self->{name} has pending connect ".
"count of $self->{pending_connect_count}?! Resetting.");
$self->{pending_connect_count} = scalar
map { $_ && ! $_->{closed} } values %{$self->{pending_connects}};
}
# keep track of the sum of existing_bored + bored_created
my $backends_created = scalar(@{$self->{bored_backends}}) + $self->{pending_connect_count};
my $backends_needed = $self->{waiting_client_count} + $self->{connect_ahead};
my $to_create = $backends_needed - $backends_created;
# can't create more than this, assuming one pending connect per node
my $max_creatable = $self->{pool}->node_count - $self->{pending_connect_count};
$to_create = $max_creatable if $to_create > $max_creatable;
# cap number of attempted connects at once
$to_create = 10 if $to_create > 10;
my $now = time;
while ($to_create > 0) {
$to_create--;
my ($ip, $port) = $self->{pool}->get_backend_endpoint;
unless ($ip) {
Perlbal::log('crit', "No backend IP for service $self->{name}");
# FIXME: register desperate flag, so load-balancer module can callback when it has a node
$self->{spawn_lock} = 0;
return;
}
# handle retry timeouts so we don't spin
next if $self->{backend_no_spawn}->{"$ip:$port"};
# if it's pending, verify the pending one is still valid
if (my Perlbal::BackendHTTP $be = $self->{pending_connects}{"$ip:$port"}) {
my $age = $now - $be->{create_time};
if ($age >= 5 && $be->{state} eq "connecting") {
$be->close('connect_timeout');
} elsif ($age >= 60 && $be->{state} eq "verifying_backend") {
# after 60 seconds of attempting to verify, we're probably already dead
$be->close('verify_timeout');
} elsif (! $be->{closed}) {
next;
}
}
# now actually spawn a backend and add it to our pending list
if (my $be = Perlbal::BackendHTTP->new($self, $ip, $port, { pool => $self->{pool},
generation => $self->{generation} })) {
$self->add_pending_connect($be);
}
}
# clear our spawn lock
$self->{spawn_lock} = 0;
}
# getter only
sub role {
my Perlbal::Service $self = shift;
return $self->{role};
}
# manage some header stuff
sub header_management {
my Perlbal::Service $self = shift;
my ($mode, $key, $val, $out) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
return $err->("no header provided") unless $key;
return $err->("no value provided") unless $val || $mode eq 'remove';
if ($mode eq 'insert') {
push @{$self->{extra_headers}->{insert}}, [ $key, $val ];
} elsif ($mode eq 'remove') {
push @{$self->{extra_headers}->{remove}}, $key;
} else {
return $err->("invalid mode '$mode'");
}
return 1;
}
sub munge_headers {
my Perlbal::Service $self = $_[0];
my Perlbal::HTTPHeaders $hdrs = $_[1];
# handle removals first
foreach my $hdr (@{$self->{extra_headers}->{remove}}) {
$hdrs->header($hdr, undef);
}
# and now insertions
foreach my $hdr (@{$self->{extra_headers}->{insert}}) {
$hdrs->header($hdr->[0], $hdr->[1]);
}
}
# Service
sub set {
my Perlbal::Service $self = shift;
my ($key, $val, $out, $verbose) = @_;
my $err = sub { $out->("ERROR: $_[0]"); return 0; };
my $ok = sub { $out->("OK") if $verbose; return 1; };
my $set = sub { $self->{$key} = $val; return $ok->(); };
my $pool_set = sub {
# if we don't have a pool, automatically create one named $NAME_pool
unless ($self->{pool}) {
# die if necessary
die "ERROR: Attempt to vivify pool $self->{name}_pool but one or more pools\n" .
" have already been created manually. Please set $key on a\n" .
" previously created pool.\n" unless $Perlbal::vivify_pools;
# create the pool and ensure that vivify stays on
Perlbal::run_manage_command("CREATE POOL $self->{name}_pool", $out);
Perlbal::run_manage_command("SET $self->{name}.pool = $self->{name}_pool");
$Perlbal::vivify_pools = 1;
}
# now we actually do the set
warn "WARNING: '$key' set on service $self->{name} on auto-vivified pool.\n" .
" This behavior is obsolete. This value should be set on a\n" .
" pool object and not on a service.\n" if $Perlbal::vivify_pools;
return $err->("No pool defined for service") unless $self->{pool};
return $self->{pool}->set($key, $val, $out, $verbose);
};
if ($key eq "role") {
return $err->("Unknown service role")
unless $val eq "reverse_proxy" || $val eq "management" || $val eq "web_server";
return $set->();
}
if ($key eq "listen") {
return $err->("Invalid host:port")
unless $val =~ m!^\d+\.\d+\.\d+\.\d+:\d+$!;
# close/reopen listening socket
if ($val ne $self->{listen} && $self->{enabled}) {
$self->disable(undef, "force");
$self->{listen} = $val;
$self->enable(undef);
}
return $set->();
}
my $bool = sub {
my $val = shift;
return 1 if $val =~ /^1|true|on|yes$/i;
return 0 if $val =~ /^0|false|off|no$/i;
return undef;
};
if ($key eq 'trusted_upstream_proxies') {
if ($self->{trusted_upstreams} = Net::Netmask->new2($val)) {
# set, all good
return $ok->();
} else {
return $err->("Error defining trusted upstream proxies: " . Net::Netmask::errstr());
}
}
if ($key eq 'always_trusted') {
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'")
unless defined $val;
return $set->();
}
if ($key eq 'enable_put' || $key eq 'enable_delete') {
return $err->("This can only be used on web_server service")
unless $self->{role} eq 'web_server';
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'.")
unless defined $val;
return $set->();
}
if ($key eq "persist_client" || $key eq "persist_backend" ||
$key eq "verify_backend") {
$val = $bool->($val);
return $err->("Expecting boolean value for option '$key'")
unless defined $val;
return $set->();
}
# this is now handled by Perlbal::Pool, so we pass this set command on
# through in case people try to use it on us like the old method.
return $pool_set->()
if $key eq 'balance_method' ||
$key eq 'nodefile' ||
$key =~ /^sendstats\./;
if ($key eq "balance_method") {
return $err->("Can only set balance method on a reverse_proxy service")
unless $self->{role} eq "reverse_proxy";
}
if ($key eq "high_priority_cookie" || $key eq "high_priority_cookie_contents") {
return $set->();
}
if ($key eq "connect_ahead") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
$set->();
$self->spawn_backends if $self->{enabled};
return $ok->();
}
if ($key eq "max_backend_uses" || $key eq "backend_persist_cache" ||
$key eq "max_put_size" || $key eq "min_put_directory" ||
$key eq "buffer_size" || $key eq "buffer_size_reproxy_url" ||
$key eq "queue_relief_size" || $key eq "buffer_backend_connect") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
return $set->();
}
if ($key eq "queue_relief_chance") {
return $err->("Expected integer value") unless $val =~ /^\d+$/;
return $err->("Expected integer value between 0 and 100 inclusive")
unless $val >= 0 && $val <= 100;
return $set->();
}
if ($key eq "docroot") {
return $err->("Can only set docroot on a web_server service")
unless $self->{role} eq "web_server";
$val =~ s!/$!!;
return $err->("Directory not found")
unless $val && -d $val;
return $set->();
}
if ($key eq "dirindexing") {
return $err->("Can only set dirindexing on a web_server service")
unless $self->{role} eq "web_server";
return $err->("Expected value 0 or 1")
unless $val eq '0' || $val eq '1';
return $set->();
}
if ($key eq "index_files") {
return $err->("Can only set index_files on a web_server service")
unless $self->{role} eq "web_server";
my @list = split(/[\s,]+/, $val);
$self->{index_files} = \@list;
return $ok->();
}
if ($key eq 'plugins') {
# unload existing plugins
foreach my $plugin (keys %{$self->{plugins}}) {
eval "Perlbal::Plugin::$plugin->unregister(\$self);";
return $err->($@) if $@;
}
# clear out loaded plugins and hooks
$self->{hooks} = {};
$self->{plugins} = {};
$self->{plugin_order} = [];
# load some plugins
foreach my $plugin (split /[\s,]+/, $val) {
next if $plugin eq 'none';
# since we lowercase our input, uppercase the first character here
my $fn = uc($1) . lc($2) if $plugin =~ /^(.)(.*)$/;
next if $self->{plugins}->{$fn};
unless ($Perlbal::plugins{$fn}) {
$err->("Plugin $fn not loaded; not registered for $self->{name}.");
next;
}
# now register it
eval "Perlbal::Plugin::$fn->register(\$self);";
$self->{plugins}->{$fn} = 1;
push @{$self->{plugin_order}}, $fn;
return $err->($@) if $@;
}
return $ok->();
}
if ($key =~ /^extra\.(.+)$/) {
# set some extra configuration data data
$self->{extra_config}->{$1} = $val;
return $ok->();
}
if ($key eq 'pool') {
my $pl = Perlbal->pool($val);
return $err->("Pool '$val' not found") unless $pl;
$self->{pool}->decrement_use_count if $self->{pool};
$self->{pool} = $pl;
$self->{pool}->increment_use_count;
$self->{generation}++;
return $ok->();
}
# see if it happens to be a plugin set command?
if ($key =~ /^(.+)\.(.+)$/) {
if (my $coderef = $self->{plugin_setters}->{$1}->{$2}) {
return $coderef->($out, $2, $val);
}
}
return $err->("Unknown attribute '$key'");
}
# Service
sub enable {
my Perlbal::Service $self;
my $out;
($self, $out) = @_;
if ($self->{enabled}) {
$out && $out->("ERROR: service $self->{name} is already enabled");
return 0;
}
# create listening socket
my $tl = Perlbal::TCPListener->new($self->{listen}, $self);
unless ($tl) {
$out && $out->("ERROR: Can't start service '$self->{name}' on $self->{listen}: $Perlbal::last_error");
return 0;
}
$self->{listener} = $tl;
$self->{enabled} = 1;
return 1;
}
# Service
sub disable {
my Perlbal::Service $self;
my ($out, $force);
($self, $out, $force) = @_;
if (! $self->{enabled}) {
$out && $out->("ERROR: service $self->{name} is already disabled");
return 0;
}
if ($self->{role} eq "management" && ! $force) {
$out && $out->("ERROR: can't disable management service");
return 0;
}
# find listening socket
my $tl = $self->{listener};
$tl->close;
$self->{listener} = undef;
$self->{enabled} = 0;
return 1;
}
sub stats_info
{
my Perlbal::Service $self = shift;
my $out = shift;
my $now = time;
$out->("SERVICE $self->{name}");
$out->(" listening: $self->{listen}");
$out->(" role: $self->{role}");
if ($self->{role} eq "reverse_proxy" ||
$self->{role} eq "web_server") {
$out->(" pend clients: $self->{waiting_client_count}");
$out->(" pend backend: $self->{pending_connect_count}");
foreach my $ipport (sort keys %{$self->{pending_connects}}) {
my $be = $self->{pending_connects}{$ipport};
next unless $be;
my $age = $now - $be->{create_time};
$out->(" $ipport - " . ($be->{closed} ? "(closed)" : $be->{state}) . " - ${age}s");
}
}
if ($self->{role} eq "reverse_proxy") {
my $bored_count = scalar @{$self->{bored_backends}};
$out->(" connect-ahead: $bored_count/$self->{connect_ahead}");
if ($self->{pool}) {
$out->(" pool: " . $self->{pool}->name);
$out->("balance method: " . $self->{pool}->balance_method);
$out->(" nodes:");
foreach my $n (@{ $self->{pool}->nodes }) {
my $hostport = "$n->[0]:$n->[1]";
$out->(sprintf(" %-21s %7d", $hostport, $self->{pool}->node_used($hostport) || 0));
}
}
} elsif ($self->{role} eq "web_server") {
$out->(" docroot: $self->{docroot}");
}
}
# simple passthroughs to the run_hook mechanism. part of the reportto interface.
sub backend_response_received {
return $_[0]->run_hook('backend_response_received', $_[1]);
}
sub _durl
{
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

279
wcmtools/perlbal/lib/Perlbal/Socket.pm Executable file
View File

@@ -0,0 +1,279 @@
######################################################################
# Base class for all socket types
######################################################################
package Perlbal::Socket;
use strict;
use warnings;
use Perlbal::HTTPHeaders;
use Danga::Socket '1.25';
use base 'Danga::Socket';
use fields (
'headers_string', # headers as they're being read
'req_headers', # the final Perlbal::HTTPHeaders object inbound
'res_headers', # response headers outbound (Perlbal::HTTPHeaders object)
'create_time', # creation time
'alive_time', # last time noted alive
'state', # general purpose state; used by descendants.
'do_die', # if on, die and do no further requests
'read_buf',
'read_ahead',
'read_size',
);
use constant MAX_HTTP_HEADER_LENGTH => 102400; # 100k, arbitrary
use constant TRACK_OBJECTS => 0; # see @created_objects below
if (TRACK_OBJECTS) {
use Scalar::Util qw(weaken isweak);
}
# time we last did a full connection sweep (O(n) .. lame)
# and closed idle connections.
our $last_cleanup = 0;
our %state_changes = (); # { "objref" => [ state, state, state, ... ] }
our $last_callbacks = 0; # time last ran callbacks
our $callbacks = []; # [ [ time, subref ], [ time, subref ], ... ]
# this one deserves its own section. we keep track of every Perlbal::Socket object
# created if the TRACK_OBJECTS constant is on. we use weakened references, though,
# so this list will hopefully contain mostly undefs. users can ask for this list if
# they want to work with it via the get_created_objects_ref function.
our @created_objects; # ( $ref, $ref, $ref ... )
our $last_co_cleanup = 0; # clean the list every few seconds
sub get_statechange_ref {
return \%state_changes;
}
sub get_created_objects_ref {
return \@created_objects;
}
sub new {
my Perlbal::Socket $self = shift;
$self = fields::new( $self ) unless ref $self;
Perlbal::objctor($self);
$self->SUPER::new( @_ );
$self->{headers_string} = '';
$self->{state} = undef;
$self->{do_die} = 0;
my $now = time;
$self->{alive_time} = $self->{create_time} = $now;
# see if it's time to do a cleanup
# FIXME: constant time interval is lame. on pressure/idle?
if ($now - 15 > $last_cleanup) {
$last_cleanup = $now;
_do_cleanup();
}
# now put this item in the list of created objects
if (TRACK_OBJECTS) {
# clean the created objects list if necessary
if ($last_co_cleanup < $now - 5) {
# remove out undefs, because those are natural byproducts of weakening
# references
@created_objects = grep { $_ } @created_objects;
# however, the grep turned our weak references back into strong ones, so
# we have to reweaken them
weaken($_) foreach @created_objects;
# we've cleaned up at this point
$last_co_cleanup = $now;
}
# now add this one to our cleaned list and weaken it
push @created_objects, $self;
weaken($created_objects[-1]);
}
return $self;
}
# FIXME: this doesn't scale in theory, but it might use less CPU in
# practice than using the Heap:: modules and manipulating the
# expirations all the time, thus doing things properly
# algorithmically. and this is definitely less work, so it's worth
# a try.
sub _do_cleanup {
my $sf = Perlbal::Socket->get_sock_ref;
my $now = time;
my %max_age; # classname -> max age (0 means forever)
my @to_close;
while (my $k = each %$sf) {
my Perlbal::Socket $v = $sf->{$k};
my $ref = ref $v;
unless (defined $max_age{$ref}) {
$max_age{$ref} = $ref->max_idle_time || 0;
}
next unless $max_age{$ref};
if ($v->{alive_time} < $now - $max_age{$ref}) {
push @to_close, $v;
}
}
$_->close("perlbal_timeout") foreach @to_close;
}
# CLASS METHOD: given a delay (in seconds) and a subref, this will call
# that subref in AT LEAST delay seconds. if the subref returns 0, the
# callback is discarded, but if it returns a positive number, the callback
# is pushed onto the callback stack to be called again in at least that
# many seconds.
sub register_callback {
# adds a new callback to our list
my ($delay, $subref) = @_;
push @$callbacks, [ time + $delay, $subref ];
return 1;
}
# CLASS METHOD: runs through the list of registered callbacks and executes
# any that need to be executed
# FIXME: this doesn't scale. need a heap.
sub run_callbacks {
my $now = time;
return if $last_callbacks == $now;
$last_callbacks = $now;
my @destlist = ();
foreach my $ref (@$callbacks) {
# if their time is <= now...
if ($ref->[0] <= $now) {
# find out if they want to run again...
my $rv = $ref->[1]->();
# and if they do, push onto list...
push @destlist, [ $rv + $now, $ref->[1] ]
if defined $rv && $rv > 0;
} else {
# not time for this one, just shove it
push @destlist, $ref;
}
}
$callbacks = \@destlist;
}
# CLASS METHOD:
# default is for sockets to never time out. classes
# can override.
sub max_idle_time { 0; }
# Socket: specific to HTTP socket types
sub read_headers {
my Perlbal::Socket $self = shift;
my $is_res = shift;
$Perlbal::reqs++ unless $is_res;
my $sock = $self->{sock};
my $to_read = MAX_HTTP_HEADER_LENGTH - length($self->{headers_string});
my $bref = $self->read($to_read);
return $self->close('remote_closure') if ! defined $bref; # client disconnected
$self->{headers_string} .= $$bref;
my $idx = index($self->{headers_string}, "\r\n\r\n");
# can't find the header delimiter?
if ($idx == -1) {
$self->close('long_headers')
if length($self->{headers_string}) >= MAX_HTTP_HEADER_LENGTH;
return 0;
}
my $hstr = substr($self->{headers_string}, 0, $idx);
print "HEADERS: [$hstr]\n" if Perlbal::DEBUG >= 2;
my $extra = substr($self->{headers_string}, $idx+4);
if (my $len = length($extra)) {
push @{$self->{read_buf}}, \$extra;
$self->{read_size} = $self->{read_ahead} = length($extra);
print "post-header extra: $len bytes\n" if Perlbal::DEBUG >= 2;
}
unless (($is_res ? $self->{res_headers} : $self->{req_headers}) =
Perlbal::HTTPHeaders->new(\$hstr, $is_res)) {
# bogus headers? close connection.
return $self->close("parse_header_failure");
}
return $is_res ? $self->{res_headers} : $self->{req_headers};
}
### METHOD: drain_read_buf_to( $destination )
### Write read-buffered data (if any) from the receiving object to the
### I<destination> object.
sub drain_read_buf_to {
my ($self, $dest) = @_;
return unless $self->{read_ahead};
while (my $bref = shift @{$self->{read_buf}}) {
$dest->write($bref);
$self->{read_ahead} -= length($$bref);
}
}
### METHOD: die_gracefully()
### By default, if we're in persist_wait state, close. Else, ignore. Children
### can override if they want to do some other processing.
sub die_gracefully {
my Perlbal::Socket $self = $_[0];
if ($self->state eq 'persist_wait') {
$self->close('graceful_shutdown');
}
$self->{do_die} = 1;
}
### METHOD: close()
### Set our state when we get closed.
sub close {
my Perlbal::Socket $self = $_[0];
$self->state('closed');
return $self->SUPER::close($_[1]);
}
### METHOD: state()
### If you pass a parameter, sets the state, else returns it.
sub state {
my Perlbal::Socket $self = shift;
return $self->{state} unless @_;
push @{$state_changes{"$self"} ||= []}, $_[0] if Perlbal::TRACK_STATES;
return $self->{state} = $_[0];
}
sub read_request_headers { read_headers(@_, 0); }
sub read_response_headers { read_headers(@_, 1); }
sub as_string_html {
my Perlbal::Socket $self = shift;
return $self->SUPER::as_string;
}
sub DESTROY {
my Perlbal::Socket $self = shift;
delete $state_changes{"$self"} if Perlbal::TRACK_STATES;
Perlbal::objdtor($self);
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

219
wcmtools/perlbal/lib/Perlbal/StatsListener.pm Executable file
View File

@@ -0,0 +1,219 @@
######################################################################
# UDP listener for Apache free/busy stats
######################################################################
package Perlbal::StatsListener;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields ('service', # Perlbal::Service,
'pos', # index in ring. this index has an empty value in it
# entries before it are good
'message_ring', # arrayref of UDP messages, unparsed
'from_ring', # arrayref of from addresses
'hostinfo', # hashref of ip (4 bytes) -> [ $free, $active ] (or undef)
'total_free', # int scalar: free listeners
'need_parse', # hashref: ip -> pos
'use_count', # hashref: ip -> times_used (ip can also be '' for empty case)
'use_total', # int scalar: count of uses we've had total
'dead', # int; if 1 then we're dead (don't give out any more info)
);
use constant RING_SIZE => 30;
sub new {
my $class = shift;
my ($hostport, $service) = @_;
my $sock = IO::Socket::INET->new(
LocalAddr => $hostport,
Proto => 'udp',
ReuseAddr => 1,
Blocking => 0,
);
return Perlbal::error("Error creating listening socket: $!")
unless $sock;
$sock->sockopt(Socket::SO_BROADCAST, 1);
$sock->blocking(0);
my $self = fields::new($class);
$self->SUPER::new($sock); # init base fields
$self->{dead} = 0;
$self->{service} = $service;
$self->reset_state;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
sub reset_state {
my Perlbal::StatsListener $self = shift;
$self->{pos} = 0;
$self->{message_ring} = [];
$self->{from_ring} = [];
$self->{total_free} = 0;
$self->{need_parse} = {};
$self->{hostinfo} = {};
$self->{use_count} = {};
}
sub event_read {
my Perlbal::StatsListener $self = shift;
my $sock = $self->{sock};
my ($port, $iaddr);
while (my $from = $sock->recv($self->{message_ring}[$self->{pos}], 1024)) {
# set the from just to the 4 byte IP address
($port, $from) = Socket::sockaddr_in($from);
$self->{from_ring}[$self->{pos}] = $from;
# new message from host $from, so clear its cached data
if (exists $self->{hostinfo}{$from}) {
if (my $hi = $self->{hostinfo}{$from}) {
$self->{total_free} -= $hi->[0];
}
$self->{hostinfo}{$from} = undef;
$self->{need_parse}{$from} = $self->{pos};
}
$self->{pos} = 0 if ++$self->{pos} == RING_SIZE;
}
}
sub get_endpoint {
my Perlbal::StatsListener $self = shift;
return () if $self->{dead};
# catch up on our parsing
while (my ($from, $pos) = each %{$self->{need_parse}}) {
# make sure this position still corresponds to that host
next unless $from eq $self->{from_ring}[$pos];
next unless $self->{message_ring}[$pos] =~
m!^bcast_ver=1\nfree=(\d+)\nactive=(\d+)\n$!;
$self->{hostinfo}{$from} = [ $1, $2 ];
$self->{total_free} += $1;
}
$self->{need_parse} = {};
# mode 1 (normal) is on advertised free, mode 2 is when nothing's
# free, so we make a weighted random guess on past performance
my $mode = 1;
my $upper_bound = $self->{total_free};
unless ($upper_bound) {
$mode = 2;
$upper_bound = $self->{use_total};
}
# pick what position we'll return
my $winner = rand($upper_bound);
# find the winner
my $count = 0;
# two passes, since the inner while is doing 'each'
# which we intrerupt when we find the winner. so later,
# coming back into this, the each doesn't necessarily
# start in the beginning so we have to let it loop around
foreach my $pass (1..2) {
while (my ($from, $hi) = each %{$self->{hostinfo}}) {
if ($mode == 1) {
# must have data
next unless $hi;
$count += $hi->[0];
} elsif ($mode == 2) {
# increment count by uses this one's received for weighting
$count += $self->{use_count}{$from};
}
if ($count >= $winner) {
my $ip = Socket::inet_ntoa($from);
if ($mode == 1) {
$hi->[0]--;
$self->{total_free}--;
$self->{use_total}++;
$self->{use_count}{$from}++;
}
return ($ip, 80);
}
}
}
# guess we couldn't find anything
$self->{use_count}{'winner_too_high'}++;
return ();
}
sub set_hosts {
my Perlbal::StatsListener $self = shift;
my @hosts = @_;
# clear the known hosts
$self->reset_state;
# make each provided host known, but undef (meaning
# its ring data hasn't been parsed)
foreach my $dq (@hosts) {
# converted dotted quad to packed format
my $pd = Socket::inet_aton($dq);
$self->{hostinfo}{$pd} = undef;
}
}
sub debug_dump {
my Perlbal::StatsListener $self = shift;
my $out = shift;
no warnings;
$out->("Stats listener dump:");
$out->(" pos = $self->{pos}");
$out->(" message_ring = ");
for (my $i=0; $i<RING_SIZE; $i++) {
my $ip = eval { Socket::inet_ntoa($self->{'from_ring'}[$i]); };
$out->(" \#$i: [$ip] " . $self->{'message_ring'}[$i]);
}
my $count_free = 0;
foreach my $host (sort keys %{$self->{hostinfo}}) {
my $ip = eval { Socket::inet_ntoa($host); };
my $hi = $self->{hostinfo}{$host};
my $need_parse = $self->{need_parse}{$host};
my $uses = $self->{use_count}{$host};
if ($hi) {
$count_free += $hi->[0];
$out->(" host $ip = $uses: [ $hi->[0] free, $hi->[1] act ] needparse=$need_parse");
} else {
$out->(" host $ip = $uses: needparse=$need_parse");
}
}
$out->(" total free: $self->{total_free} (calculated: $count_free)");
$out->("Uses with no total: $self->{use_count}{'no_free'}, winner too high: $self->{use_count}{'winner_too_high'}");
}
sub event_err { }
sub event_hup { }
sub die_gracefully {
# okay, let's actually die now
my $self = shift;
$self->{dead} = 1;
$self->close;
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

95
wcmtools/perlbal/lib/Perlbal/TCPListener.pm Executable file
View File

@@ -0,0 +1,95 @@
######################################################################
# TCP listener on a given port
######################################################################
package Perlbal::TCPListener;
use strict;
use warnings;
use base "Perlbal::Socket";
use fields qw(service hostport);
use Socket qw(IPPROTO_TCP);
# TCPListener
sub new {
my ($class, $hostport, $service) = @_;
my $sock = IO::Socket::INET->new(
LocalAddr => $hostport,
Proto => IPPROTO_TCP,
Listen => 1024,
ReuseAddr => 1,
Blocking => 0,
);
return Perlbal::error("Error creating listening socket: $!")
unless $sock;
# IO::Socket::INET's Blocking => 0 just doesn't seem to work
# on lots of perls. who knows why.
IO::Handle::blocking($sock, 0);
my $self = $class->SUPER::new($sock);
$self->{service} = $service;
$self->{hostport} = $hostport;
bless $self, ref $class || $class;
$self->watch_read(1);
return $self;
}
# TCPListener: accepts a new client connection
sub event_read {
my Perlbal::TCPListener $self = shift;
# accept as many connections as we can
while (my ($psock, $peeraddr) = $self->{sock}->accept) {
my $service_role = $self->{service}->role;
if (Perlbal::DEBUG >= 1) {
my ($pport, $pipr) = Socket::sockaddr_in($peeraddr);
my $pip = Socket::inet_ntoa($pipr);
print "Got new conn: $psock ($pip:$pport) for $service_role\n";
}
IO::Handle::blocking($psock, 0);
if ($service_role eq "reverse_proxy") {
Perlbal::ClientProxy->new($self->{service}, $psock);
} elsif ($service_role eq "management") {
Perlbal::ClientManage->new($self->{service}, $psock);
} elsif ($service_role eq "web_server") {
Perlbal::ClientHTTP->new($self->{service}, $psock);
}
}
}
sub as_string {
my Perlbal::TCPListener $self = shift;
my $ret = $self->SUPER::as_string;
my Perlbal::Service $svc = $self->{service};
$ret .= ": listening on $self->{hostport} for service '$svc->{name}'";
return $ret;
}
sub as_string_html {
my Perlbal::TCPListener $self = shift;
my $ret = $self->SUPER::as_string_html;
my Perlbal::Service $svc = $self->{service};
$ret .= ": listening on $self->{hostport} for service <b>$svc->{name}</b>";
return $ret;
}
sub die_gracefully {
# die off so we stop waiting for new connections
my $self = shift;
$self->close('graceful_death');
}
1;
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

134
wcmtools/perlbal/lib/Perlbal/Test.pm Executable file
View File

@@ -0,0 +1,134 @@
package Perlbal::Test;
use strict;
use POSIX qw( :sys_wait_h );
use IO::Socket::INET;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(ua start_server foreach_aio manage filecontent tempdir new_port
wait_on_child);
our $i_am_parent = 0;
our $msock; # management sock of child
our $to_kill = 0;
our $mgmt_port;
our $free_port = 60000;
END {
manage("shutdown") if $i_am_parent;
}
sub tempdir {
require File::Temp;
return File::Temp::tempdir( CLEANUP => 1 );
}
sub new_port {
return $free_port++; # FIXME: make it somehow detect if port is in use?
}
sub filecontent {
my $file = shift;
my $ct;
open (F, $file) or return undef;
$ct = do { local $/; <F>; };
close F;
return $ct;
}
sub foreach_aio (&) {
my $cb = shift;
foreach my $mode (qw(none linux ioaio)) {
my $line = manage("SERVER aio_mode = $mode");
next unless $line;
$cb->($mode);
}
}
sub manage {
my $cmd = shift;
print $msock "$cmd\r\n";
my $res = <$msock>;
return 0 if !$res || $res =~ /^ERR/;
return $res;
}
sub start_server {
my $conf = shift;
$mgmt_port = new_port();
my $child = fork;
if ($child) {
$i_am_parent = 1;
$to_kill = $child;
my $msock = wait_on_child($child, $mgmt_port);
my $rv = waitpid($child, WNOHANG);
if ($rv) {
die "Child process (webserver) died.\n";
}
print $msock "proc\r\n";
my $spid = undef;
while (<$msock>) {
last if m!^\.\r?\n!;
next unless /^pid:\s+(\d+)/;
$spid = $1;
}
die "Our child was $child, but we connected and it says it's $spid."
unless $child == $spid;
return $msock;
}
# child process...
require Perlbal;
$conf .= qq{
CREATE SERVICE mgmt
SET mgmt.listen = 127.0.0.1:$mgmt_port
SET mgmt.role = management
ENABLE mgmt
};
my $out = sub { print STDOUT join("\n", map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_) . "\n"; };
Perlbal::run_manage_command($_, $out) foreach split(/\n/, $conf);
unless (Perlbal::Socket->WatchedSockets() > 0) {
die "Invalid configuration. (shouldn't happen?) Stopping (self=$$).\n";
}
Perlbal::run();
exit 0;
}
# get the manager socket
sub msock {
return $msock;
}
sub ua {
require LWP;
require LWP::UserAgent;
return LWP::UserAgent->new;
}
sub wait_on_child {
my $pid = shift;
my $port = shift;
my $start = time;
while (1) {
$msock = IO::Socket::INET->new(PeerAddr => "127.0.0.1:$port");
return $msock if $msock;
select undef, undef, undef, 0.25;
if (waitpid($pid, WNOHANG) > 0) {
die "Child process (webserver) died.\n";
}
die "Timeout waiting for port $port to startup" if time > $start + 5;
}
}
1;

127
wcmtools/perlbal/lib/Perlbal/Test/WebClient.pm Executable file
View File

@@ -0,0 +1,127 @@
#!/usr/bin/perl
package Perlbal::Test::WebClient;
use strict;
use IO::Socket::INET;
use HTTP::Response;
use Socket qw(MSG_NOSIGNAL);
require Exporter;
use vars qw(@ISA @EXPORT $FLAG_NOSIGNAL);
@ISA = qw(Exporter);
@EXPORT = qw(new);
eval { $FLAG_NOSIGNAL = MSG_NOSIGNAL; };
# create a blank object
sub new {
my $class = shift;
my $self = {};
bless $self, $class;
return $self;
}
# get/set what server we should be testing; "ip:port" generally
sub server {
my $self = shift;
if (@_) {
return $self->{server} = shift;
} else {
return $self->{server};
}
}
# set which HTTP version to emulate; specify '1.0' or '1.1'
sub http_version {
my $self = shift;
if (@_) {
return $self->{http_version} = shift;
} else {
return $self->{http_version};
}
}
# set on or off to enable or disable persistent connection
sub keepalive {
my $self = shift;
if (@_) {
$self->{keepalive} = shift() ? 1 : 0;
}
return $self->{keepalive};
}
# construct and send a request
sub request {
my $self = shift;
return undef unless $self->{server};
my $cmds = join(',', map { eurl($_) } @_);
return undef unless $cmds;
# keep-alive header if 1.0, also means add content-length header
my $headers = '';
$headers .= "Connection: keep-alive\r\n"
if $self->{keepalive};
my $send = "GET /$cmds HTTP/$self->{http_version}\r\n$headers\r\n";
my $len = length $send;
# send setup
my $rv;
my $sock = $self->{_sock};
local $SIG{'PIPE'} = "IGNORE" unless $FLAG_NOSIGNAL;
### send it cached
if ($sock) {
$rv = send($sock, $send, $FLAG_NOSIGNAL);
if ($! || ! defined $rv) {
undef $self->{_sock};
} elsif ($rv != $len) {
return undef;
}
}
# failing that, send it through a new socket
unless ($rv) {
$sock = IO::Socket::INET->new(
PeerAddr => $self->{server},
Timeout => 3,
) or return undef;
$rv = send($sock, $send, $FLAG_NOSIGNAL);
if ($! || $rv != $len) {
return undef;
}
$self->{_sock} = $sock
if $self->{keepalive};
}
my $res = '';
while (<$sock>) {
$res .= $_;
last if ! $_ || /^\r?\n/;
}
my $resp = HTTP::Response->parse($res);
return undef unless $resp;
my $cl = $resp->header('Content-Length');
if ($cl > 0) {
my $content = '';
while (($cl -= read($sock, $content, $cl)) > 0) {
# don't do anything, the loop is it
}
$resp->content($content);
}
return $resp;
}
# general purpose URL escaping function
sub eurl {
my $a = $_[0];
$a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
$a =~ tr/ /+/;
return $a;
}
1;

114
wcmtools/perlbal/lib/Perlbal/Test/WebServer.pm Executable file
View File

@@ -0,0 +1,114 @@
#!/usr/bin/perl
package Perlbal::Test::WebServer;
use strict;
use IO::Socket::INET;
use HTTP::Request;
use Perlbal::Test;
require Exporter;
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw(start_webserver);
our @webserver_pids;
END {
# ensure we kill off the webserver
kill 9, @webserver_pids;
}
sub start_webserver {
my $port = new_port();
if (my $child = fork) {
# i am parent, wait for child to startup
push @webserver_pids, $child;
my $sock = wait_on_child($child, $port);
die "Unable to spawn webserver on port $port\n"
unless $sock;
print $sock "GET /status HTTP/1.0\r\n\r\n";
my $line = <$sock>;
die "Didn't get 200 OK: $line"
unless $line =~ /200 OK/;
return $port;
}
# i am child, start up
my $ssock = IO::Socket::INET->new(LocalPort => $port, ReuseAddr => 1, Listen => 3)
or die "Unable to start socket: $!\n";
while (my $csock = $ssock->accept) {
exit 0 unless $csock;
fork and next; # parent starts waiting for next request
my $response = sub {
my ($code, $msg, $content, $ctype) = @_;
$msg ||= { 200 => 'OK', 500 => 'Internal Server Error' }->{$code};
$content ||= "$code $msg";
my $clen = length $content;
$ctype ||= "text/plain";
return "HTTP/1.0 $code $msg\r\n" .
"Content-Type: $ctype\r\n" .
"Content-Length: $clen\r\n" .
"\r\n" .
"$content";
};
my $req = '';
while (<$csock>) {
$req .= $_;
last if ! $_ || /^\r?\n/;
}
# parse out things we want to have
my @cmds;
my $httpver; # 0 = 1.0, 1 = 1.1, undef = neither
if ($req =~ m!^GET /(\S+) HTTP/(1\.\d+)\r?\n?!) {
@cmds = split(/\s*,\s*/, durl($1));
$httpver = ($2 eq '1.0' ? 0 : ($2 eq '1.1' ? 1 : undef));
}
my $msg = HTTP::Request->parse($req);
# 500 if no commands were given or we don't know their HTTP version
# or we didn't parse a proper HTTP request
unless (@cmds && defined $httpver && $msg) {
print $csock $response->(500);
exit 0;
}
# prepare a simple 200 to send; undef this if you want to control
# your own output below
my $to_send = $response->(200);
foreach my $cmd (@cmds) {
$cmd =~ s/^\s+//;
$cmd =~ s/\s+$//;
if ($cmd =~ /^sleep\s+(\d+)$/i) {
sleep $1+0;
}
if ($cmd =~ /^status$/i) {
$to_send = $response->(200, undef, "pid = $$");
}
}
if (defined $to_send) {
print $csock $to_send;
}
exit 0;
}
exit 0;
}
# de-url escape
sub durl {
my ($a) = @_;
$a =~ tr/+/ /;
$a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
return $a;
}
1;

76
wcmtools/perlbal/perlbal Executable file
View File

@@ -0,0 +1,76 @@
#!/usr/bin/perl -w
#
=head1 NAME
Perlbal - Reverse-proxy load balancer and webserver
=head1 DESCRIPTION
For now, see example configuration files in conf/
=head1 AUTHORS
Brad Fitzpatrick, <brad@danga.com>
Mark Smith, <marksmith@danga.com>
=head1 SEE ALSO
http://www.danga.com/perlbal/
=head1 BUGS
Not enough docs.
=head1 LICENSE
Copyright 2004.
You can use and redistribute Perlbal under the same terms as Perl itself.
=cut
use strict;
use warnings;
use lib 'lib';
use Perlbal;
my $opt_daemonize;
my $opt_config;
exit 1 unless
Getopt::Long::GetOptions(
'daemon' => \$opt_daemonize,
'config=s' => \$opt_config,
);
my $default_config = "/etc/perlbal/perlbal.conf";
$opt_config = $default_config if ! $opt_config && -e $default_config;
# load user config
Perlbal::load_config($opt_config, sub {
print STDOUT join("\n", map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_) . "\n";
}) if $opt_config;
if ($Perlbal::AIO_MODE eq "none") {
print STDERR "WARNING: AIO mode disabled or not available. \n".
" Perlbal will run slowly under load if you're doing any\n".
" disk operations. (e.g. web_server mode).\n";
}
unless (Perlbal::Socket->WatchedSockets() > 0) {
die "No services or management port configured. Nothing to do. Stopping.\n";
}
if ($opt_daemonize) {
Perlbal::daemonize();
} else {
print "Running.\n";
}
Perlbal::run();
# Local Variables:
# mode: perl
# c-basic-indent: 4
# indent-tabs-mode: nil
# End:

8
wcmtools/perlbal/t/00-use.t Executable file
View File

@@ -0,0 +1,8 @@
#!/usr/bin/perl -w
use strict;
use Test::More tests => 1;
use Perlbal;
ok(1);

10
wcmtools/perlbal/t/10-testharness.t Executable file
View File

@@ -0,0 +1,10 @@
#!/usr/bin/perl
use strict;
use Perlbal::Test;
use Test::More 'no_plan';
my $msock = start_server("");
ok($msock);
1;

38
wcmtools/perlbal/t/12-headers.t Executable file
View File

@@ -0,0 +1,38 @@
#!/usr/bin/perl
use strict;
use Perlbal::Test;
use Test::More 'no_plan';
use Perlbal;
use Perlbal::HTTPHeaders;
eval "use Perlbal::XS::HTTPHeaders;";
# classes we will be testing
my @classes = ('Perlbal::HTTPHeaders');
push @classes, $Perlbal::XSModules{headers}
if $Perlbal::XSModules{headers};
# verify they work
foreach my $class (@classes) {
# basic request, just tests to see if the class is functioning
my $req = \"GET / HTTP/1.0\r\n\r\n";
my $c_req = $class->new($req);
ok($c_req, "basic request - $class");
# basic response, same
my $resp = \"HTTP/1.0 200 OK\r\n\r\n";
my $c_resp = $class->new($resp, 1);
ok($c_resp, "basic response - $class");
# test for a bug in the XS headers that caused headers with no content
# to be disconnected from the server
my $hdr = \"GET / HTTP/1.0\r\nHeader: content\r\nAnother: \r\nSomething:\r\n\r\n";
my $obj = $class->new($hdr);
ok($obj, "headers without content 1 - $class");
is($obj->header('header'), 'content', "headers without content 2 - $class");
is($obj->header('anoTHER'), '', "headers without content 3 - $class");
is($obj->header('notthere'), undef, "headers without content 4 - $class");
}
1;

76
wcmtools/perlbal/t/15-webserver.t Executable file
View File

@@ -0,0 +1,76 @@
#!/usr/bin/perl
use strict;
use Perlbal::Test;
use Test::More 'no_plan';
require HTTP::Request;
my $port = new_port();
my $dir = tempdir();
my $conf = qq{
SERVER aio_mode = none
CREATE SERVICE test
SET test.role = web_server
SET test.listen = 127.0.0.1:$port
SET test.docroot = $dir
SET test.dirindexing = 0
SET test.persist_client = 1
ENABLE test
};
my $msock = start_server($conf);
ok($msock, "manage sock");
my $ua = ua();
ok($ua, "ua");
my ($url, $disk_file, $contents);
sub set_path {
my $path = shift;
$url = "http://127.0.0.1:$port$path";
$disk_file = "$dir$path";
}
sub set_contents {
$contents = shift;
}
sub write_file {
open(F, ">$disk_file") or die "Couldn't open $disk_file: $!\n";
print F $contents;
close F;
}
sub get {
my $url = shift;
my $req = HTTP::Request->new(GET => $url);
my $res = $ua->request($req);
return $res->is_success ? $res->content : undef;
}
# write a file to disk
mkdir "$dir/foo";
set_path("/foo/bar.txt");
set_contents("foo bar baz\n" x 1000);
write_file();
ok(filecontent($disk_file) eq $contents, "disk file verify");
# a simple get
ok(get($url) eq $contents, "GET request");
# 404 path
ok(! get("$url/404.txt"), "missing file");
# verify directory indexing is off
{
my $dirurl = $url;
$dirurl =~ s!/[^/]+?$!/!;
my $diridx = get($dirurl);
like($diridx, qr/Directory listing disabled/, "no dirlist");
manage("SET test.dirindexing = 1");
$diridx = get($dirurl);
like($diridx, qr/bar\.txt/, "see dirlist");
}
1;

108
wcmtools/perlbal/t/20-put.t Executable file
View File

@@ -0,0 +1,108 @@
#!/usr/bin/perl
use strict;
use Perlbal::Test;
use Test::More 'no_plan';
my $port = new_port();
my $dir = tempdir();
my $conf = qq{
SERVER aio_mode = none
CREATE SERVICE test
SET test.role = web_server
SET test.listen = 127.0.0.1:$port
SET test.docroot = $dir
SET test.dirindexing = 0
SET test.enable_put = 1
SET test.enable_delete = 1
SET test.min_put_directory = 0
SET test.persist_client = 1
ENABLE test
};
my $msock = start_server($conf);
my $ua = ua();
ok($ua);
require HTTP::Request;
my $url = "http://127.0.0.1:$port/foo.txt";
my $disk_file = "$dir/foo.txt";
my $content;
sub put_file {
my $req = HTTP::Request->new(PUT => $url);
$content = "foo bar baz\n" x 1000;
$req->content($content);
my $res = $ua->request($req);
return $res->is_success;
}
sub delete_file {
my $req = HTTP::Request->new(DELETE => $url);
my $res = $ua->request($req);
return $res->is_success;
}
sub verify_put {
ok(filecontent($disk_file) eq $content, "verified put");
}
# successful puts
foreach_aio {
my $aio = shift;
ok(put_file(), "$aio: good put");
verify_put();
unlink $disk_file;
};
# good delete
put_file();
ok( -f $disk_file, "file exists");
ok(delete_file(), "delete file");
ok(! -f $disk_file, "file gone");
ok(! delete_file(), "deleting non-existent file");
# min_put_directory
ok(manage("SET test.min_put_directory = 2"));
foreach_aio {
my $mode = shift;
my $dir1 = "mode-$mode";
my $path = "$dir1/dir2/foo.txt";
$url = "http://127.0.0.1:$port/$path";
$disk_file = "$dir/$path";
ok(! put_file(), "aio $mode: bad put");
ok(mkdir("$dir/$dir1"), "mkdir dir1");
ok(mkdir("$dir/$dir1/dir2"), "mkdir dir1/dir2");
ok(put_file(), "aio $mode: good put at dir1/dir2/foo.txt");
verify_put();
ok(unlink($disk_file), "rm file");
ok(rmdir("$dir/$dir1/dir2"), "rm dir2");
ok(rmdir("$dir/$dir1"), "rm dir1");
};
ok(manage("SET test.min_put_directory = 0"));
# let Perlbal autocreate a dir tree
{
my $path = "a/b/c/d/foo.txt";
$url = "http://127.0.0.1:$port/$path";
$disk_file = "$dir/$path";
ok(put_file(), "made deep file");
ok(-f $disk_file, "deep file exists");
}
# permissions
ok(put_file());
ok(manage("SET test.enable_put = 0"));
ok(! put_file(), "put disabled");
ok(manage("SET test.enable_delete = 0"));
ok(! delete_file(), "delete disabled");
1;

51
wcmtools/perlbal/t/30-reverseproxy.t Executable file
View File

@@ -0,0 +1,51 @@
#!/usr/bin/perl
use strict;
use Perlbal::Test;
use Perlbal::Test::WebServer;
use Perlbal::Test::WebClient;
use Test::More 'no_plan';
# option setup
my $start_servers = 3; # web servers to start
# setup a few web servers that we can work with
my @web_ports = map { start_webserver() } 1..$start_servers;
@web_ports = grep { $_ > 0 } map { $_ += 0 } @web_ports;
ok(scalar(@web_ports) == $start_servers, 'web servers started');
# setup a simple perlbal that uses the above server
my $pb_port = new_port();
my $conf = qq{
CREATE POOL a
CREATE SERVICE test
SET test.role = reverse_proxy
SET test.listen = 127.0.0.1:$pb_port
SET test.persist_client = 1
SET test.persist_backend = 1
SET test.pool = a
ENABLE test
};
$conf .= "POOL a ADD 127.0.0.1:$_\n"
foreach @web_ports;
my $msock = start_server($conf);
ok($msock, 'perlbal started');
my $wc = new Perlbal::Test::WebClient;
$wc->server("127.0.0.1:$pb_port");
$wc->keepalive(0);
$wc->http_version('1.0');
ok($wc, 'web client object created');
my $resp = $wc->request('status');
ok($resp, 'status response ok');
my $content = $resp ? $resp->content : '';
my $pid = $content =~ /^pid = (\d+)$/ ? $1 : 0;
ok($pid > 0, 'web server functioning');
1;

34
wcmtools/perlbal/test/helper-server.pl Executable file
View File

@@ -0,0 +1,34 @@
#!/usr/bin/perl
#
use strict;
use IO::Socket::INET;
my $sock = IO::Socket::INET->new(Listen => 5,
LocalAddr => 'localhost',
LocalPort => 8012,
Reuse => 1,
Proto => 'tcp');
while (my $child = $sock->accept) {
my $reqline = <$child>;
next unless $reqline =~ /^(\S+)\s+(\S+)\s+HTTP\/(\d+\.\d+)\r?\n/;
my ($meth, $uri, $ver) = ($1, $2, $3);
my %header;
my $line;
while (($line = <$child>) =~ /\S/) {
$line =~ s/\r?\n$//;
print "Got line: $line";
next unless $line =~ /^(\w+):\s*(.+)/;
$header{$1} = $2;
print "1 = $1, 2 = $2\n";
}
my %args;
foreach (split(m!/!, $uri)) {
my ($k, $v) = split /=/;
$args{$k} = $v if $k;
}
print "Args: " . join(", ", %args) . "\n";
}