File Coverage

blib/lib/Net/HTTP/Knork.pm
Criterion Covered Total %
statement 118 127 92.9
branch 21 32 65.6
condition 8 13 61.5
subroutine 23 25 92.0
pod 1 7 14.2
total 171 204 83.8


line stmt bran cond sub pod time code
1             package Net::HTTP::Knork;
2              
3             # ABSTRACT: Lightweight implementation of Spore specification
4 6     6   464094 use Moo;
  6         48851  
  6         29  
5 6     6   9829 use Sub::Install;
  6         7599  
  6         34  
6 6     6   2041 use Try::Tiny;
  6         854  
  6         334  
7 6     6   23 use Carp;
  6         8  
  6         211  
8 6     6   2261 use JSON::MaybeXS;
  6         20718  
  6         307  
9 6     6   2556 use Data::Rx;
  6         80853  
  6         155  
10 6     6   516 use LWP::UserAgent;
  6         31253  
  6         143  
11 6     6   27 use URI;
  6         6  
  6         106  
12 6     6   2716 use File::ShareDir ':ALL';
  6         29676  
  6         1044  
13 6     6   2749 use Subclass::Of;
  6         82152  
  6         33  
14 6     6   3509 use Net::HTTP::Knork::Request;
  6         20  
  6         182  
15 6     6   45 use Net::HTTP::Knork::Response;
  6         8  
  6         7175  
16              
17             with 'Net::HTTP::Knork::Role::Middleware';
18              
19              
20             has 'client' => ( is => 'lazy', );
21              
22             # option that allows one to pass optional parameters that are not specified
23             # in the spore 'optional_params' section for a given method
24              
25             has 'lax_optionals' => ( is => 'rw', default => sub {0} );
26              
27             has 'base_url' => (
28             is => 'rw',
29             lazy => 1,
30             builder => sub {
31 8     8   2414 return $_[0]->spec->{base_url};
32             }
33             );
34              
35             has 'request' => (
36             is => 'rw',
37             lazy => 1,
38             clearer => 1,
39             builder => sub {
40 8     8   1737 return Net::HTTP::Knork::Request->new( $_[0]->env );
41             }
42             );
43              
44             has 'env' => ( is => 'rw', );
45              
46             has 'spec' => (
47             is => 'lazy',
48             required => 1,
49             coerce => sub {
50             my $json_spec = $_[0];
51             my $spec;
52              
53             # it could be a file
54             try {
55             open my $fh, '<', $json_spec or croak 'Cannot read the spec file';
56             local $/ = undef;
57             binmode $fh;
58             $spec = decode_json(<$fh>);
59             close $fh;
60             }
61             catch {
62             try {
63             $spec = decode_json($json_spec);
64             }
65              
66             # it is not json, so we are returning the string as is
67             catch {
68             $spec = $json_spec;
69             };
70             };
71             return $spec;
72             }
73             );
74              
75             has 'default_params' => (
76             is => 'rw',
77             default => sub { {} },
78             predicate => 1,
79             clearer => 1,
80             writer => 'set_default_params',
81             );
82              
83             has 'spore_rx' => (
84             is => 'rw',
85             default => sub {
86             return dist_file(
87             'Net-HTTP-Knork',
88             'config/specs/spore_validation.rx'
89             );
90             }
91             );
92              
93              
94             # Change the namespace of a given instance, so that there won't be any
95             # method collision between two instances
96              
97             sub BUILD {
98 9     9 0 113 my $self = shift;
99 9         55 my $subclass = subclass_of('Net::HTTP::Knork');
100 9         13836 bless( $self, $subclass );
101 9         71 $self->build_from_spec();
102             }
103              
104             sub _build_client {
105 0     0   0 my $self = shift;
106 0         0 return LWP::UserAgent->new();
107             }
108              
109             sub validate_spore {
110 9     9 0 16 my ( $self, $spec ) = @_;
111 9         72 my $rx = Data::Rx->new;
112 9         86496 my $spore_schema;
113 9 50       366 if ( -f $self->spore_rx ) {
114 9         251 open my $fh, "<", $self->spore_rx;
115 9         22 binmode $fh;
116 9         42 local $/ = undef;
117 9         156 $spore_schema = <$fh>;
118 9         96 close $fh;
119             }
120             else {
121 0         0 croak "Spore schema " . $self->spore_rx . " could not be found";
122             }
123 9         343 my $json_schema = decode_json($spore_schema);
124 9         45 my $schema = $rx->make_schema($json_schema);
125             try {
126 9     9   338 my $valid = $schema->assert_valid($spec);
127             }
128             catch {
129 0     0   0 croak "Spore specification is invalid, please fix it\n" . $_;
130 9         12526 };
131             }
132              
133             # take a spec and instanciate methods that matches those
134              
135             sub build_from_spec {
136 9     9 0 17 my $self = shift;
137 9         93 my $spec = $self->spec;
138              
139 9         2730 $self->validate_spore($spec);
140 9         9369 my $base_url = $self->base_url;
141 9 50       454 croak
142             'We need a base URL, either in the spec or as a parameter to build_from_spec'
143             unless $base_url;
144 9         53 $self->build_methods();
145             }
146              
147             sub build_methods {
148 9     9 0 11 my $self = shift;
149 9         14 foreach my $method ( keys %{ $self->spec->{methods} } ) {
  9         142  
150 63         3069 my $sub_from_spec =
151             $self->make_sub_from_spec( $self->spec->{methods}->{$method} );
152 63         228 Sub::Install::install_sub(
153             { code => $sub_from_spec,
154             into => ref($self),
155             as => $method,
156             }
157             );
158             }
159             }
160              
161             sub make_sub_from_spec {
162 64     64 1 820 my $reg = shift;
163 64         58 my $meth_spec = shift;
164             return sub {
165 9     9   3186 my $self = shift;
166 9         122 $self->clear_request;
167              
168 9         1566 my %param_spec;
169 9 100 66     67 if (scalar @_ == 1 and ref($_[0]) eq 'HASH') {
170 4         6 %param_spec = %{ $_[0] };
  4         15  
171             }
172             else {
173 5         13 %param_spec = @_;
174             }
175              
176 9 100       58 if ( $self->has_default_params ) {
177 8         15 foreach my $d_param ( keys( %{ $self->default_params } ) ) {
  8         45  
178 1         4 $param_spec{$d_param} = $self->default_params->{$d_param};
179             }
180             }
181 9         15 my %method_args = %{$meth_spec};
  9         38  
182 9         18 my $method = $method_args{method};
183 9 50       30 my $payload =
184             ( defined $param_spec{spore_payload} )
185             ? delete $param_spec{spore_payload}
186             : delete $param_spec{payload};
187              
188 9 50 33     29 if ( $method_args{required_payload} && !$payload ) {
189 0         0 croak "this method requires a payload and no payload is provided";
190             }
191 9 50 66     58 if ( $payload
192             && ( $method !~ /^(?:POST|PUT|PATCH)$/i ) )
193             {
194 0         0 croak "payload requires a PUT, PATCH or POST method";
195             }
196              
197 9   100     34 $payload //= undef;
198              
199 9 100       22 if ( $method_args{required_params} ) {
200 4         4 foreach my $required ( @{ $method_args{required_params} } ) {
  4         10  
201 4 100       8 if ( !grep { $required eq $_ } keys %param_spec ) {
  3         12  
202 1         19 croak
203             "Parameter '$required' is marked as required but is missing";
204             }
205             }
206             }
207              
208 8         11 my $params;
209 8         12 foreach ( @{ $method_args{required_params} } ) {
  8         21  
210 3         11 push @$params, $_, delete $param_spec{$_};
211             }
212              
213 8         17 foreach ( @{ $method_args{optional_params} } ) {
  8         18  
214 3 50       12 push @$params, $_, delete $param_spec{$_}
215             if ( defined( $param_spec{$_} ) );
216             }
217 8 50       22 if (%param_spec) {
218 0 0       0 if ( $self->lax_optionals ) {
219 0         0 foreach ( keys %param_spec ) {
220 0         0 push @$params, $_, delete $param_spec{$_};
221             }
222             }
223             }
224              
225 8 100       167 my $base_url =
226             ( exists $method_args{base_url} )
227             ? $method_args{base_url}
228             : $self->base_url;
229 8         146 $base_url = URI->new( $base_url );
230 8 50 50     29823 my $env = {
231             REQUEST_METHOD => $method,
232             SERVER_NAME => $base_url->host,
233             SERVER_PORT => $base_url->port,
234             SCRIPT_NAME => (
235             $base_url->path eq '/'
236             ? ''
237             : $base_url->path
238             ),
239             PATH_INFO => $method_args{path},
240             REQUEST_URI => '',
241             QUERY_STRING => '',
242             HTTP_USER_AGENT => $self->client->agent // '',
243              
244             'spore.params' => $params,
245             'spore.payload' => $payload,
246             'spore.errors' => *STDERR,
247             'spore.url_scheme' => $base_url->scheme,
248             'spore.userinfo' => $base_url->userinfo,
249              
250             };
251 8         3789 $self->env($env);
252 8         79 my $request = $self->request->finalize();
253 8         85 my $raw_response = $self->perform_request($request);
254 8         1189 return $self->generate_response($raw_response);
255 64         312 };
256             }
257              
258              
259             sub perform_request {
260 8     8 0 11 my $self = shift;
261 8         13 my $request = shift;
262 8         204 return $self->client->request($request);
263             }
264              
265             sub generate_response {
266 8     8 0 12 my $self = shift;
267 8         12 my $raw_response = shift;
268 8         11 my $orig_response = shift;
269 8         214 my $knork_response = $self->request->new_response(
270             $raw_response->code, $raw_response->message, $raw_response->headers,
271             $raw_response->content
272             );
273 8 100       29 if ( defined($orig_response) ) {
274 2 50       15 $knork_response->raw_body( $orig_response->content )
275             unless defined( ( $knork_response->raw_body ) );
276             }
277 8         90 return $knork_response;
278             }
279              
280              
281              
282             1;
283              
284             __END__