File Coverage

blib/lib/Terse.pm
Criterion Covered Total %
statement 194 280 69.2
branch 87 152 57.2
condition 47 98 47.9
subroutine 32 38 84.2
pod 9 11 81.8
total 369 579 63.7


line stmt bran cond sub pod time code
1             package Terse;
2             our $VERSION = '0.20';
3 13     13   3460576 use 5.006;
  13         100  
4 13     13   81 use strict;
  13         29  
  13         309  
5 13     13   71 use warnings;
  13         29  
  13         371  
6 13     13   68 no warnings 'redefine';
  13         26  
  13         500  
7 13     13   7093 use Plack::Request;
  13         1117714  
  13         517  
8 13     13   6134 use Plack::Response;
  13         24432  
  13         430  
9 13     13   110 use Cpanel::JSON::XS;
  13         25  
  13         866  
10 13     13   95 use Scalar::Util qw/reftype/;
  13         25  
  13         644  
11 13     13   7330 use Time::HiRes qw(gettimeofday);
  13         18902  
  13         72  
12 13     13   8722 use Terse::WebSocket;
  13         37  
  13         479  
13 13     13   6625 use Want qw/want/;
  13         25218  
  13         814  
14 13     13   7354 use Digest::SHA;
  13         40758  
  13         676  
15 13     13   90 use URI;
  13         28  
  13         644  
16 13     13   6573 use Struct::WOP qw/all/ => { type => ['UTF-8'], destruct => 1 };
  13         19508  
  13         155  
17              
18             our ($JSON, %PRIVATE);
19             BEGIN {
20 13     13   1866 $JSON = Cpanel::JSON::XS->new->utf8->canonical(1)->allow_blessed->convert_blessed;
21             %PRIVATE = (
22 13         44 map { $_ => 1 }
  221         47863  
23             qw/new run logger logInfo logError websocket delayed_response build_terse content_type raiseError graft pretty serialize DESTROY TO_JSON AUTOLOAD to_app/
24             );
25             }
26              
27             sub new {
28 44     44 1 24409 my ($pkg, %args) = @_;
29            
30 44 50       151 $pkg = ref $pkg if ref $pkg;
31            
32 44 100       124 if (delete $args{private}) {
33 6         28 for my $key (keys %args) {
34 41 50       84 if ($key !~ m/^_/) {
35 41         91 $args{"_$key"} = delete $args{$key};
36             }
37             }
38             }
39              
40 44         252 return bless \%args, $pkg;
41             }
42              
43             sub run {
44 3     3 1 6594 my ($pkg, %args) = @_;
45              
46 3         15 my $j = $pkg->new(
47             private => 1,
48             login => 'login',
49             logout => 'logout',
50             auth => 'auth',
51             insecure_session => 0,
52             content_type => 'application/json',
53             request_class => 'Plack::Request',
54             websocket_class => 'Terse::WebSocket',
55             sock => 'psgix.io',
56             stream_check => 'psgi.streaming',
57             favicon => 'favicon.ico',
58             %args
59             );
60              
61 3         20 $j->headers = {};
62              
63 3         10 $j->_build_terse();
64            
65 3         15 $j->request = $j->{_request_class}->new($args{plack_env});
66 3         15 $j->response = $pkg->new(
67             authenticated => \0,
68             error => \0,
69             errors => [],
70             );
71            
72 3 50       16 if ($j->request->env->{PATH_INFO} =~ m/favicon.ico$/) {
73 0 0       0 return [500, [], []] unless -f $j->_favicon;
74 0         0 open my $fh, '<', $j->_favicon;
75 0         0 my $favicon = do { local $/; <$fh> };
  0         0  
  0         0  
76 0         0 close $fh;
77 0         0 return [200, ['Content-Type', 'image/vnd.microsoft.icon'], [$favicon] ];
78             }
79              
80 3         24 my $content_type = $j->request->content_type;
81 3 50 33     25 if ($content_type && $content_type =~ m/application\/json/) {
82 0   0     0 $j->graft('params', $j->request->raw_body || "{}");
83             } else {
84 3 50       5 $j->params = {%{$j->request->parameters || {}}};
  3         11  
85             }
86              
87 3 50 50     18 unless ((reftype($j->params) || "") eq 'HASH') {
88 0         0 $j->response->raiseError('Invalid parameters', 400);
89 0         0 return $j->_response($j->response);
90             }
91            
92 3         11 $j->sid = $j->request->cookies->{sid};
93            
94 3 50       12 unless ($j->sid) {
95 0         0 my $h = Digest::SHA->new(256);
96 0         0 my @us = gettimeofday;
97 0         0 push @us, map { $j->request->env->{$_} } grep {
98 0         0 $_ =~ /^HTTP(?:_|$)/;
99 0         0 } keys %{ $j->request->env };
  0         0  
100 0         0 $h->add(@us);
101 0         0 $j->sid = $h->hexdigest;
102             }
103              
104             $j->sid = {
105             value => $j->is_logout ? "" : $j->sid,
106             path => $j->{_sid_path} || $j->{_root_path} || "/",
107             secure => !$j->{_insecure_session},
108 3 50 50     15 samesite => 'none'
109             };
110              
111 3         11 my $auth = $j->{_auth};
112              
113 3         15 my ($session) = $j->_dispatch($auth, $pkg->new());
114            
115 3         14 my $req = $j->params->req;
116 3 50 50     17 $req =~ /^([a-z][0-9a-zA-Z_]{1,31})$/ && do { $req = $1 // '' } if $req;
  3   33     11  
117 3 50       17 $req = $j->{_application}->preprocess_req($req, $j) if $j->{_application}->can('preprocess_req');
118 3 50 33     75 if (!$req || !$session || $PRIVATE{$req}) {
      33        
119 0         0 $j->response->raiseError('Invalid request', 400);
120 0         0 return $j->_response($j->response);
121             }
122              
123 3         14 $j->req = $req;
124 3         11 $j->response->authenticated = \1;
125 3         14 $j->session = $session;
126              
127 3 50 33     14 $j->sid->expires = (ref $j->session && $j->session->expires) || (time + 24 * 60 * 60)
128             if (!$j->sid->expires);
129              
130             ($j->is_login, $j->is_logout) = (
131             $j->{_login} eq $req,
132 3         30 $j->{_logout} eq $req
133             );
134              
135 3         14 my ($out) = $j->_dispatch($req);
136            
137 3 100       17 return $j->_response($j->response) if $j->response->error;
138              
139 2 50 33     10 $j->session = $out if ( $j->is_login || $j->is_logout );
140              
141 2 100       29 ($j->session) = $j->_dispatch($auth, $j->session) if $j->response->authenticated;
142              
143 2 50 66     9 if ((!$j->response->authenticated || !$j->session) && !($j->is_login || $j->is_logout)) {
      33        
      66        
144 1         6 $j->response->raiseError('Unauthenticated during the request', 400);
145 1         4 return $j->_response($j->response);
146             }
147            
148 1         5 return $j->_response($j->response, $j->sid, $j->content_type);
149             }
150              
151             sub to_app {
152 0     0 0 0 my ($self, $new, $run) = @_;
153 0 0       0 my $app = $self->new($new ? %{ $new } : ());
  0         0  
154             return sub {
155 0     0   0 my ($env) = (shift);
156             Terse->run(
157             plack_env => $env,
158             application => $app,
159 0 0       0 ($env->{'psgix.logger'} ? (logger => $env->{'psgix.logger'}) : ()),
160             );
161 0         0 };
162             };
163            
164             sub logger {
165 4     4 1 5639 my ($self, $logger) = @_;
166 4 100       19 $self->{_logger} = $logger if ($logger);
167 4         14 return $self->{_logger};
168             }
169              
170             sub logError {
171 4     4 1 7657 my ($self, $message, $status, $no_response) = @_;
172             $self->{_application}
173 4 100       34 ? $self->response->raiseError($message, $status)
174             : $self->raiseError($message, $status);
175 4 100       14 $message = { message => $message } if (!ref $message);
176             $message = $self->{_application}->_logError($message, $status)
177 4 100 100     53 if ($self->{_application} && $self->{_application}->can('_logError'));
178             ref $self->{_logger} eq 'CODE'
179             ? $self->{_logger}->('error', $message)
180             : $self->{_logger}->error($message)
181 4 100       32 if $self->{_logger};
    100          
182 4 100       24 $self->response->no_response = 1 if $no_response;
183 4         17 return $self;
184             }
185              
186             sub logInfo {
187 8     8 1 14759 my ($self, $message) = @_;
188 8 50       32 $message = { message => $message } if (!ref $message);
189             $message = $self->{_application}->_logInfo($message)
190 8 100 66     84 if ($self->{_application} && $self->{_application}->can('_logInfo'));
191             ref $self->{_logger} eq 'CODE'
192             ? $self->{_logger}->('info', $message)
193             : $self->{_logger}->info($message)
194 8 100       120 if $self->{_logger};
    100          
195 8         63 return $self;
196             }
197              
198             sub raiseError {
199 6     6 1 31 my ($self, $message, $code) = @_;
200 6 50       16 return $self->response->raiseError($message, $code) if $self->{_application};
201 6         12 $self->{error} = \1;
202 6 50 100     40 if ((reftype($message) || '') eq 'ARRAY') {
203 0         0 push @{$self->{errors}}, @{$message};
  0         0  
  0         0  
204             } else {
205 6         12 push @{$self->{errors}}, $message;
  6         17  
206             }
207 6 50 33     31 $self->{status_code} = $code if ($code && !$self->{status_code});
208 6         9 return $self;
209             }
210              
211             sub graft {
212 5     5 1 474 my ($self, $name, $json) = @_;
213              
214 5 100       31 unless ($json =~ m/[\{\[]/) {
215 1         4 $self->{$name} = $json;
216 1         4 return $self->{$name};
217             }
218              
219 4         8 $self->{$name} = eval {
220 4         40 $JSON->decode($json);
221             };
222              
223 4 100       18 return 0 if $@;
224              
225 3         10 return $self->_bless_tree($self->{$name});
226             }
227              
228 1     1 1 99 sub pretty { $_[0]->{_pretty} = 1; $_[0]; }
  1         4  
229              
230             sub serialize {
231 6     6 1 3460 my ($self, $die) = @_;
232 6   66     59 my $pretty = !!(reftype $self eq 'HASH' && $self->{_pretty});
233 6         12 my $out = eval {
234 6         39 $JSON->pretty($pretty)->encode(maybe_decode($self));
235             };
236 6 50 66     2027 die $@ if ($@ && $die);
237 6   66     50 return $out || $@;
238             }
239              
240             sub _build_terse {
241 3     3   4 my ($t) = @_;
242              
243 3 50       8 if (! $t->{_application}) {
244 0         0 $t->response->raiseError('No application passed to run', 500);
245 0         0 return $t->_response($t->response);
246             }
247              
248             $t->{redirect} = sub {
249 0     0   0 my ($self, $url, $response) = @_;
250 0         0 $url = URI->new($url);
251 0 0       0 $url->query_form( $url->query_form, %{$response || {}});
  0         0  
252 0         0 $self->response->status_code = 302;
253 0         0 $self->response->message = 'Found';
254 0         0 $self->headers->Location = $url->as_string;
255 0         0 return $self;
256 3         16 };
257              
258             $t->{websocket} = sub {
259 0     0   0 my ($self, %args) = @_;
260 0         0 my $websocket = $t->{_websocket_class}->new($self);
261 0 0       0 if (!ref $websocket) {
262 0         0 $args{error}->($t, $websocket);
263 0         0 return;
264             }
265             $t->{_delayed_response} = sub {
266 0         0 my $responder = shift;
267 0         0 $websocket->start($t, \%args, $responder);
268 0         0 };
269 0         0 return $websocket;
270 3 50 33     22 } unless $t->{websocket} || !$t->{_websocket_class};
271              
272             $t->{delayed_response} = sub {
273 0     0   0 my ($self, $response, $sid, $ct, $status) = @_;
274 0   0     0 $sid ||= $self->sid;
275 0   0     0 $status ||= 200;
276 0   0     0 $ct ||= 'application/json';
277             return $self->{_application}->delayed_response_handle(
278             $self, $response, $sid, $ct, $status
279 0 0       0 ) if $self->{_application_has_delayed_response_handler};
280             $self->{_delayed_response} = sub {
281 0         0 my $responder = shift;
282 0         0 my $res = $self->_build_response($sid, $ct, $status);
283 0         0 $res = [splice @{$res->finalize}, 0, 2];
  0         0  
284 0         0 my $writer = $responder->($res);
285 0         0 $response = eval { $response->($writer); };
  0         0  
286 0 0 0     0 if ($@ || $self->response->error) {
    0          
287 0   0     0 $res->[0] = $self->response->status_code || 500;
288 0 0       0 $self->raiseError($@) if $@;
289 0         0 push @{$res}, [$self->response->serialize];
  0         0  
290 0         0 return $responder->($res);
291             }
292             elsif ($response) {
293 0         0 $writer->write($response->serialize);
294             }
295 0         0 $writer->close;
296 0         0 };
297 0         0 $self;
298 3 50       17 } unless $t->{delayed_response};
299              
300 3 50       22 $t->{_application}->build_terse($t) if $t->{_application}->can('build_terse');
301 3         15 $t->{_application_has_dispatcher} = !! $t->{_application}->can('dispatch');
302 3         12 $t->{_application_has_response_handler} = !! $t->{_application}->can('response_handle');
303 3         13 $t->{_application_has_delayed_response_handler} = !! $t->{_application}->can('delayed_response_handle');
304              
305             $t->{_build_response} = sub {
306 3     3   8 my ($self, $sid, $content, $status) = @_;
307 3   66     12 my $res = $self->request->new_response($self->response->{status_code} ||= $status);
308 3 50       91 $res->cookies($self->cookies) if $self->cookies;
309 3 50       16 $res->headers({%{$self->headers}}) if $self->headers;
  3         12  
310 3 100       77 $res->cookies->{sid} = {%{$sid}} if $sid;
  1         8  
311 3         22 $res->content_type($content);
312 3         57 return $res;
313 3 50       30 } unless $t->{_build_response};
314              
315             $t->{content_type} = sub {
316 1 50   1   4 $_[0]->{_content_type} = $_[1] if $_[1];
317 1         7 return $_[0]->{_content_type};
318 3 50       13 } unless $t->{content_type};
319              
320             $t->{_response} = sub {
321 3     3   15 my ($self, $response_body, $sid, $ct, $status) = @_;
322 3 50       8 return $self->{_application}->response_handle(@_) if $self->{_application_has_response_handler};
323 3   100     28 $ct ||= 'application/json';
324 3         8 my $res = $self->{_delayed_response};
325 3 50       7 return $res if ($res);
326 3   50     23 $res = $self->_build_response($sid, $ct, $status || 200);
327 3         11 $res->body($response_body->serialize());
328 3         28 return $res->finalize;
329 3 50       13 } unless $t->{_response};
330              
331             $t->{_dispatch} = sub {
332 7     7   19 my ($self, $method, @params) = @_;
333             my @out = $self->{_application_has_dispatcher} ? eval {
334 0         0 $self->{_application}->dispatch($method, $self, @params)
335 7 50       16 } : eval {
336 7 100       40 unless ($self->{_application}->can($method)) {
337 1         42 $self->response->raiseError('Invalid request - ' . $method, 400);
338 1         3 return;
339             }
340 6         26 $self->{_application}->$method($self, @params);
341             };
342 7 50       24 if ($@) {
343 0         0 $self->response->raiseError(['Error while dispatching the request', $@], 400);
344 0         0 return;
345             }
346 7         22 return @out;
347 3 50       14 } unless $t->{_dispatch};
348            
349 3         5 return $t;
350             }
351              
352             sub _bless_tree {
353 42     42   112 my ($self, $node) = @_;
354 42         71 my $refnode = ref $node;
355 42 100 100     159 return unless $refnode eq 'HASH' || $refnode eq 'ARRAY';
356 20 100       50 if ($refnode eq 'HASH'){
357 18 50       50 bless $node, $node->{_inherit} ? ref $self : __PACKAGE__;
358 18         89 $self->_bless_tree($node->{$_}) for keys %$node;
359             }
360 20 100       53 if ($refnode eq 'ARRAY'){
361 2         13 bless $node, ref $self;
362 2         17 $self->_bless_tree($_) for @$node;
363             }
364 20         43 $node;
365             }
366              
367             sub TO_JSON {
368 0     0 0 0 my $self = shift;
369 0         0 my $ref = reftype $self;
370 0 0 0     0 return $self unless $ref && $ref =~ m/ARRAY|HASH/;
371 0 0       0 return [@$self] if $ref eq 'ARRAY';
372 0 0       0 return 'cannot stringify application object' if $self->{_application};
373 0         0 my $output = {};
374 0         0 my $nodebug = ! $self->{_debug};
375 0         0 for(keys %$self){
376 0         0 my $skip;
377 0 0 0     0 $skip++ if $_ =~ /^_/ && $nodebug;
378 0 0       0 next if $skip;
379 0         0 $output->{$_} = $self->{$_};
380             }
381 0         0 return $output;
382             }
383              
384             sub DESTROY {
385 49     49   55537 my ($self) = @_;
386 49 100       215 (reftype $self eq 'HASH' ? %{$self} : @{$self}) = ();
  47         935  
  2         11  
387             }
388              
389             sub AUTOLOAD : lvalue {
390 178     178   12603 my $classname = ref $_[0];
391 178         235 my $validname = '[_a-zA-Z][\:a-zA-Z0-9_]*';
392 178         1201 our $AUTOLOAD =~ /^${classname}::($validname)$/;
393 178         414 my $key = $1;
394 178 50       350 die "illegal key name, must be of $validname form\n$AUTOLOAD" unless $key;
395 178 100       369 my $miss = Want::want('REF OBJECT') ? {} : '';
396 178         10117 my $retval = $_[0]->{$key};
397 178 100       439 return $retval->(@_) if (ref $retval eq 'CODE');
398 161 50       376 die "illegal use of AUTOLOAD $classname -> $key - too many arguments" if (scalar @_ > 2);
399 161   100     293 my $isBool = Want::want('SCALAR BOOL') && ((reftype($retval) // '') eq 'SCALAR');
400 161 100       12372 return $$retval if $isBool;
401 154   66     657 $_[0]->{$key} = $_[1] // $retval // $miss;
      100        
402 154 100 66     606 $_[0]->_bless_tree($_[0]->{$key}) if ref $_[0]->{$key} eq 'HASH' || ref $_[0]->{$key} eq 'ARRAY';
403 154         705 $_[0]->{$key};
404             }
405              
406             1;
407              
408             __END__