Context Navigation

Service.pm

Revision 824, 61.4 kB (checked in by hachi, 2 months ago)

Rudimentary dumpconfig command, 90% working.

This reverts commit c5dc669c6250b46f82a6cc4da38f45be7f45c296.

(Yes, that would be a double-revert that I am doing.)

Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

Line
1	######################################################################
2	# Service class
3	######################################################################
4	#
5	# Copyright 2004, Danga Interactive, Inc.
6	# Copyright 2005-2007, Six Apart, Ltd.
7	#
8
9	package Perlbal::Service;
10	use strict;
11	use warnings;
12	no warnings qw(deprecated);
13
14	use Perlbal::BackendHTTP;
15	use Perlbal::Cache;
16	use Perlbal::Util;
17
18	use fields (
19	'name', # scalar: name of this service
20	'role', # scalar: role type 'web_server', 'reverse_proxy', etc...
21	'enabled', # scalar: bool, whether we're enabled or not (enabled = listening)
22
23	'pool', # Perlbal::Pool that we're using to allocate nodes if we're in proxy mode
24	'listener', # Perlbal::TCPListener object, when enabled
25	'reproxy_cache', # Perlbal::Cache object, when enabled
26
27	# end-user tunables
28	'listen', # scalar IP:port of where we're listening for new connections
29	'docroot', # document root for webserver role
30	'dirindexing', # bool: directory indexing? (for webserver role) not async.
31	'index_files', # arrayref of filenames to try for index files
32	'enable_concatenate_get', # bool: if user can request concatenated files
33	'enable_put', # bool: whether PUT is supported
34	'max_put_size', # int: max size in bytes of a put file
35	'max_chunked_request_size', # int: max size in bytes of a chunked request (to be written to disk first)
36	'min_put_directory', # int: number of directories required to exist at beginning of URIs in put
37	'enable_delete', # bool: whether DELETE is supported
38	'high_priority_cookie', # cookie name to check if client can 'cut in line' and get backends faster
39	'high_priority_cookie_contents', # aforementioned cookie value must contain this substring
40	'backend_persist_cache', # scalar: max number of persistent backends to hold onto while no clients
41	'persist_client', # bool: persistent connections for clients
42	'persist_backend', # bool: persistent connections for backends
43	'verify_backend', # bool: get attention of backend before giving it clients (using OPTIONS)
44	'verify_backend_path', # path to check with the OPTIONS request (default *)
45	'max_backend_uses', # max requests to send per kept-alive backend (default 0 = unlimited)
46	'connect_ahead', # scalar: number of spare backends to connect to in advance all the time
47	'buffer_size', # int: specifies how much data a ClientProxy object should buffer from a backend
48	'buffer_size_reproxy_url', # int: same as above but for backends that are reproxying for us
49	'queue_relief_size', # int; number of outstanding standard priority
50	# connections to activate pressure relief at
51	'queue_relief_chance', # int:0-100; % chance to take a standard priority
52	# request when we're in pressure relief mode
53	'trusted_upstream_proxies', # Net::Netmask object containing netmasks for trusted upstreams
54	'always_trusted', # bool; if true, always trust upstreams
55	'blind_proxy', # bool: if true, do not modify X-Forwarded-For, X-Host, or X-Forwarded-Host headers
56	'enable_reproxy', # bool; if true, advertise that server will reproxy files and/or URLs
57	'reproxy_cache_maxsize', # int; maximum number of reproxy results to be cached. (0 is disabled and default)
58	'client_sndbuf_size', # int: bytes for SO_SNDBUF
59	'server_process' , # scalar: path to server process (executable)
60	'persist_client_timeout', # int: keep-alive timeout in seconds for clients (default is 30)
61
62	# Internal state:
63	'waiting_clients', # arrayref of clients waiting for backendhttp conns
64	'waiting_clients_highpri', # arrayref of high-priority clients waiting for backendhttp conns
65	'waiting_clients_lowpri', # arrayref of low-priority clients waiting for backendhttp conns
66	'waiting_client_count', # number of clients waiting for backends
67	'waiting_client_map' , # map of clientproxy fd -> 1 (if they're waiting for a conn)
68	'pending_connects', # hashref of "ip:port" -> $time (only one pending connect to backend at a time)
69	'pending_connect_count', # number of outstanding backend connects
70	'bored_backends', # arrayref of backends we've already connected to, but haven't got clients
71	'hooks', # hashref: hookname => [ [ plugin, ref ], [ plugin, ref ], ... ]
72	'plugins', # hashref: name => 1
73	'plugin_order', # arrayref: name, name, name...
74	'plugin_setters', # hashref: { plugin_name => { key_name => coderef } }
75	'extra_config', # hashref: extra config options; name => values
76	'spawn_lock', # bool: if true, we're currently in spawn_backends
77	'extra_headers', # { insert => [ [ header, value ], ... ], remove => [ header, header, ... ],
78	# set => [ [ header, value ], ... ] }; used in header management interface
79	'generation', # int; generation count so we can slough off backends from old pools
80	'backend_no_spawn', # { "ip:port" => 1 }; if on, spawn_backends will ignore this ip:port combo
81	'buffer_backend_connect', # 0 for of, else, number of bytes to buffer before we ask for a backend
82	'selector', # CODE ref, or undef, for role 'selector' services
83	'default_service', # Perlbal::Service; name of a service a selector should default to
84	'buffer_uploads', # bool; enable/disable the buffered uploads to disk system
85	'buffer_uploads_path', # string; path to store buffered upload files
86	'buffer_upload_threshold_time', # int; buffer uploads estimated to take longer than this
87	'buffer_upload_threshold_size', # int; buffer uploads greater than this size (in bytes)
88	'buffer_upload_threshold_rate', # int; buffer uploads uploading at less than this rate (in bytes/sec)
89
90	'upload_status_listeners', # string: comma separated list of ip:port of UDP upload status receivers
91	'upload_status_listeners_sockaddr', # arrayref of sockaddrs (packed ip/port)
92
93	'enable_ssl', # bool: whether this service speaks SSL to the client
94	'ssl_key_file', # file: path to key pem file
95	'ssl_cert_file', # file: path to key pem file
96	'ssl_cipher_list', # OpenSSL cipher list string
97
98	'enable_error_retries', # bool: whether we should retry requests after errors
99	'error_retry_schedule', # string of comma-separated seconds (full or partial) to delay between retries
100	'latency', # int: milliseconds of latency to add to request
101
102	# stats:
103	'_stat_requests', # total requests to this service
104	'_stat_cache_hits', # total requests to this service that were served via the reproxy-url cache
105	);
106
107	# hash; 'role' => coderef to instantiate a client for this role
108	our %PluginRoles;
109
110	our $tunables = {
111
112	'role' => {
113	des => "What type of service. One of 'reverse_proxy' for a service that load balances to a pool of backend webserver nodes, 'web_server' for a typical webserver', 'management' for a Perlbal management interface (speaks both command-line or HTTP, auto-detected), or 'selector', for a virtual service that maps onto other services.",
114	required => 1,
115
116	check_type => sub {
117	my ($self, $val, $errref) = @_;
118	return 0 unless $val;
119	return 1 if $val =~ /^(?:reverse_proxy\|web_server\|management\|selector\|upload_tracker)$/;
120	return 1 if $PluginRoles{$val};
121	$$errref = "Role not valid for service $self->{name}";
122	return 0;
123	},
124	check_role => '*',
125	setter => sub {
126	my ($self, $val, $set, $mc) = @_;
127	my $rv = $set->();
128	$self->init; # now that service role is set
129	return $rv;
130	},
131	},
132
133	'listen' => {
134	check_role => "*",
135	des => "The ip:port to listen on. For a service to work, you must either make it listen, or make another selector service map to a non-listening service.",
136	check_type => ["regexp", qr/^(\d+\.\d+\.\d+\.\d+:)?\d+$/,
137	"Listen argument must be ip:port or port. " .
138	"e.g. 192.168.0.1:80 or 81"],
139	setter => sub {
140	my ($self, $val, $set, $mc) = @_;
141
142	# close/reopen listening socket
143	if ($val ne ($self->{listen} \|\| "") && $self->{enabled}) {
144	$self->disable(undef, "force");
145	$self->{listen} = $val;
146	$self->enable(undef);
147	}
148
149	return $set->();
150	},
151	},
152
153	'backend_persist_cache' => {
154	des => "The number of backend connections to keep alive on reserve while there are no clients.",
155	check_type => "int",
156	default => 2,
157	check_role => "reverse_proxy",
158	},
159
160	'persist_client' => {
161	des => "Whether to enable HTTP keep-alives to the end user.",
162	default => 0,
163	check_type => "bool",
164	check_role => "*",
165	},
166
167	'persist_backend' => {
168	des => "Whether to enable HTTP keep-alives to the backend webnodes. (Off by default, but highly recommended if Perlbal will be the only client to your backends. If not, beware that Perlbal will hog the connections, starving other clients.)",
169	default => 0,
170	check_type => "bool",
171	check_role => "reverse_proxy",
172	},
173
174	'verify_backend' => {
175	des => "Whether Perlbal should send a quick OPTIONS request to the backends before sending an actual client request to them. If your backend is Apache or some other process-based webserver, this is HIGHLY recommended. All too often a loaded backend box will reply to new TCP connections, but it's the kernel's TCP stack Perlbal is talking to, not an actual Apache process yet. Using this option reduces end-user latency a ton on loaded sites.",
176	default => 0,
177	check_type => "bool",
178	check_role => "reverse_proxy",
179	},
180
181	'verify_backend_path' => {
182	des => "What path the OPTIONS request sent by verify_backend should use. Default is '*'.",
183	default => '*',
184	check_role => "reverse_proxy",
185	},
186
187	'max_backend_uses' => {
188	check_role => "reverse_proxy",
189	des => "The max number of requests to be made on a single persistent backend connection before releasing the connection. The default value of 0 means no limit, and the connection will only be discarded once the backend asks it to be, or when Perlbal is sufficiently idle.",
190	default => 0,
191	},
192
193	'max_put_size' => {
194	default => 0, # no limit
195	des => "The maximum content-length that will be accepted for a PUT request, if enable_put is on. Default value of 0 means no limit.",
196	check_type => "size",
197	check_role => "web_server",
198	},
199
200	'max_chunked_request_size' => {
201	default => 209715200, # 200 MB. (0: no limit)
202	des => "The maximum size that will be accepted for a chunked request. Default is 200MB (which is written to disk, buffered uploads must be on). A value of 0 means no limit.",
203	check_type => "size",
204	check_role => "*",
205	},
206
207	'buffer_size' => {
208	des => "How much we'll ahead of a client we'll get while copying from a backend to a client. If a client gets behind this much, we stop reading from the backend for a bit.",
209	default => "256k",
210	check_type => "size",
211	check_role => "reverse_proxy",
212	},
213
214	'buffer_size_reproxy_url' => {
215	des => "How much we'll get ahead of a client we'll get while copying from a reproxied URL to a client. If a client gets behind this much, we stop reading from the reproxied URL for a bit. The default is lower than the regular buffer_size (50k instead of 256k) because it's assumed that you're only reproxying to large files on event-based webservers, which are less sensitive to many open connections, whereas the 256k buffer size is good for keeping heavy process-based free of slow clients.",
216	default => "50k",
217	check_type => "size",
218	check_role => "reverse_proxy",
219	},
220
221	'queue_relief_size' => {
222	default => 0,
223	check_type => "int",
224	check_role => "reverse_proxy",
225	},
226
227	'queue_relief_chance' => {
228	default => 0,
229	check_type => sub {
230	my ($self, $val, $errref) = @_;
231	return 1 if $val =~ /^\d+$/ && $val >= 0 && $val <= 100;
232	$$errref = "Expecting integer value between 0 and 100, inclusive.";
233	return 0;
234	},
235	check_role => "reverse_proxy",
236	},
237
238	'buffer_backend_connect' => {
239	des => "How much content-body (POST/PUT/etc) data we read from a client before we start sending it to a backend web node. If 'buffer_uploads' is enabled, this value is used to determine how many bytes are read before Perlbal makes a determination on whether or not to spool the upload to disk.",
240	default => '100k',
241	check_type => "size",
242	check_role => "reverse_proxy",
243	},
244
245	'docroot' => {
246	des => "Directory root for web server.",
247
248	check_role => "web_server",
249	val_modify => sub { my $valref = shift; $$valref =~ s!/$!!; },
250	check_type => sub {
251	my ($self, $val, $errref) = @_;
252	#FIXME: require absolute paths?
253	return 1 if $val && -d $val;
254	$$errref = "Directory not found for service $self->{name}";
255	return 0;
256	},
257	},
258
259	'enable_put' => {
260	des => "Enable HTTP PUT requests.",
261	default => 0,
262	check_role => "web_server",
263	check_type => "bool",
264	},
265
266	'enable_delete' => {
267	des => "Enable HTTP DELETE requests.",
268	default => 0,
269	check_role => "web_server",
270	check_type => "bool",
271	},
272
273	'enable_reproxy' => {
274	des => "Enable 'reproxying' (end-user-transparent internal redirects) to either local files or other URLs. When enabled, the backend servers in the pool that this service is configured for will have access to tell this Perlbal instance to serve any local readable file, or connect to any other URL that this Perlbal can connect to. Only enable this if you trust the backend web nodes.",
275	default => 0,
276	check_role => "reverse_proxy",
277	check_type => "bool",
278	},
279
280	'reproxy_cache_maxsize' => {
281	des => "Set the maximum number of cached reproxy results (X-REPROXY-CACHE-FOR) that may be kept in the service cache. These cached requests take up about 1.25KB of ram each (on Linux x86), but will vary with usage. Perlbal still starts with 0 in the cache and will grow over time. Be careful when adjusting this and watch your ram usage like a hawk.",
282	default => 0,
283	check_role => "reverse_proxy",
284	check_type => "int",
285	setter => sub {
286	my ($self, $val, $set, $mc) = @_;
287	if ($val) {
288	$self->{reproxy_cache} \|\|= Perlbal::Cache->new(maxsize => 1);
289	$self->{reproxy_cache}->set_maxsize($val);
290	} else {
291	$self->{reproxy_cache} = undef;
292	}
293	return $mc->ok;
294	},
295	},
296
297	'upload_status_listeners' => {
298	des => "Comma separated list of hosts in form 'a.b.c.d:port' which will receive UDP upload status packets no faster than once a second per HTTP request (PUT/POST) from clients that have requested an upload status bar, which they request by appending the URL get argument ?client_up_session=[xxxxxx] where xxxxx is 5-50 'word' characters (a-z, A-Z, 0-9, underscore).",
299	default => "",
300	check_role => "reverse_proxy",
301	check_type => sub {
302	my ($self, $val, $errref) = @_;
303	my @packed;
304	foreach my $ipa (grep { $_ } split(/\s,\s/, $val)) {
305	unless ($ipa =~ /^(\d+\.\d+\.\d+\.\d+):(\d+)$/) {
306	$$errref = "Invalid UDP endpoint: \"$ipa\". Must be of form a.b.c.d:port";
307	return 0;
308	}
309	push @packed, scalar Socket::sockaddr_in($2, Socket::inet_aton($1));
310	}
311	$self->{upload_status_listeners_sockaddr} = \@packed;
312	return 1;
313	},
314	},
315
316	'min_put_directory' => {
317	des => "If PUT requests are enabled, require this many levels of directories to already exist. If not, fail.",
318	default => 0, # no limit
319	check_role => "web_server",
320	check_type => "int",
321	},
322
323	'dirindexing' => {
324	des => "Show directory indexes when an HTTP request is for a directory. Warning: this is not an async operation, so will slow down Perlbal on heavily loaded sites.",
325	default => 0,
326	check_role => "web_server",
327	check_type => "bool",
328	},
329
330	'enable_concatenate_get' => {
331	des => "Enable Perlbal's multiple-files-in-one-request mode, where a client have use a comma-separated list of files to return, always in text/plain. Useful for web apps which have dozens/hundreds of tiny css/js files, and don't trust browsers/etc to do pipelining. Decreases overall round-trip latency a bunch, but requires app to be modified to support it. See t/17-concat.t test for details.",
332	default => 0,
333	check_role => "web_server",
334	check_type => "bool",
335	},
336
337	'connect_ahead' => {
338	des => "How many extra backend connections we keep alive in addition to the current ones, in anticipation of new client connections.",
339	default => 0,
340	check_type => "int",
341	check_role => "reverse_proxy",
342	setter => sub {
343	my ($self, $val, $set, $mc) = @_;
344	my $rv = $set->();
345	$self->spawn_backends if $self->{enabled};
346	return $rv;
347	},
348	},
349
350	'always_trusted' => {
351	des => "Whether to trust all incoming requests' X-Forwarded-For and related headers. Set to true only if you know that all incoming requests from your own proxy servers that clean/set those headers.",
352	default => 0,
353	check_type => "bool",
354	check_role => "*",
355	},
356
357	'blind_proxy' => {
358	des => "Flag to disable any modification of X-Forwarded-For, X-Host, and X-Forwarded-Host headers.",
359	default => 0,
360	check_type => "bool",
361	check_role => "reverse_proxy",
362	},
363
364	'high_priority_cookie' => {
365	des => "The cookie name to inspect to determine if the client goes onto the high-priority queue.",
366	check_role => "reverse_proxy",
367	},
368
369	'high_priority_cookie_contents' => {
370	des => "A string that the high_priority_cookie must contain to go onto the high-priority queue.",
371	check_role => "reverse_proxy",
372	},
373
374	'trusted_upstream_proxies' => {
375	des => "A Net::Netmask filter (e.g. 10.0.0.0/24, see Net::Netmask) that determines whether upstream clients are trusted or not, where trusted means their X-Forwarded-For/etc headers are not munged.",
376	check_role => "*",
377	check_type => sub {
378	my ($self, $val, $errref) = @_;
379	unless (my $loaded = eval { require Net::Netmask; 1; }) {
380	$$errref = "Net::Netmask not installed";
381	return 0;
382	}
383
384	return 1 if $self->{trusted_upstream_proxies} = Net::Netmask->new2($val);
385	$$errref = "Error defining trusted upstream proxies: " . Net::Netmask::errstr();
386	return 0;
387	},
388	setter => sub {
389	my ($self, $val, $set, $mc) = @_;
390	# Do nothing here, we don't want the default setter because we've
391	# already set the value in the type_check step.
392	return $mc->ok;
393	},
394	},
395
396	'index_files' => {
397	check_role => "web_server",
398	default => "index.html",
399	des => "Comma-separated list of filenames to load when a user visits a directory URL, listed in order of preference.",
400	setter => sub {
401	my ($self, $val, $set, $mc) = @_;
402	$self->{index_files} = [ split(/[\s,]+/, $val) ];
403	return $mc->ok;
404	},
405	dumper => sub {
406	my ($self, $val) = @_;
407	return join(', ', @$val);
408	},
409	},
410
411	'default_service' => {
412	des => "Name of previously-created service to default requests that aren't matched by a selector plugin to.",
413	check_role => "selector",
414	check_type => sub {
415	my ($self, $val, $errref) = @_;
416
417	my $svc = Perlbal->service($val);
418	unless ($svc) {
419	$$errref = "Service '$svc' not found";
420	return 0;
421	}
422
423	$self->{default_service} = $svc;
424	return 1;
425	},
426	setter => sub {
427	# override default so we don't set it to the text
428	return $_[3]->ok;
429	},
430	},
431
432	'pool' => {
433	des => "Name of previously-created pool object containing the backend nodes that this reverse proxy sends requests to.",
434	check_role => "reverse_proxy",
435	check_type => sub {
436	my ($self, $val, $errref) = @_;
437	my $pl = Perlbal->pool($val);
438	unless ($pl) {
439	$$errref = "Pool '$val' not found";
440	return 0;
441	}
442	$self->{pool}->decrement_use_count if $self->{pool};
443	$self->{pool} = $pl;
444	$self->{pool}->increment_use_count;
445	$self->{generation}++;
446	return 1;
447	},
448	setter => sub {
449	my ($self, $val, $set, $mc) = @_;
450	# override the default, which is to set "pool" to the
451	# stringified name of the pool, but we already set it in
452	# the type-checking phase. instead, we do nothing here.
453	return $mc->ok;
454	},
455	dumper => sub {
456	my ($self, $val) = @_;
457	return $val->name;
458	}
459	},
460
461	'server_process' => {
462	des => "Executable which will be the HTTP server on stdin/stdout. (ALPHA, EXPERIMENTAL!)",
463	check_role => "reverse_proxy",
464	check_type => sub {
465	my ($self, $val, $errref) = @_;
466	#FIXME: require absolute paths?
467	return 1 if $val && -x $val;
468	$$errref = "Server process ($val) not executable.";
469	return 0;
470	},
471	},
472
473	'persist_client_timeout' => {
474	des => "Timeout in seconds for HTTP keep-alives to the end user (default is 30)",
475	check_type => "int",
476	default => 30,
477	check_role => "*",
478	},
479
480	'buffer_uploads_path' => {
481	des => "Directory root for storing files used to buffer uploads.",
482
483	check_role => "reverse_proxy",
484	val_modify => sub { my $valref = shift; $$valref =~ s!/$!!; },
485	check_type => sub {
486	my ($self, $val, $errref) = @_;
487	#FIXME: require absolute paths?
488	return 1 if $val && -d $val;
489	$$errref = "Directory ($val) not found for service $self->{name} (buffer_uploads_path)";
490	return 0;
491	},
492	},
493
494	'buffer_uploads' => {
495	des => "Used to enable or disable the buffer uploads to disk system. If enabled, 'buffer_backend_connect' bytes worth of the upload will be stored in memory. At that point, the buffer upload thresholds will be checked to see if we should just send this upload to the backend, or if we should spool it to disk.",
496	default => 0,
497	check_role => "reverse_proxy",
498	check_type => "bool",
499	},
500
501	'buffer_upload_threshold_time' => {
502	des => "If an upload is estimated to take more than this number of seconds, it will be buffered to disk. Set to 0 to not check estimated time.",
503	default => 5,
504	check_role => "reverse_proxy",
505	check_type => "int",
506	},
507
508	'buffer_upload_threshold_size' => {
509	des => "If an upload is larger than this size in bytes, it will be buffered to disk. Set to 0 to not check size.",
510	default => '250k',
511	check_role => "reverse_proxy",
512	check_type => "size",
513	},
514
515	'buffer_upload_threshold_rate' => {
516	des => "If an upload is coming in at a rate less than this value in bytes per second, it will be buffered to disk. Set to 0 to not check rate.",
517	default => 0,
518	check_role => "reverse_proxy",
519	check_type => "int",
520	},
521
522	'latency' => {
523	des => "Forced latency (in milliseconds) to add to request.",
524	default => 0,
525	check_role => "selector",
526	check_type => "int",
527	},
528
529	'enable_ssl' => {
530	des => "Enable SSL to the client.",
531	default => 0,
532	check_type => "bool",
533	check_role => "*",
534	},
535
536	'ssl_key_file' => {
537	des => "Path to private key PEM file for SSL.",
538	default => "certs/server-key.pem",
539	check_type => "file_or_none",
540	check_role => "*",
541	},
542
543	'ssl_cert_file' => {
544	des => "Path to certificate PEM file for SSL.",
545	default => "certs/server-cert.pem",
546	check_type => "file_or_none",
547	check_role => "*",
548	},
549
550	'ssl_cipher_list' => {
551	des => "OpenSSL-style cipher list.",
552	default => "ALL:!LOW:!EXP",
553	check_role => "*",
554	},
555
556	'enable_error_retries' => {
557	des => 'Whether Perlbal should transparently retry requests to backends if a backend returns a 500 server error.',
558	default => 0,
559	check_type => "bool",
560	check_role => "reverse_proxy",
561	},
562
563	'error_retry_schedule' => {
564	des => 'String of comma-separated seconds (full or partial) to delay between retries. For example "0,2" would mean do at most two retries, the first zero seconds after the first failure, and the second 2 seconds after the 2nd failure. You probably don\'t need to modify the default value',
565	default => '0,.25,.50,1,1,1,1,1',
566	check_role => "reverse_proxy",
567	},
568
569	'client_sndbuf_size' => {
570	des => "How large to set the client's socket SNDBUF.",
571	default => 0,
572	check_type => "size",
573	check_role => '*',
574	},
575
576
577	};
578	sub autodoc_get_tunables { return $tunables; }
579
580	sub new {
581	my Perlbal::Service $self = shift;
582	$self = fields::new($self) unless ref $self;
583
584	my ($name) = @_;
585
586	$self->{name} = $name;
587	$self->{enabled} = 0;
588	$self->{extra_config} = {};
589
590	$self->{backend_no_spawn} = {};
591	$self->{generation} = 0;
592
593	$self->{hooks} = {};
594	$self->{plugins} = {};
595	$self->{plugin_order} = [];
596
597	# track pending connects to backend
598	$self->{pending_connects} = {};
599	$self->{pending_connect_count} = 0;
600	$self->{bored_backends} = [];
601
602	# waiting clients
603	$self->{waiting_clients} = [];
604	$self->{waiting_clients_highpri} = [];
605	$self->{waiting_clients_lowpri} = [];
606	$self->{waiting_client_count} = 0;
607	$self->{waiting_client_map} = {};
608
609	# buffered upload setup
610	$self->{buffer_uploads_path} = undef;
611
612	# don't have an object for this yet
613	$self->{trusted_upstream_proxies} = undef;
614
615	# bare data structure for extra header info
616	$self->{extra_headers} = { remove => [], insert => [] };
617
618	# things to watch...
619	foreach my $v (qw(pending_connects bored_backends waiting_clients
620	waiting_clients_highpri backend_no_spawn
621	waiting_client_map
622	)) {
623	die "Field '$v' not set" unless $self->{$v};
624	Perlbal::track_var("svc-$name-$v", $self->{$v});
625	}
626
627	return $self;
628	}
629
630	# handy instance method to run some manage commands in the context of this service,
631	# without needing to worry about its name.
632	# This is intended as an internal API thing, so any output that would have been
633	# generated is just eaten.
634	sub run_manage_commands {
635	my ($self, $cmd_block) = @_;
636
637	my $ctx = Perlbal::CommandContext->new;
638	$ctx->{last_created} = $self->name;
639	return Perlbal::run_manage_commands($cmd_block, undef, $ctx);
640	}
641
642	# here's an alternative version of the above that runs a single command
643	sub run_manage_command {
644	my ($self, $cmd) = @_;
645
646	my $ctx = Perlbal::CommandContext->new;
647	$ctx->{last_created} = $self->name;
648	return Perlbal::run_manage_command($cmd, undef, $ctx);
649	}
650
651	sub dumpconfig {
652	my $self = shift;
653
654	my @return;
655
656	my %my_tunables = %$tunables;
657
658	my $dump = sub {
659	my $setting = shift;
660	};
661
662	foreach my $skip (qw(role listen pool)) {
663	delete $my_tunables{$skip};
664	}
665
666	my $role = $self->{role};
667
668	foreach my $setting ("role", "listen", "pool", sort keys %my_tunables) {
669	my $attrs = $tunables->{$setting};
670	my $value = $self->{$setting};
671
672	my $check_role = $attrs->{check_role};
673	my $check_type = $attrs->{check_type};
674	my $default = $attrs->{default};
675	my $required = $attrs->{required};
676
677	next if ($check_role && $check_role ne '*' && $check_role ne $role);
678
679	if ($check_type && $check_type eq 'size') {
680	$default = $1 if $default =~ /^(\d+)b$/i;
681	$default = $1 * 1024 if $default =~ /^(\d+)k$/i;
682	$default = $1 * 1024 * 1024 if $default =~ /^(\d+)m$/i;
683	}
684
685	if (!$required) {
686	next unless defined $value;
687	next if (defined $default && $value eq $default);
688	}
689
690	if (my $dumper = $attrs->{dumper}) {
691	$value = $dumper->($self, $value);
692	}
693
694	if ($check_type && $check_type eq 'bool') {
695	$value = 'on' if $value;
696	}
697
698	push @return, "SET $setting = $value";
699	}
700
701	my $plugins = $self->{plugins};
702
703	foreach my $plugin (keys %$plugins) {
704	local $@;
705
706	my $class = "Perlbal::Plugin::$plugin";
707	my $cv = $class->can('dumpconfig');
708
709	if ($cv) {
710	eval { push @return, $class->dumpconfig($self) };
711	if ($@) {
712	push @return, "# Plugin '$plugin' threw an exception while being dumped.";
713	}
714	} else {
715	push @return, "# Plugin '$plugin' isn't capable of dumping config.";
716	}
717	}
718
719	return @return;
720	}
721
722	# called once a role has been set
723	sub init {
724	my Perlbal::Service $self = shift;
725	die "init called when no role" unless $self->{role};
726
727	# set all the defaults
728	for my $param (keys %$tunables) {
729	my $tun = $tunables->{$param};
730	next unless $tun->{check_role} eq "*" \|\| $tun->{check_role} eq $self->{role};
731	next unless exists $tun->{default};
732	$self->set($param, $tun->{default});
733	}
734	}
735
736	# Service
737	sub set {
738	my Perlbal::Service $self = shift;
739	my ($key, $val, $mc) = @_;
740
741	# if you don't provide an $mc, that better mean you're damn sure it
742	# won't crash. (end-users never go this route)
743	$mc \|\|= Perlbal::ManageCommand->loud_crasher;
744
745	my $set = sub { $self->{$key} = $val; return $mc->ok; };
746
747	my $pool_set = sub {
748	# if we don't have a pool, automatically create one named $NAME_pool
749	unless ($self->{pool}) {
750	# die if necessary
751	die "ERROR: Attempt to vivify pool $self->{name}_pool but one or more pools\n" .
752	" have already been created manually. Please set $key on a\n" .
753	" previously created pool.\n" unless $Perlbal::vivify_pools;
754
755	# create the pool and ensure that vivify stays on
756	Perlbal::run_manage_command("CREATE POOL $self->{name}_pool", $mc->out);
757	Perlbal::run_manage_command("SET $self->{name}.pool = $self->{name}_pool");
758	$Perlbal::vivify_pools = 1;
759	}
760
761	# now we actually do the set
762	warn "WARNING: '$key' set on service $self->{name} on auto-vivified pool.\n" .
763	" This behavior is obsolete. This value should be set on a\n" .
764	" pool object and not on a service.\n" if $Perlbal::vivify_pools;
765	return $mc->err("No pool defined for service") unless $self->{pool};
766	return $self->{pool}->set($key, $val, $mc);
767	};
768
769	# this is now handled by Perlbal::Pool, so we pass this set command on
770	# through in case people try to use it on us like the old method.
771	return $pool_set->()
772	if $key eq 'nodefile' \|\|
773	$key eq 'balance_method';
774
775	my $bool = sub {
776	my $val = shift;
777	return 1 if $val =~ /^1\|true\|on\|yes$/i;
778	return 0 if $val =~ /^0\|false\|off\|no$/i;
779	return undef;
780	};
781
782	if (my $tun = $tunables->{$key}) {
783	if (my $req_role = $tun->{check_role}) {
784	return $mc->err("The '$key' option can only be set on a '$req_role' service")
785	unless ($self->{role}\|\|"") eq $req_role \|\| $req_role eq "*";
786	}
787
788	if (my $req_type = $tun->{check_type}) {
789	if (ref $req_type eq "ARRAY" && $req_type->[0] eq "enum") {
790	return $mc->err("Value of '$key' must be one of: " . join(", ", @{$req_type->[1]}))
791	unless grep { $val eq $_ } @{$req_type->[1]};
792	} elsif (ref $req_type eq "ARRAY" && $req_type->[0] eq "regexp") {
793	my $re = $req_type->[1];
794	my $emsg = $req_type->[2];
795	return $mc->err($emsg) unless $val =~ /$re/;
796	} elsif (ref $req_type eq "CODE") {
797	my $emsg = "";
798	return $mc->err($emsg) unless $req_type->($self, $val, \$emsg);
799	} elsif ($req_type eq "bool") {
800	$val = $bool->($val);
801	return $mc->err("Expecting boolean value for parameter '$key'")
802	unless defined $val;
803	} elsif ($req_type eq "int") {
804	return $mc->err("Expecting integer value for parameter '$key'")
805	unless $val =~ /^\d+$/;
806	} elsif ($req_type eq "size") {
807	$val = $1 if $val =~ /^(\d+)b$/i;
808	$val = $1 * 1024 if $val =~ /^(\d+)k$/i;
809	$val = $1 * 1024 * 1024 if $val =~ /^(\d+)m$/i;
810	return $mc->err("Expecting size unit value for parameter '$key' in bytes, or suffixed with 'K' or 'M'")
811	unless $val =~ /^\d+$/;
812	} elsif ($req_type eq "file") {
813	return $mc->err("File '$val' not found for '$key'") unless -f $val;
814	} elsif ($req_type eq "file_or_none") {
815	return $mc->err("File '$val' not found for '$key'") unless -f $val \|\| $val eq $tun->{default};
816	} else {
817	die "Unknown check_type: $req_type\n";
818	}
819	}
820
821	my $setter = $tun->{setter};
822
823	if (ref $setter eq "CODE") {
824	return $setter->($self, $val, $set, $mc);
825	} elsif ($tun->{_plugin_inserted}) {
826	# plugins that add tunables need to be stored in the extra_config hash due to the main object
827	# using fields. this passthrough is done so the config files don't need to specify this.
828	$self->{extra_config}->{$key} = $val;
829	return $mc->ok;
830	} else {
831	return $set->();
832	}
833	}
834
835	if ($key eq 'plugins') {
836	# unload existing plugins
837	foreach my $plugin (keys %{$self->{plugins}}) {
838	eval "Perlbal::Plugin::$plugin->unregister(\$self);";
839	return $mc->err($@) if $@;
840	}
841
842	# clear out loaded plugins and hooks
843	$self->{hooks} = {};
844	$self->{plugins} = {};
845	$self->{plugin_order} = [];
846
847	# load some plugins
848	foreach my $plugin (split /[\s,]+/, $val) {
849	next if $plugin eq 'none';
850
851	my $fn = Perlbal::plugin_case($plugin);
852
853	next if $self->{plugins}->{$fn};
854	unless ($Perlbal::plugins{$fn}) {
855	$mc->err("Plugin $fn not loaded; not registered for $self->{name}.");
856	next;
857	}
858
859	# now register it
860	eval "Perlbal::Plugin::$fn->register(\$self);";
861	return $mc->err($@) if $@;
862	$self->{plugins}->{$fn} = 1;
863	push @{$self->{plugin_order}}, $fn;
864	}
865	return $mc->ok;
866	}
867
868	if ($key =~ /^extra\.(.+)$/) {
869	# set some extra configuration data data
870	$self->{extra_config}->{$1} = $val;
871	return $mc->ok;
872	}
873
874	# see if it happens to be a plugin set command?
875	if ($key =~ /^(.+)\.(.+)$/) {
876	if (my $coderef = $self->{plugin_setters}->{$1}->{$2}) {
877	return $coderef->($mc->out, $2, $val);
878	}
879	}
880
881	return $mc->err("Unknown service parameter '$key'");
882	}
883
884	# CLASS METHOD -
885	# used by plugins that want to add tunables so that the config file
886	# can have more options for service settings
887	sub add_tunable {
888	my ($name, $hashref) = @_;
889	return 0 unless $name && $hashref && ref $hashref eq 'HASH';
890	return 0 if $tunables->{$name};
891	$hashref->{_plugin_inserted} = 1; # mark that a plugin did this
892	$tunables->{$name} = $hashref;
893	return 1;
894	}
895
896	# CLASS METHOD -
897	# remove a defined tunable, but only if a plugin is what created it
898	sub remove_tunable {
899	my $name = shift;
900	my $tun = $tunables->{$name} or return 0;
901	return 0 unless $tun->{_plugin_inserted};
902	delete $tunables->{$name};
903	return 1;
904	}
905
906	# CLASS METHOD -
907	# used by plugins to define a new role that services can take on
908	sub add_role {
909	my ($role, $creator) = @_;
910	return 0 unless $role && $creator && ref $creator eq 'CODE';
911	return 0 if $PluginRoles{$role};
912	$PluginRoles{$role} = $creator;
913	return 1;
914	}
915
916	# CLASS METHOD -
917	# remove a defined plugin role
918	sub remove_role {
919	return 0 unless delete $PluginRoles{$_[0]};
920	return 1;
921	}
922
923	# CLASS METHOD -
924	# returns a defined role creator, if it exists. (undef if it does not)
925	sub get_role_creator {
926	return $PluginRoles{$_[0]};
927	}
928
929	# run the hooks in a list one by one until one hook returns a true
930	# value. returns 1 or 0 depending on if any hooks handled the
931	# request.
932	sub run_hook {
933	my Perlbal::Service $self = shift;
934	my $hook = shift;
935	if (defined (my $ref = $self->{hooks}->{$hook})) {
936	# call all the hooks until one returns true
937	foreach my $hookref (@$ref) {
938	my $rval = $hookref->[1]->(@_);
939	return 1 if $rval;
940	}
941	}
942	return 0;
943	}
944
945	# run a bunch of hooks in this service, always returns undef.
946	sub run_hooks {
947	my Perlbal::Service $self = shift;
948	my $hook = shift;
949	if (defined (my $ref = $self->{hooks}->{$hook})) {
950	# call all the hooks
951	$_->[1]->(@_) foreach @$ref;
952	}
953	return undef;
954	}
955
956	# define a hook for this service
957	sub register_hook {
958	my Perlbal::Service $self = shift;
959	my ($pclass, $hook, $ref) = @_;
960	push @{$self->{hooks}->{$hook} \|\|= []}, [ $pclass, $ref ];
961	return 1;
962	}
963
964	# remove hooks we have defined
965	sub unregister_hook {
966	my Perlbal::Service $self = shift;
967	my ($pclass, $hook) = @_;
968	if (defined (my $refs = $self->{hooks}->{$hook})) {
969	my @new;
970	foreach my $ref (@$refs) {
971	# fill @new with hooks that DON'T match
972	push @new, $ref
973	unless $ref->[0] eq $pclass;
974	}
975	$self->{hooks}->{$hook} = \@new;
976	return 1;
977	}
978	return undef;
979	}
980
981	# remove all hooks of a certain class
982	sub unregister_hooks {
983	my Perlbal::Service $self = shift;
984	foreach my $hook (keys %{$self->{hooks}}) {
985	# call unregister_hook with this hook name
986	$self->unregister_hook($_[0], $hook);
987	}
988	}
989
990	# register a value setter for plugin configuration
991	sub register_setter {
992	my Perlbal::Service $self = shift;
993	my ($pclass, $key, $coderef) = @_;
994	return unless $pclass && $key && $coderef;
995	$self->{plugin_setters}->{lc $pclass}->{lc $key} = $coderef;
996	}
997
998	# remove a setter
999	sub unregister_setter {
1000	my Perlbal::Service $self = shift;
1001	my ($pclass, $key) = @_;
1002	return unless $pclass && $key;
1003	delete $self->{plugin_setters}->{lc $pclass}->{lc $key};
1004	}
1005
1006	# remove a bunch of setters
1007	sub unregister_setters {
1008	my Perlbal::Service $self = shift;
1009	my $pclass = shift;
1010	return unless $pclass;
1011	delete $self->{plugin_setters}->{lc $pclass};
1012	}
1013
1014	# take a backend we've created and mark it as pending if we do not
1015	# have another pending backend connection in this slot
1016	sub add_pending_connect {
1017	my Perlbal::Service $self = shift;
1018	my Perlbal::BackendHTTP $be = shift;
1019
1020	# error if we already have a pending connection for this ipport
1021	if (defined $self->{pending_connects}{$be->{ipport}}) {
1022	Perlbal::log('warning', "Warning: attempting to spawn backend connection that already existed.");
1023
1024	# now dump a backtrace so we know how we got here
1025	my $depth = 0;
1026	while (my ($package, $filename, $line, $subroutine) = caller($depth++)) {
1027	Perlbal::log('warning', " -- [$filename:$line] $package::$subroutine");
1028	}
1029
1030	# we're done now, just return
1031	return;
1032	}
1033
1034	# set this connection up in the pending connection list
1035	$self->{pending_connects}{$be->{ipport}} = $be;
1036	$self->{pending_connect_count}++;
1037	}
1038
1039	# remove a backend connection from the pending connect list if and only
1040	# if it is the actual connection contained in the list; prevent double
1041	# decrementing on accident
1042	sub clear_pending_connect {
1043	my Perlbal::Service $self = shift;
1044	my Perlbal::BackendHTTP $be = shift;
1045	if (defined $self->{pending_connects}{$be->{ipport}} && defined $be &&
1046	$self->{pending_connects}{$be->{ipport}} == $be) {
1047	$self->{pending_connects}{$be->{ipport}} = undef;
1048	$self->{pending_connect_count}--;
1049	}
1050	}
1051
1052	# called by BackendHTTP when it's closed by any means
1053	sub note_backend_close {
1054	my Perlbal::Service $self = shift;
1055	my Perlbal::BackendHTTP $be = shift;
1056	$self->clear_pending_connect($be);
1057	$self->spawn_backends;
1058	}
1059
1060	# called by ClientProxy when it dies.
1061	sub note_client_close {
1062	my Perlbal::Service $self;
1063	my Perlbal::ClientProxy $cp;
1064	($self, $cp) = @_;
1065
1066	if (delete $self->{waiting_client_map}{$cp->{fd}}) {
1067	$self->{waiting_client_count}--;
1068	}
1069	}
1070
1071	sub mark_node_used {
1072	my Perlbal::Service $self = $_[0];
1073	$self->{pool}->mark_node_used($_[1]) if $self->{pool};
1074	}
1075
1076	sub get_client {
1077	my Perlbal::Service $self = shift;
1078
1079	my $ret = sub {
1080	my Perlbal::ClientProxy $cp = shift;
1081	$self->{waiting_client_count}--;
1082	delete $self->{waiting_client_map}{$cp->{fd}};
1083
1084	# before we return, start another round of connections
1085	$self->spawn_backends;
1086
1087	return $cp;
1088	};
1089
1090	# determine if we should jump straight to the high priority queue or
1091	# act as pressure relief on the standard queue
1092	my $hp_first = 1;
1093	if (($self->{queue_relief_size} > 0) &&
1094	(scalar(@{$self->{waiting_clients}}) >= $self->{queue_relief_size})) {
1095	# if we're below the chance level, take a standard queue item
1096	$hp_first = 0
1097	if rand(100) < $self->{queue_relief_chance};
1098	}
1099
1100	# find a high-priority client, or a regular one
1101	my Perlbal::ClientProxy $cp;
1102	while ($hp_first && ($cp = shift @{$self->{waiting_clients_highpri}})) {
1103	next if $cp->{closed};
1104	if (Perlbal::DEBUG >= 2) {
1105	my $backlog = scalar @{$self->{waiting_clients}};
1106	print "Got from fast queue, in front of $backlog others\n";
1107	}
1108	return $ret->($cp);
1109	}
1110
1111	# regular clients:
1112	while ($cp = shift @{$self->{waiting_clients}}) {
1113	next if $cp->{closed};
1114	print "Backend requesting client, got normal = $cp->{fd}.\n" if Perlbal::DEBUG >= 2;
1115	return $ret->($cp);
1116	}
1117
1118	# low-priority (batch/idle) clients.
1119	while ($cp = shift @{$self->{waiting_clients_lowpri}}) {
1120	next if $cp->{closed};
1121	print "Backend requesting client, got low priority = $cp->{fd}.\n" if Perlbal::DEBUG >= 2;
1122	return $ret->($cp);
1123	}
1124
1125	return undef;
1126	}
1127
1128	# given a backend, verify it's generation
1129	sub verify_generation {
1130	my Perlbal::Service $self = $_[0];
1131	my Perlbal::BackendHTTP $be = $_[1];
1132
1133	# fast cases: generation count matches, so we just return an 'okay!' flag
1134	return 1 if $self->{generation} == $be->generation;
1135
1136	# if our current pool knows about this ip:port, then we can still use it
1137	if (defined $self->{pool}->node_used($be->ipport)) {
1138	# so we know this is good, in the future we just want to hit the fast case
1139	# and continue, so let's update the generation
1140	$be->generation($self->{generation});
1141	return 1;
1142	}
1143
1144	# if we get here, the backend should be closed
1145	$be->close('invalid_generation');
1146	return 0;
1147	}
1148
1149	# called by backend connection after it becomes writable
1150	sub register_boredom {
1151	my Perlbal::Service $self;
1152	my Perlbal::BackendHTTP $be;
1153	($self, $be) = @_;
1154
1155	# note that this backend is no longer pending a connect,
1156	# if we thought it was before. but not if it's a persistent
1157	# connection asking to be re-used.
1158	unless ($be->{use_count}) {
1159	$self->clear_pending_connect($be);
1160	}
1161
1162	# it is possible that this backend is part of a different pool that we're
1163	# no longer using... if that's the case, we want to close it
1164	return unless $self->verify_generation($be);
1165
1166	# now try to fetch a client for it
1167	my Perlbal::ClientProxy $cp = $self->get_client;
1168	if ($cp) {
1169	return if $be->assign_client($cp);
1170
1171	# don't want to lose client, so we (unfortunately)
1172	# stick it at the end of the waiting queue.
1173	# fortunately, assign_client shouldn't ever fail.
1174	$self->request_backend_connection($cp);
1175	}
1176
1177	# don't hang onto more bored, persistent connections than
1178	# has been configured for connect-ahead
1179	if ($be->{use_count}) {
1180	my $current_bored = scalar @{$self->{bored_backends}};
1181	if ($current_bored >= $self->{backend_persist_cache}) {
1182	$be->close('too_many_bored');
1183	return;
1184	}
1185	}
1186
1187	# put backends which are known to be bound to processes
1188	# and not to TCP stacks at the beginning where they'll
1189	# be used first
1190	if ($be->{has_attention}) {
1191	unshift @{$self->{bored_backends}}, $be;
1192	} else {
1193	push @{$self->{bored_backends}}, $be;
1194	}
1195	}
1196
1197	sub note_bad_backend_connect {
1198	my Perlbal::Service $self = shift;
1199	my Perlbal::BackendHTTP $be = shift;
1200	my $retry_time = shift();
1201
1202	# clear this pending connection
1203	$self->clear_pending_connect($be);
1204
1205	# mark this host as dead for a while if we need to
1206	if (defined $retry_time && $retry_time > 0) {
1207	# we don't want other spawn_backends calls to retry
1208	$self->{backend_no_spawn}->{$be->{ipport}} = 1;
1209
1210	# and now we set a callback to ensure we're kicked at the right time
1211	Perlbal::Socket::register_callback($retry_time, sub {
1212	delete $self->{backend_no_spawn}->{$be->{ipport}};
1213	$self->spawn_backends;
1214	});
1215	}
1216
1217	# FIXME: do something interesting (tell load balancer about dead host,
1218	# and fire up a new connection, if warranted)
1219
1220	# makes a new connection, if needed
1221	$self->spawn_backends;
1222	}
1223
1224	sub request_backend_connection { # : void
1225	my Perlbal::Service $self;
1226	my Perlbal::ClientProxy $cp;
1227	($self, $cp) = @_;
1228
1229	return unless $cp && ! $cp->{closed};
1230
1231	my $hi_pri = $cp->{high_priority}; # load values from the client proxy object
1232	my $low_pri = $cp->{low_priority}; # they are initialized as 0 during object creation, but hooks can override them
1233
1234	# is there a defined high-priority cookie?
1235	if (my $cname = $self->{high_priority_cookie}) {
1236	# decide what priority class this request is in
1237	my $hd = $cp->{req_headers};
1238	my %cookie;
1239	foreach (split(/;\s+/, $hd->header("Cookie") \|\| '')) {
1240	next unless ($_ =~ /(.)=(.)/);
1241	$cookie{Perlbal::Util::durl($1)} = Perlbal::Util::durl($2);
1242	}
1243	my $hicookie = $cookie{$cname} \|\| "";
1244	$hi_pri = index($hicookie, $self->{high_priority_cookie_contents}) != -1;
1245	}
1246
1247	# now, call hook to see if this should be high priority
1248	$hi_pri = $self->run_hook('make_high_priority', $cp)
1249	unless $hi_pri; # only if it's not already
1250
1251	# and then, call hook to see about low priority
1252	$low_pri = $self->run_hook('make_low_priority', $cp)
1253	unless $hi_pri \|\| $low_pri; # only if it's not high or low already
1254
1255	$cp->{high_priority} = 1 if $hi_pri;
1256	$cp->{low_priority} = 1 if $low_pri;
1257
1258	# before we even consider spawning backends, let's see if we have
1259	# some bored (pre-connected) backends that'd take this client
1260	my Perlbal::BackendHTTP $be;
1261	my $now = time;
1262	while ($be = shift @{$self->{bored_backends}}) {
1263	next if $be->{closed};
1264
1265	# now make sure that it's still in our pool, and if not, close it
1266	next unless $self->verify_generation($be);
1267
1268	# don't use connect-ahead connections when we haven't
1269	# verified we have their attention
1270	if (! $be->{has_attention} && $be->{create_time} < $now - 5) {
1271	$be->close("too_old_bored");
1272	next;
1273	}
1274
1275	# don't use keep-alive connections if we know the server's
1276	# just about to kill the connection for being idle
1277	if ($be->{disconnect_at} && $now + 2 > $be->{disconnect_at}) {
1278	$be->close("too_close_disconnect");
1279	next;
1280	}
1281
1282	# give the backend this client
1283	if ($be->assign_client($cp)) {
1284	# and make some extra bored backends, if configured as such
1285	$self->spawn_backends;
1286	return;
1287	}
1288
1289	# assign client can end up closing the connection, so check for that
1290	return if $cp->{closed};
1291	}
1292
1293	if ($hi_pri) {
1294	push @{$self->{waiting_clients_highpri}}, $cp;
1295	} elsif ($low_pri) {
1296	push @{$self->{waiting_clients_lowpri}}, $cp;
1297	} else {
1298	push @{$self->{waiting_clients}}, $cp;
1299	}
1300
1301	$self->{waiting_client_count}++;
1302	$self->{waiting_client_map}{$cp->{fd}} = 1;
1303
1304	$self->spawn_backends;
1305	}
1306
1307	# sees if it should spawn one or more backend connections
1308	sub spawn_backends {
1309	my Perlbal::Service $self = shift;
1310
1311	# check our lock and set it if we can
1312	return if $self->{spawn_lock};
1313	$self->{spawn_lock} = 1;
1314
1315	# sanity checks on our bookkeeping
1316	if ($self->{pending_connect_count} < 0) {
1317	Perlbal::log('crit', "Bogus: service $self->{name} has pending connect ".
1318	"count of $self->{pending_connect_count}?! Resetting.");
1319	$self->{pending_connect_count} = scalar
1320	map { $_ && ! $_->{closed} } values %{$self->{pending_connects}};
1321	}
1322
1323	# keep track of the sum of existing_bored + bored_created
1324	my $backends_created = scalar(@{$self->{bored_backends}}) + $self->{pending_connect_count};
1325	my $backends_needed = $self->{waiting_client_count} + $self->{connect_ahead};
1326	my $to_create = $backends_needed - $backends_created;
1327
1328	my $pool = $self->{pool};
1329
1330	# can't create more than this, assuming one pending connect per node
1331	my $max_creatable = $pool ? ($self->{pool}->node_count - $self->{pending_connect_count}) : 1;
1332	$to_create = $max_creatable if $to_create > $max_creatable;
1333
1334	# cap number of attempted connects at once
1335	$to_create = 10 if $to_create > 10;
1336
1337	my $now = time;
1338
1339	while ($to_create > 0) {
1340	$to_create--;
1341
1342	# spawn processes if not a pool, else whine.
1343	unless ($pool) {
1344	if (my $sp = $self->{server_process}) {
1345	warn "To create = $to_create...\n";
1346	warn " spawning $sp\n";
1347	my $be = Perlbal::BackendHTTP->new_process($self, $sp);
1348	return;
1349	}
1350	warn "No pool! Can't spawn backends.\n";
1351	return;
1352	}
1353
1354	my ($ip, $port) = $self->{pool}->get_backend_endpoint;
1355	unless ($ip) {
1356	Perlbal::log('crit', "No backend IP for service $self->{name}");
1357	# FIXME: register desperate flag, so load-balancer module can callback when it has a node
1358	$self->{spawn_lock} = 0;
1359	return;
1360	}
1361
1362	# handle retry timeouts so we don't spin
1363	next if $self->{backend_no_spawn}->{"$ip:$port"};
1364
1365	# if it's pending, verify the pending one is still valid
1366	if (my Perlbal::BackendHTTP $be = $self->{pending_connects}{"$ip:$port"}) {
1367	my $age = $now - $be->{create_time};
1368	if ($age >= 5 && $be->{state} eq "connecting") {
1369	$be->close('connect_timeout');
1370	} elsif ($age >= 60 && $be->{state} eq "verifying_backend") {
1371	# after 60 seconds of attempting to verify, we're probably already dead
1372	$be->close('verify_timeout');
1373	} elsif (! $be->{closed}) {
1374	next;
1375	}
1376	}
1377
1378	# now actually spawn a backend and add it to our pending list
1379	if (my $be = Perlbal::BackendHTTP->new($self, $ip, $port, { pool => $self->{pool} })) {
1380	$self->add_pending_connect($be);
1381	}
1382	}
1383
1384	# clear our spawn lock
1385	$self->{spawn_lock} = 0;
1386	}
1387
1388	# getter only
1389	sub role {
1390	my Perlbal::Service $self = shift;
1391	return $self->{role};
1392	}
1393
1394	# called by BackendHTTP to ask if a client's IP is in our trusted list
1395	sub trusted_ip {
1396	my Perlbal::Service $self = shift;
1397	my $ip = shift;
1398
1399	return 1 if $self->{'always_trusted'};
1400
1401	my $tmap = $self->{trusted_upstream_proxies};
1402	return 0 unless $tmap;
1403
1404	# try to use it as a Net::Netmask object
1405	return 1 if eval { $tmap->match($ip); };
1406	return 0;
1407	}
1408
1409	# manage some header stuff
1410	sub header_management {
1411	my Perlbal::Service $self = shift;
1412	my ($mode, $key, $val, $mc) = @_;
1413	return $mc->err("no header provided") unless $key;
1414	return $mc->err("no value provided") unless $val \|\| $mode eq 'remove';
1415	return $mc->err("only valid on reverse_proxy services") unless $self->{role} eq 'reverse_proxy';
1416
1417	if ($mode eq 'insert') {
1418	push @{$self->{extra_headers}->{insert}}, [ $key, $val ];
1419	} elsif ($mode eq 'remove') {
1420	push @{$self->{extra_headers}->{remove}}, $key;
1421	}
1422	return $mc->ok;
1423	}
1424
1425	sub munge_headers {
1426	my Perlbal::Service $self = $_[0];
1427	my Perlbal::HTTPHeaders $hdrs = $_[1];
1428
1429	# handle removals first
1430	foreach my $hdr (@{$self->{extra_headers}->{remove}}) {
1431	$hdrs->header($hdr, undef);
1432	}
1433
1434	# and now insertions
1435	foreach my $hdr (@{$self->{extra_headers}->{insert}}) {
1436	$hdrs->header($hdr->[0], $hdr->[1]);
1437	}
1438	}
1439
1440	# getter/setter
1441	sub selector {
1442	my Perlbal::Service $self = shift;
1443	if (@_) {
1444	my $ref = shift;
1445	$self->{selector} = sub {
1446	my $cb = shift;
1447
1448	# try to give it to our defined selector
1449	my $res = $ref->($cb);
1450
1451	# if that failed and we have a default, then give it to them
1452	if (!$res && $self->{default_service}) {
1453	$self->{default_service}->adopt_base_client($cb);
1454	return 1;
1455	}
1456
1457	return $res;
1458	};
1459	}
1460	return $self->{selector};
1461	}
1462
1463	# given a base client from a 'selector' role, down-cast it to its specific type
1464	sub adopt_base_client {
1465	my Perlbal::Service $self = shift;
1466	my Perlbal::ClientHTTPBase $cb = shift;
1467
1468	$cb->{service} = $self;
1469
1470	if ($self->{'role'} eq "web_server") {
1471	Perlbal::ClientHTTP->new_from_base($cb);
1472	return;
1473	} elsif ($self->{'role'} eq "reverse_proxy") {
1474	Perlbal::ClientProxy->new_from_base($cb);
1475	return;
1476	} elsif ($self->{'role'} eq "selector") {
1477	$self->selector()->($cb);
1478	return;
1479	} else {
1480	$cb->_simple_response(500, "Can't map to service type $self->{'role'}");
1481	}
1482	}
1483
1484	# turn a ClientProxy or ClientHTTP back into a generic base client
1485	# (for a service-selector role)
1486	sub return_to_base {
1487	my Perlbal::Service $self = shift;
1488	my Perlbal::ClientHTTPBase $cb = shift; # actually a subclass of Perlbal::ClientHTTPBase
1489
1490	$cb->{service} = $self;
1491	Perlbal::Util::rebless($cb, "Perlbal::ClientHTTPBase");
1492
1493	# the read/watch events are reset by ClientHTTPBase's http_response_sent (our caller)
1494	}
1495
1496	# Service
1497	sub enable {
1498	my Perlbal::Service $self;
1499	my $mc;
1500
1501	($self, $mc) = @_;
1502
1503	if ($self->{enabled}) {
1504	$mc && $mc->err("service $self->{name} is already enabled");
1505	return 0;
1506	}
1507
1508	my $listener;
1509
1510	# create UDP upload tracker listener
1511	if ($self->{role} eq "upload_tracker") {
1512	$listener = Perlbal::UploadListener->new($self->{listen}, $self);
1513	}
1514
1515	# create TCP listening socket
1516	if (! $listener && $self->{listen}) {
1517	my $opts = {};
1518	if ($self->{enable_ssl}) {
1519	$opts->{ssl} = {
1520	SSL_key_file => $self->{ssl_key_file},
1521	SSL_cert_file => $self->{ssl_cert_file},
1522	SSL_cipher_list => $self->{ssl_cipher_list},
1523	};
1524	return $mc->err("IO::Socket:SSL (0.97+) not available. Can't do SSL.") unless eval "use IO::Socket::SSL 0.97 (); 1;";
1525	return $mc->err("SSL key file ($self->{ssl_key_file}) doesn't exist") unless -f $self->{ssl_key_file};
1526	return $mc->err("SSL cert file ($self->{ssl_cert_file}) doesn't exist") unless -f $self->{ssl_cert_file};
1527	}
1528
1529	my $tl = Perlbal::TCPListener->new($self->{listen}, $self, $opts);
1530	unless ($tl) {
1531	$mc && $mc->err("Can't start service '$self->{name}' on $self->{listen}: $Perlbal::last_error");
1532	return 0;
1533	}
1534	$listener = $tl;
1535	}
1536
1537	$self->{listener} = $listener;
1538	$self->{enabled} = 1;
1539	return $mc ? $mc->ok : 1;
1540	}
1541
1542	# Service
1543	sub disable {
1544	my Perlbal::Service $self;
1545	my ($mc, $force);
1546
1547	($self, $mc, $force) = @_;
1548
1549	if (! $self->{enabled}) {
1550	$mc && $mc->err("service $self->{name} is already disabled");
1551	return 0;
1552	}
1553	if ($self->{role} eq "management" && ! $force) {
1554	$mc && $mc->err("can't disable management service");
1555	return 0;
1556	}
1557
1558	# find listening socket
1559	my $tl = $self->{listener};
1560	$tl->close if $tl;
1561	$self->{listener} = undef;
1562	$self->{enabled} = 0;
1563	return $mc ? $mc->ok : 1;
1564	}
1565
1566	sub stats_info
1567	{
1568	my Perlbal::Service $self = shift;
1569	my $out = shift;
1570	my $now = time;
1571
1572	$out->("SERVICE $self->{name}");
1573	$out->(" listening: " . ($self->{listen} \|\| "--"));
1574	$out->(" role: $self->{role}");
1575	if ($self->{role} eq "reverse_proxy" \|\|
1576	$self->{role} eq "web_server") {
1577	$out->(" pend clients: $self->{waiting_client_count}");
1578	$out->(" pend backend: $self->{pending_connect_count}");
1579	foreach my $ipport (sort keys %{$self->{pending_connects}}) {
1580	my $be = $self->{pending_connects}{$ipport};
1581	next unless $be;
1582	my $age = $now - $be->{create_time};
1583	$out->(" $ipport - " . ($be->{closed} ? "(closed)" : $be->{state}) . " - ${age}s");
1584	}
1585	}
1586	if ($self->{role} eq "reverse_proxy") {
1587	if ($self->{reproxy_cache}) {
1588	my $hits = $self->{_stat_cache_hits} \|\| 0;
1589	my $hit_rate = sprintf("%0.02f%%", eval { $hits / ($self->{_stat_requests} \|\| 0) * 100 } \|\| 0);
1590
1591	my $size = eval { $self->{reproxy_cache}->size };
1592	$size = defined($size) ? $size : 'undef';
1593
1594	my $maxsize = eval { $self->{reproxy_cache}->maxsize };
1595	$maxsize = defined ($maxsize) ? $maxsize : 'undef';
1596
1597	my $sizepercent = eval { sprintf("%0.02f%%", $size / $maxsize * 100) } \|\| 'undef';
1598
1599	$out->(" cache size: $size/$maxsize ($sizepercent)");
1600	$out->(" cache hits: $hits");
1601	$out->("cache hit rate: $hit_rate");
1602	}
1603
1604	my $bored_count = scalar @{$self->{bored_backends}};
1605	$out->(" connect-ahead: $bored_count/$self->{connect_ahead}");
1606	if ($self->{pool}) {
1607	$out->(" pool: " . $self->{pool}->name);
1608	$out->(" nodes:");
1609	foreach my $n (@{ $self->{pool}->nodes }) {
1610	my $hostport = "$n->[0]:$n->[1]";
1611	$out->(sprintf(" %-21s %7d", $hostport, $self->{pool}->node_used($hostport) \|\| 0));
1612	}
1613	}
1614	} elsif ($self->{role} eq "web_server") {
1615	$out->(" docroot: $self->{docroot}");
1616	}
1617	}
1618
1619	# simple passthroughs to the run_hook mechanism. part of the reportto interface.
1620	sub backend_response_received {
1621	return $_[0]->run_hook('backend_response_received', $_[1]);
1622	}
1623
1624	# just a getter for our name
1625	sub name {
1626	my Perlbal::Service $self = $_[0];
1627	return $self->{name};
1628	}
1629
1630	sub listenaddr {
1631	my Perlbal::Service $self = $_[0];
1632	return $self->{listen};
1633	}
1634
1635	sub reproxy_cache {
1636	my Perlbal::Service $self = $_[0];
1637	return $self->{reproxy_cache};
1638	}
1639
1640	sub add_to_reproxy_url_cache {
1641	my Perlbal::Service $self;
1642	my ($reqhd, $reshd);
1643
1644	($self, $reqhd, $reshd) = @_;
1645
1646	# is caching enabled on this service?
1647	my $cache = $self->{reproxy_cache} or
1648	return 0;
1649
1650	# these should always be set anyway, from BackendHTTP:
1651	my $reproxy_cache_for = $reshd->header('X-REPROXY-CACHE-FOR') or return 0;
1652	my $urls = $reshd->header('X-REPROXY-URL') or return 0;
1653
1654	my ($timeout_delta, $cache_headers) = split ';', $reproxy_cache_for, 2;
1655	my $timeout = $timeout_delta ? time() + $timeout_delta : undef;
1656
1657	my $hostname = $reqhd->header("Host") \|\| '';
1658	my $requri = $reqhd->request_uri \|\| '';
1659	my $key = "$hostname\|$requri";
1660
1661	my @headers;
1662	foreach my $header (split /\s+/, $cache_headers) {
1663	my $value;
1664	next unless $header && ($value = $reshd->header($header));
1665	$value = _ref_to($value) if uc($header) eq 'CONTENT-TYPE';
1666	push @headers, _ref_to($header), $value;
1667	}
1668
1669	$cache->set($key, [$timeout, \@headers, $urls]);
1670	}
1671
1672	# given a string, return a shared reference to that string. to save
1673	# memory when lots of same string is stored.
1674	my %refs;
1675	sub _ref_to {
1676	my $key = shift;
1677	return $refs{$key} \|\| ($refs{$key} = \$key);
1678	}
1679
1680	1;
1681
1682	# Local Variables:
1683	# mode: perl
1684	# c-basic-indent: 4
1685	# indent-tabs-mode: nil
1686	# End:

Note: See TracBrowser for help on using the browser.

Context Navigation

root/trunk/lib/Perlbal/Service.pm

Download in other formats: