File Coverage

blib/lib/Net/HTTP/Knork.pm
Criterion Covered Total %
statement 115 125 92.0
branch 17 28 60.7
condition 8 12 66.6
subroutine 23 25 92.0
pod 1 7 14.2
total 164 197 83.2


line stmt bran cond sub pod time code
1             package Net::HTTP::Knork;
2              
3             # ABSTRACT: Lightweight implementation of Spore specification
4 5     5   392716 use Moo;
  5         48171  
  5         27  
5 5     5   8907 use Sub::Install;
  5         6919  
  5         33  
6 5     5   1367 use Try::Tiny;
  5         1140  
  5         280  
7 5     5   27 use Carp;
  5         8  
  5         230  
8 5     5   2694 use JSON;
  5         40118  
  5         25  
9 5     5   3126 use Data::Rx;
  5         76488  
  5         152  
10 5     5   5162 use LWP::UserAgent;
  5         42288  
  5         136  
11 5     5   25 use URI;
  5         7  
  5         141  
12 5     5   2724 use File::ShareDir ':ALL';
  5         28633  
  5         852  
13 5     5   2534 use Subclass::Of;
  5         36094  
  5         26  
14 5     5   19328 use Net::HTTP::Knork::Request;
  5         19  
  5         197  
15 5     5   40 use Net::HTTP::Knork::Response;
  5         7  
  5         6755  
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 7     7   2023 return $_[0]->spec->{base_url};
32             }
33             );
34              
35             has 'request' => (
36             is => 'rw',
37             lazy => 1,
38             clearer => 1,
39             builder => sub {
40 5     5   1693 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 = from_json(<$fh>);
59             close $fh;
60             }
61             catch {
62             try {
63             $spec = from_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             has 'http_options' => (
94             is => 'rw',
95             default => sub { {} },
96             );
97              
98             # Change the namespace of a given instance, so that there won't be any
99             # method collision between two instances
100              
101             sub BUILD {
102 8     8 0 107 my $self = shift;
103 8         57 my $subclass = subclass_of('Net::HTTP::Knork');
104 8         12192 bless( $self, $subclass );
105 8         51 $self->build_from_spec();
106             }
107              
108             sub _build_client {
109 0     0   0 my $self = shift;
110 0         0 return LWP::UserAgent->new( %{ $self->http_options } );
  0         0  
111             }
112              
113             sub validate_spore {
114 8     8 0 13 my ( $self, $spec ) = @_;
115 8         62 my $rx = Data::Rx->new;
116 8         83005 my $spore_schema;
117 8 50       344 if ( -f $self->spore_rx ) {
118 8         277 open my $fh, "<", $self->spore_rx;
119 8         25 binmode $fh;
120 8         42 local $/ = undef;
121 8         167 $spore_schema = <$fh>;
122 8         83 close $fh;
123             }
124             else {
125 0         0 croak "Spore schema " . $self->spore_rx . " could not be found";
126             }
127 8         44 my $json_schema = from_json($spore_schema);
128 8         493 my $schema = $rx->make_schema($json_schema);
129             try {
130 8     8   349 my $valid = $schema->assert_valid($spec);
131             }
132             catch {
133 0     0   0 croak "Spore specification is invalid, please fix it\n" . $_;
134 8         13253 };
135             }
136              
137             # take a spec and instanciate methods that matches those
138              
139             sub build_from_spec {
140 8     8 0 12 my $self = shift;
141 8         102 my $spec = $self->spec;
142              
143 8         2358 $self->validate_spore($spec);
144 8         9114 my $base_url = $self->base_url;
145 8 50       497 croak
146             'We need a base URL, either in the spec or as a parameter to build_from_spec'
147             unless $base_url;
148 8         53 $self->build_methods();
149             }
150              
151             sub build_methods {
152 8     8 0 14 my $self = shift;
153 8         14 foreach my $method ( keys %{ $self->spec->{methods} } ) {
  8         147  
154 48         2628 my $sub_from_spec =
155             $self->make_sub_from_spec( $self->spec->{methods}->{$method} );
156 48         202 Sub::Install::install_sub(
157             { code => $sub_from_spec,
158             into => ref($self),
159             as => $method,
160             }
161             );
162             }
163             }
164              
165             sub make_sub_from_spec {
166 49     49 1 710 my $reg = shift;
167 49         50 my $meth_spec = shift;
168             return sub {
169 6     6   2465 my $self = shift;
170 6         86 $self->clear_request;
171 6   100     1446 my $ref_param_spec = shift // {};
172 6         11 my %param_spec = %{$ref_param_spec};
  6         23  
173 6 100       44 if ( $self->has_default_params ) {
174 5         7 foreach my $d_param ( keys( %{ $self->default_params } ) ) {
  5         34  
175 1         7 $param_spec{$d_param} = $self->default_params->{$d_param};
176             }
177             }
178 6         12 my %method_args = %{$meth_spec};
  6         24  
179 6         15 my $method = $method_args{method};
180 6 50       23 my $payload =
181             ( defined $param_spec{spore_payload} )
182             ? delete $param_spec{spore_payload}
183             : delete $param_spec{payload};
184              
185 6 50 33     25 if ( $method_args{required_payload} && !$payload ) {
186 0         0 croak "this method requires a payload and no payload is provided";
187             }
188 6 50 66     43 if ( $payload
189             && ( $method !~ /^(?:POST|PUT|PATCH)$/i ) )
190             {
191 0         0 croak "payload requires a PUT, PATCH or POST method";
192             }
193              
194 6   100     21 $payload //= undef;
195              
196 6 100       18 if ( $method_args{required_params} ) {
197 3         6 foreach my $required ( @{ $method_args{required_params} } ) {
  3         10  
198 3 100       8 if ( !grep { $required eq $_ } keys %param_spec ) {
  2         15  
199 1         20 croak
200             "Parameter '$required' is marked as required but is missing";
201             }
202             }
203             }
204              
205 5         8 my $params;
206 5         6 foreach ( @{ $method_args{required_params} } ) {
  5         18  
207 2         9 push @$params, $_, delete $param_spec{$_};
208             }
209              
210 5         7 foreach ( @{ $method_args{optional_params} } ) {
  5         13  
211 2 50       8 push @$params, $_, delete $param_spec{$_}
212             if ( defined( $param_spec{$_} ) );
213             }
214 5 50       13 if (%param_spec) {
215 0 0       0 if ( $self->lax_optionals ) {
216 0         0 foreach ( keys %param_spec ) {
217 0         0 push @$params, $_, delete $param_spec{$_};
218             }
219             }
220             }
221              
222 5         133 my $base_url = URI->new( $self->base_url );
223 5 50 50     26753 my $env = {
224             REQUEST_METHOD => $method,
225             SERVER_NAME => $base_url->host,
226             SERVER_PORT => $base_url->port,
227             SCRIPT_NAME => (
228             $base_url->path eq '/'
229             ? ''
230             : $base_url->path
231             ),
232             PATH_INFO => $method_args{path},
233             REQUEST_URI => '',
234             QUERY_STRING => '',
235             HTTP_USER_AGENT => $self->client->agent // '',
236              
237             'spore.params' => $params,
238             'spore.payload' => $payload,
239             'spore.errors' => *STDERR,
240             'spore.url_scheme' => $base_url->scheme,
241             'spore.userinfo' => $base_url->userinfo,
242              
243             };
244 5         3516 $self->env($env);
245 5         48 my $request = $self->request->finalize();
246 5         96 my $raw_response = $self->perform_request($request);
247 5         902 return $self->generate_response($raw_response);
248 49         252 };
249             }
250              
251              
252             sub perform_request {
253 5     5 0 9 my $self = shift;
254 5         6 my $request = shift;
255 5         146 return $self->client->request($request);
256             }
257              
258             sub generate_response {
259 5     5 0 8 my $self = shift;
260 5         10 my $raw_response = shift;
261 5         6 my $prev_response = shift;
262 5         151 my $knork_response = $self->request->new_response(
263             $raw_response->code, $raw_response->message, $raw_response->headers,
264             $raw_response->content
265             );
266 5 100       18 if ( defined($prev_response) ) {
267 2 50       12 $knork_response->raw_body( $prev_response->content )
268             unless defined( ( $knork_response->raw_body ) );
269             }
270 5         75 return $knork_response;
271             }
272              
273              
274              
275             1;
276              
277             __END__