File Coverage

blib/lib/Limper.pm
Criterion Covered Total %
statement 14 174 8.0
branch 0 94 0.0
condition 0 83 0.0
subroutine 5 34 14.7
pod 18 24 75.0
total 37 409 9.0


line stmt bran cond sub pod time code
1             package Limper;
2             $Limper::VERSION = '0.013';
3 2     2   23442 use 5.10.0;
  2         7  
4 2     2   10 use strict;
  2         3  
  2         43  
5 2     2   20 use warnings;
  2         2  
  2         68  
6              
7 2     2   1805 use IO::Socket;
  2         51801  
  2         9  
8              
9 2     2   1329 use Exporter qw/import/;
  2         5  
  2         6926  
10             our @EXPORT = qw/get post put del trace options patch any status headers request response config hook limp/;
11             our @EXPORT_OK = qw/info warning rfc1123date/;
12              
13             # data stored here
14             my $request = {};
15             my $response = {};
16             my $config = {};
17             my $hook = {};
18             my $conn;
19              
20             # route subs
21             my $route = {};
22 0     0 1   sub get { push @{$route->{GET}}, @_; @_ }
  0            
  0            
23 0     0 1   sub post { push @{$route->{POST}}, @_; @_ }
  0            
  0            
24 0     0 1   sub put { push @{$route->{PUT}}, @_; @_ }
  0            
  0            
25 0     0 1   sub del { push @{$route->{DELETE}}, @_; @_ }
  0            
  0            
26 0     0 1   sub trace { push @{$route->{TRACE}}, @_; @_ }
  0            
  0            
27 0     0 1   sub options { push @{$route->{OPTIONS}}, @_; @_ }
  0            
  0            
28 0     0 1   sub patch { push @{$route->{PATCH}}, @_; @_ }
  0            
  0            
29 0     0 1   sub any { push @{$route->{$_}}, @_ for keys %$route }
  0            
30              
31             # for send_response()
32             my $reasons = {
33             100 => 'Continue',
34             101 => 'Switching Protocols',
35             200 => 'OK',
36             201 => 'Created',
37             202 => 'Accepted',
38             203 => 'Non-Authoritative Information',
39             204 => 'No Content',
40             205 => 'Reset Content',
41             206 => 'Partial Content',
42             300 => 'Multiple Choices',
43             301 => 'Moved Permanently',
44             302 => 'Found',
45             303 => 'See Other',
46             304 => 'Not Modified',
47             305 => 'Use Proxy',
48             307 => 'Temporary Redirect',
49             400 => 'Bad Request',
50             401 => 'Unauthorized',
51             402 => 'Payment Required',
52             403 => 'Forbidden',
53             404 => 'Not Found',
54             405 => 'Method Not Allowed',
55             406 => 'Not Acceptable',
56             407 => 'Proxy Authentication Required',
57             408 => 'Request Time-out',
58             409 => 'Conflict',
59             410 => 'Gone',
60             411 => 'Length Required',
61             412 => 'Precondition Failed',
62             413 => 'Request Entity Too Large',
63             414 => 'Request-URI Too Large',
64             415 => 'Unsupported Media Type',
65             416 => 'Requested range not satisfiable',
66             417 => 'Expectation Failed',
67             500 => 'Internal Server Error',
68             501 => 'Not Implemented',
69             502 => 'Bad Gateway',
70             503 => 'Service Unavailable',
71             504 => 'Gateway Time-out',
72             505 => 'HTTP Version not supported',
73             };
74              
75             # for get_request()
76             my $method_rx = qr/(?: OPTIONS | GET | HEAD | POST | PUT | DELETE | TRACE | CONNECT )/x;
77             my $version_rx = qr{HTTP/\d+\.\d+};
78             my $uri_rx = qr/[^ ]+/;
79              
80             # Returns current time or passed timestamp as an HTTP 1.1 date
81             my @months = qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/;
82             my @days = qw/Sun Mon Tue Wed Thu Fri Sat/;
83             sub rfc1123date {
84 0 0   0 1   my ($sec, $min, $hour, $mday, $mon, $year, $wday) = @_ ? gmtime $_[0] : gmtime;
85 0           sprintf '%s, %02d %s %4d %02d:%02d:%02d GMT', $days[$wday], $mday, $months[$mon], $year + 1900, $hour, $min, $sec;
86             }
87              
88             # Formats date like "2014-08-17 00:12:41" in local time.
89             sub date {
90 0     0 0   my ($sec, $min, $hour, $mday, $mon, $year) = localtime;
91 0           sprintf '%04d-%02d-%02d %02d:%02d:%02d', $year + 1900, $mon, $mday, $hour, $min, $sec;
92             }
93              
94             # Trivially log to STDOUT or STDERR
95 0     0 1   sub info { say date, ' ', @_ }
96 0     0 1   sub warning { warn date, ' ', @_ }
97              
98             sub timeout {
99 0     0 0   eval {
100 0     0     local $SIG{ALRM} = sub { die "alarm\n" };
  0            
101 0   0       alarm($config->{timeout} // 5);
102 0           $_ = $_[0]->();
103 0           alarm 0;
104             };
105 0 0 0       $@ ? ($conn->close and undef) : $_;
106             }
107              
108             sub bad_request {
109 0     0 0   warning "[$request->{remote_host}] bad request: $_[0]";
110 0           $response = { status => 400, body => 'Bad Request' };
111 0   0       send_response($request->{method} // '' eq 'HEAD', 'close');
112             }
113              
114             # Returns a processed request as a hash, or sends a 400 and closes if invalid.
115             sub get_request {
116 0   0 0 0   $request = { headers => {}, remote_host => $conn->peerhost // 'localhost' };
117 0           $response = { headers => {} };
118 0           my ($request_line, $headers_done, $chunked);
119 0           while (1) {
120 0 0   0     defined(my $line = timeout(sub { $conn->getline })) or last;
  0            
121 0 0         if (!defined $request_line) {
    0          
122 0 0         next if $line eq "\r\n";
123 0           ($request->{method}, $request->{uri}, $request->{version}) = $line =~ /^($method_rx) ($uri_rx) ($version_rx)\r\n/;
124 0 0         return bad_request $line unless defined $request->{method};
125             ($request->{scheme}, $request->{authority}, $request->{path}, $request->{query}, $request->{fragment}) =
126 0           $request->{uri} =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|; # from https://metacpan.org/pod/URI
127 0           $request_line = 1;
128             } elsif (!defined $headers_done) {
129 0 0         if ($line =~ /^\r\n/) {
130 0           $headers_done = 1;
131             } else {
132 0           my ($name, $value) = split /:[ \t]*/, $line, 2;
133 0 0         if ($name =~ /\r\n/) {
134 0           return bad_request $line;
135             }
136 0           $value =~ s/\r\n//;
137 0 0 0       $value = $1 if lc $name eq 'host' and $request->{version} eq 'HTTP/1.1' and $request->{uri} =~ s{^https?://(.+?)/}{/};
      0        
138 0 0         if (exists $request->{headers}{lc $name}) {
139 0 0         if (ref $request->{headers}{lc $name}) {
140 0           push @{$request->{headers}{lc $name}}, $value;
  0            
141             } else {
142 0           $request->{headers}{lc $name} = [$request->{headers}{lc $name}, $value];
143             }
144             } else {
145 0           $request->{headers}{lc $name} = $value;
146             }
147             }
148             }
149 0 0         if (defined $headers_done) {
150 0 0         return if defined $chunked;
151 0   0       info "[$request->{remote_host}] $request->{method} $request->{uri} $request->{version} [", $request->{headers}{'user-agent'} // '', ']';
152 0 0 0       return bad_request 'Host header missing' if $request->{version} eq 'HTTP/1.1' and (!exists $request->{headers}{host} or ref $request->{headers}{host});
      0        
153 0           for (keys %{$request->{headers}}) {
  0            
154 0 0 0       if ($_ eq 'expect' and lc $request->{headers}{$_} eq '100-continue' and $request->{version} eq 'HTTP/1.1') {
    0 0        
    0 0        
155 0           $conn->print("HTTP/1.1 100 Continue\r\n\r\n"); # this does not check if route is valid. just here to comply.
156             } elsif ($_ eq 'content-length') {
157 0     0     timeout(sub { $conn->read($request->{body}, $request->{headers}{$_}) });
  0            
158 0           last;
159             } elsif ($_ eq 'transfer-encoding' and lc $request->{headers}{$_} eq 'chunked') {
160 0           my $length = my $offset = $chunked = 0;
161 0           do {
162 0     0     $_ = timeout(sub { $conn->getline });
  0            
163 0           $length = hex((/^([A-Fa-f0-9]+)(?:;.*)?\r\n/)[0]);
164 0 0   0     timeout(sub { $conn->read($request->{body}, $length + 2, $offset) }) if $length;
  0            
165 0           $offset += $length;
166             } while $length;
167 0           $request->{body} =~ s/\r\n$//;
168 0           undef $headers_done; # to get optional footers, and another blank line
169             }
170             }
171 0 0         last if defined $headers_done;
172             }
173             }
174             }
175              
176             # Finds and calls the appropriate route sub, or sends a 404 response.
177             sub handle_request {
178 0     0 0   my $head = 1;
179 0 0 0       (defined $request->{method} and $request->{method} eq 'HEAD') ? ($request->{method} = 'GET') : ($head = 0);
180 0 0 0       if (defined $request->{method} and exists $route->{$request->{method}}) {
181 0           for (my $i = 0; $i < @{$route->{$request->{method}}}; $i += 2) {
  0            
182 0 0 0       if ($route->{$request->{method}}[$i] eq $request->{path} ||
      0        
183             ref $route->{$request->{method}}[$i] eq 'Regexp' and $request->{path} =~ $route->{$request->{method}}[$i]) {
184 0           $response->{body} = & { $route->{$request->{method}}[$i+1] };
  0            
185 0           return send_response($head);
186             }
187             }
188             }
189 0           $response->{body} = 'This is the void';
190 0           $response->{status} = 404;
191 0           send_response($head);
192             }
193              
194             # Sends a response to client. Default status is 200.
195             sub send_response {
196 0     0 0   my ($head, $connection) = @_;
197             $connection //= (($request->{version} // '') eq 'HTTP/1.1')
198             ? lc($request->{headers}{connection} // '')
199 0 0 0       : lc($request->{headers}{connection} // 'close') eq 'keep-alive' ? 'keep-alive' : 'close';
    0 0        
      0        
      0        
200 0   0       $response->{status} //= 200;
201 0           $response->{headers}{Date} = rfc1123date();
202 0 0 0       if (defined $response->{body} and !ref $response->{body}) {
203 0   0       $response->{headers}{'Content-Length'} //= length $response->{body};
204 0   0       $response->{headers}{'Content-Type'} //= 'text/plain';
205             }
206 0 0 0       delete $response->{body} if $head // 0;
207 0 0 0       $response->{headers}{Connection} = $connection if $connection eq 'close' or ($connection eq 'keep-alive' and $request->{version} ne 'HTTP/1.1');
      0        
208 0   0       $response->{headers}{Server} = 'limper/' . ($Limper::VERSION // 'pre-release');
209 0           $_->($request, $response) for @{$hook->{after}};
  0            
210 0 0         return $hook->{response_handler}[0]->() if exists $hook->{response_handler};
211             {
212 0           local $\ = "\r\n";
  0            
213 0   0       $conn->print(join ' ', $request->{version} // 'HTTP/1.1', $response->{status}, $response->{reason} // $reasons->{$response->{status}});
      0        
214 0 0         return unless $conn->connected;
215 0           my @headers = headers();
216 0           $conn->print( join(': ', splice(@headers, 0, 2)) ) while @headers;
217 0           $conn->print();
218             }
219 0 0 0       $conn->print($response->{body} // '') if defined $response->{body};
220 0 0         $conn->close if $connection eq 'close';
221             }
222              
223             sub status {
224 0 0   0 1   if (defined wantarray) {
225 0 0         wantarray ? ($response->{status}, $response->{reason}) : $response->{status};
226             } else {
227 0           $response->{status} = shift;
228 0 0         $response->{reason} = shift if @_;
229             }
230             }
231              
232             sub headers {
233 0 0   0 1   if (!defined wantarray) {
234 0           $response->{headers}{+pop} = pop while @_;
235             } else {
236 0           my @headers;
237 0           for my $key (keys %{ $response->{headers} }) {
  0            
238 0 0         if (ref $response->{headers}{$key}) {
239 0           push @headers, $key, $_ for @{$response->{headers}{$key}};
  0            
240             } else {
241 0           push @headers, $key, $response->{headers}{$key};
242             }
243             }
244 0           @headers;
245             }
246             }
247              
248 0     0 1   sub request { $request }
249              
250 0     0 1   sub response { $response }
251              
252 0     0 1   sub config { $config }
253              
254 0     0 1   sub hook { push @{$hook->{$_[0]}}, $_[1] }
  0            
255              
256             sub limp {
257 0 0   0 1   $config = shift @_ if ref $_[0] eq 'HASH';
258 0 0         return $hook->{request_handler}[0] if exists $hook->{request_handler};
259 0 0         my $sock = IO::Socket::INET->new(Listen => SOMAXCONN, ReuseAddr => 1, LocalAddr => 'localhost', LocalPort => 8080, Proto => 'tcp', @_)
260             or die "cannot bind to port: $!";
261              
262 0           info 'limper started';
263              
264 0   0       for (1 .. $config->{workers} // 5) {
265 0 0         defined(my $pid = fork) or die "fork failed: $!";
266 0           while (!$pid) {
267 0 0         if ($conn = $sock->accept()) {
268 0           do {
269 0           eval {
270 0           get_request;
271 0 0         handle_request if $conn->connected;
272             };
273 0 0         if ($@) {
274 0 0 0       $response = { status => 500, body => $config->{debug} // 0 ? $@ : 'Internal Server Error' };
275 0           send_response 0, 'close';
276 0           warning $@;
277             }
278             } while ($conn->connected);
279             }
280             }
281             }
282 0           1 while (wait != -1);
283              
284 0           my $shutdown = $sock->shutdown(2);
285 0           my $closed = $sock->close();
286 0 0         info 'shutdown ', $shutdown ? 'successful' : 'unsuccessful';
287 0 0         info 'closed ', $closed ? 'successful' : 'unsuccessful';
288             }
289              
290             1;
291              
292             __END__