Version 2.. it had issues with zombie / defunct processes on Linux. This is significantly more stable, and I'm currently serving 300,000+ requests a day on something based off of this:
1
2
3
4
5
6
7
8
9
10
11
12 use HTTP::Daemon;
13 use HTTP::Status;
14 use CGI;
15 use POSIX;
16
17 my $totalChildren = 15;
18 my $childLifetime = 10;
19 my $logFile = "/tmp/daemon.log";
20 my %children;
21 my $children = 0;
22
23 &daemonize;
24
25 my $d = HTTP::Daemon->new( LocalPort => 1981, LocalAddr => '127.0.0.1', Reuse => 1, Timeout => 180 ) || die "Cannot create socket: $!\n";
26
27 warn ("master is ", $d->url);
28
29 &spawnChildren;
30 &keepTicking;
31 exit;
32
33
34
35
36 sub spawnChildren {
37 for (1..$totalChildren) {
38 &newChild();
39 }
40 }
41
42
43
44
45
46 sub keepTicking {
47 while ( 1 ) {
48 sleep;
49 for (my $i = $children; $i < $totalChildren; $i++ ) {
50 &newChild();
51 }
52 };
53 }
54
55
56
57
58 sub newChild {
59 my $pid;
60 my $sigset = POSIX::SigSet->new(SIGINT);
61 sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!";
62 die "Cannot fork child: $!\n" unless defined ($pid = fork);
63 if ($pid) {
64 $children{$pid} = 1;
65 $children++;
66 warn "forked new child, we now have $children children";
67 return;
68 }
69
70 my $i;
71 while ($i < $childLifetime) {
72 $i++;
73 my $c = $d->accept or last;
74 $c->autoflush(1);
75 logMessage ("connect:". $c->peerhost . "\n");
76 my $r = $c->get_request(1) or last;
77
78
79
80
81 my $url = $r->url;
82 $url =~ s/^\///g;
83
84 if ($r->method ne 'GET') {
85 $c->send_error(RC_FORBIDDEN);
86 logMessage ($c->peerhost . " made weird request\n");
87 redo;
88 }
89
90 my $response = HTTP::Response->new(200);
91 logMessage ($c->peerhost . " " . $d->url . $url . "\n");
92 $response->content("<html><body>The daemon works! This child has served $i requests.</body></html>");
93
94 $response->header("Content-Type" => "text/html");
95 $c->send_response($response);
96
97 logMessage ("disconnect:" . $c->peerhost . " - ct[$i]\n");
98 $c->close;
99 }
100
101 warn "child terminated after $i requests";
102 exit;
103 }
104
105
106
107
108 sub REAPER {
109 my $stiff;
110 while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
111 warn ("child $stiff terminated -- status $?");
112 $children--;
113 $children{$stiff};
114 }
115 $SIG{CHLD} = \&REAPER;
116 }
117
118
119
120 sub daemonize {
121 my $pid = fork;
122 defined ($pid) or die "Cannot start daemon: $!";
123 print "Parent daemon running.\n" if $pid;
124 exit if $pid;
125
126
127
128 POSIX::setsid();
129
130 close (STDOUT);
131 close (STDIN);
132 close (STDERR);
133
134
135
136 $SIG{__WARN__} = sub {
137 &logMessage ("NOTE! " . join(" ", @_));
138 };
139
140 $SIG{__DIE__} = sub {
141 &logMessage ("FATAL! " . join(" ", @_));
142 exit;
143 };
144
145 $SIG{HUP} = $SIG{INT} = $SIG{TERM} = sub {
146 my $sig = shift;
147 $SIG{$sig} = 'IGNORE';
148 kill 'INT' => keys %children;
149 die "killed by $sig\n";
150 exit;
151 };
152
153 $SIG{CHLD} = \&REAPER;
154 }
155
156
157
158 sub logMessage {
159 my $message = shift;
160 (my $sec, my $min, my $hour, my $mday, my $mon, my $year) = gmtime();
161 $mon++;
162 $mon = sprintf("%0.2d", $mon);
163 $mday = sprintf("%0.2d", $mday);
164 $hour = sprintf("%0.2d", $hour);
165 $min = sprintf("%0.2d", $min);
166 $sec = sprintf("%0.2d", $sec);
167 $year += 1900;
168 my $time = qq{$year/$mon/$mday $hour:$min:$sec};
169 open (FH, ">>" . $logFile);
170 print FH $time . " - " . $message;
171 close (FH);
172 }
