File Coverage

lib/OAuthomatic/Internal/MicroWebSrv.pm
Criterion Covered Total %
statement 1 3 33.3
branch n/a
condition n/a
subroutine 1 1 100.0
pod n/a
total 2 4 50.0


line stmt bran cond sub pod time code
1             package OAuthomatic::Internal::MicroWebSrv;
2             # ABSTRACT: temporary embedded web server used internally - request handling
3              
4              
5 1     1   1044 use namespace::sweep;
  0            
  0            
6             use Moose;
7             use MooseX::AttributeShortcuts;
8             use MooseX::Types::Path::Tiny qw/AbsDir AbsPath/;
9             use Path::Tiny qw/path/;
10             use threads;
11             use Thread::Queue;
12             use HTTP::Server::Brick;
13             use HTTP::Status;
14             use IO::Null;
15             use Template;
16             use OAuthomatic::Internal::Util qw/parse_http_msg_form/;
17              
18             has 'app_name' => (is=>'ro', isa=>'Str', required=>1);
19             has 'site_name' => (is=>'ro', isa=>'Str', required=>1);
20             has 'site_client_creation_page' => (is=>'ro', isa=>'Str', required=>1);
21             has 'site_client_creation_desc' => (is=>'ro', isa=>'Str', required=>1);
22             has 'site_client_creation_help' => (is=>'ro', isa=>'Str', required=>1);
23             has 'static_dir' => (is=>'ro', isa=>AbsDir, required=>1, coerce=>1);
24             has 'template_dir' => (is=>'ro', isa=>AbsDir, required=>1, coerce=>1);
25             has 'port' => (is=>'ro', isa=>'Int', required=>1);
26             has 'callback_path' => (is=>'ro', isa=>'Str', required=>1);
27             has 'client_key_path' => (is=>'ro', isa=>'Str', required=>1);
28             has 'debug' => (is=>'ro', isa=>'Bool', required=>1);
29             has 'verbose' => (is=>'ro', isa=>'Bool', required=>1);
30             has 'oauth_queue' => (is=>'ro', required=>1, clearer=>'_clear_oauth_queue');
31             has 'client_key_queue' => (is=>'ro', required=>1, clearer=>'_clear_client_key_queue');
32              
33             has '_brick' => (is=>'lazy', clearer=>'_clear_brick');
34             has '_template' => (is=>'lazy', clearer=>'_clear_template');
35              
36             sub run {
37             my $self = shift;
38              
39             my $debug = $self->debug;
40              
41             $self->_template; # Not needed but let's fail fast if there are problems
42             my $brick = $self->_brick;
43              
44             $brick->mount($self->callback_path => {
45             handler => sub {
46             return $self->_handle_oauth_request(@_);
47             },
48             wildcard => 1, # let's treat longer urls as erroneous replies
49             });
50             $brick->mount($self->client_key_path => {
51             handler => sub {
52             return $self->_handle_client_key_request(@_);
53             },
54             });
55             $brick->mount("/favicon.ico" => {
56             handler => sub {
57             return RC_NOT_FOUND;
58             },
59             });
60             $brick->mount("/static" => {
61             path => $self->static_dir,
62             });
63             $brick->mount( '/' => {
64             handler => sub {
65             return $self->_handle_generic_request(@_);
66             },
67             wildcard => 1,
68             });
69              
70             print "[OAuthomatic] Embedded web server listens to requests\n" if $debug;
71              
72             # Signalling we started. This queue is as good as any
73             $self->oauth_queue->enqueue({"started" => 1});
74              
75             $brick->start();
76              
77             # Clear variables, just in case.
78             $self->_clear_brick;
79             $self->_clear_template;
80             $self->_clear_oauth_queue;
81             $self->_clear_client_key_queue;
82             undef $brick;
83             undef $self;
84              
85             print "[OAuthomatic] Embedded web server is shut down\n" if $debug;
86              
87             return;
88             }
89              
90             sub _build__template {
91             my $self = shift;
92              
93             my $tt_vars = {
94             app_name => $self->app_name,
95             site_name => $self->site_name,
96             site_client_creation_page => $self->site_client_creation_page,
97             site_client_creation_desc => $self->site_client_creation_desc,
98             site_client_creation_help => $self->site_client_creation_help,
99             static_dir => $self->static_dir,
100             };
101              
102             my $tt = Template->new({
103             INCLUDE_PATH=>[$self->template_dir, $self->static_dir],
104             VARIABLES=>$tt_vars,
105             ($self->debug ? (CACHE_SIZE => 0) : ()), # Disable caching during tests
106             # STRICT=>1,
107             }) or die "Failed to setup templates: $Template::ERROR\n";
108              
109             return $tt;
110             }
111              
112             sub _build__brick {
113             my $self = shift;
114             my @args = (
115             port => $self->port,
116             daemon_args => [ Timeout => 1 ], # To make shutdown faster, Brick's timeout does not work
117             );
118             unless($self->verbose) {
119             my $null = IO::Null->new;
120             push @args, (error_log => $null, access_log => $null);
121             }
122             my $brick = HTTP::Server::Brick->new(@args);
123             # URLs are mounted in run
124             return $brick;
125             }
126              
127             sub _render_template {
128             my ($self, $response, $template_name, $template_params) = @_;
129              
130             my $tt = $self->_template;
131             unless( $tt->process($template_name,
132             $template_params,
133             sub { $response->add_content(@_); }) ) {
134             my $err = $tt->error();
135             # use Data::Dumper; print Dumper($err->info);
136             OAuthomatic::Error::Generic->throw(
137             ident => "Template error",
138             extra => $err->as_string());
139             }
140             return;
141             }
142              
143             sub _handle_oauth_request {
144             my ($self, $req, $resp) = @_;
145              
146             my $params = $req->uri->query_form_hash(); # URI::QueryParam
147              
148             my $verifier = $params->{'oauth_verifier'};
149             my $token = $params->{'oauth_token'};
150              
151             my $reply = {};
152             my $template_name;
153              
154             if ($verifier && $token) {
155             $reply = {
156             verifier => $verifier,
157             token => $token,
158             };
159             $template_name = "oauth_granted.thtml";
160             } else {
161             my $oauth_problem = $params->{'oauth_problem'} || '';
162             $reply->{oauth_problem} = $oauth_problem if $oauth_problem;
163             if($oauth_problem eq 'user_refused') {
164             $template_name = "oauth_rejected.thtml";
165             } else {
166             $template_name = "oauth_bad_request.thtml";
167             }
168             }
169              
170             $self->_render_template($resp, $template_name, $reply);
171              
172             $self->oauth_queue->enqueue($reply);
173              
174             $resp->code(200);
175             return RC_OK;
176             }
177              
178             sub _handle_client_key_request {
179             my ($self, $req, $resp) = @_;
180              
181             unless($req->method eq 'POST') {
182             # Just show input form
183             $self->_render_template($resp, "client_key_entry.thtml", {});
184             } else {
185             my $params = parse_http_msg_form($req) || {};
186              
187             my %values;
188             my %errors;
189             # Validation
190             foreach my $pname (qw(client_key client_secret)) {
191             my $value = $params->{$pname};
192             # Strip leading and final spaces (possible copy&paste)
193             $value =~ s/^[\s\r\n]+//x;
194             $value =~ s/[\s\r\n]+$//x;
195             unless($value) {
196             $errors{$pname} = "Missing value.";
197             } elsif ($value !~ /^\S{10,1000}$/x) {
198             $errors{$pname} = "Invalid value (suspiciously short, too long, or contaning invalid characters)";
199             }
200             $values{$pname} = $value;
201             }
202              
203             unless(%errors) {
204             $self->_render_template($resp, "client_key_submitted.thtml", {});
205             $self->client_key_queue->enqueue(\%values);
206             } else {
207             # Redisplay
208             $self->_render_template($resp, "client_key_entry.thtml", {
209             errors_found => 1,
210             error => \%errors,
211             value => \%values });
212             }
213             }
214              
215             $resp->code(200);
216             return RC_OK;
217             }
218              
219             sub _handle_generic_request {
220             my ($self, $req, $resp) = @_;
221              
222             print "[OAuthomatic] Ignoring as unsupported request to ", $req->uri, "\n" if $self->debug;
223              
224             $self->_render_template($resp, "default.thtml", {});
225              
226             $resp->code(200);
227             return RC_NOT_FOUND;
228             }
229              
230             1;
231              
232             # FIXME: reuse single browser window (maybe frame and some long polling)
233             # FIXME: whole process in browser, without terminal snippets
234              
235             __END__
236              
237             =pod
238              
239             =encoding UTF-8
240              
241             =head1 NAME
242              
243             OAuthomatic::Internal::MicroWebSrv - temporary embedded web server used internally - request handling
244              
245             =head1 VERSION
246              
247             version 0.0201
248              
249             =head1 DESCRIPTION
250              
251             This is actual code of MicroWeb.
252              
253             This object is constructed in separate thread and runs there, rest of
254             the code manages it via L<OAuthomatic::Internal::MicroWeb>.
255              
256             =head1 AUTHOR
257              
258             Marcin Kasperski <Marcin.Kasperski@mekk.waw.pl>
259              
260             =head1 COPYRIGHT AND LICENSE
261              
262             This software is copyright (c) 2015 by Marcin Kasperski.
263              
264             This is free software; you can redistribute it and/or modify it under
265             the same terms as the Perl 5 programming language system itself.
266              
267             =cut