File Coverage

blib/lib/MetaCPAN/Client/Request.pm
Criterion Covered Total %
statement 116 125 92.8
branch 35 58 60.3
condition 8 17 47.0
subroutine 20 20 100.0
pod 3 3 100.0
total 182 223 81.6


line stmt bran cond sub pod time code
1 19     19   137 use strict;
  19         43  
  19         626  
2 19     19   104 use warnings;
  19         38  
  19         824  
3             package MetaCPAN::Client::Request;
4             # ABSTRACT: Object used for making requests to MetaCPAN
5             $MetaCPAN::Client::Request::VERSION = '2.028000';
6 19     19   105 use Moo;
  19         35  
  19         110  
7 19     19   6175 use Carp;
  19         68  
  19         1305  
8 19     19   9157 use JSON::MaybeXS qw;
  19         150499  
  19         1199  
9 19     19   150 use Ref::Util qw< is_arrayref is_hashref is_ref >;
  19         42  
  19         908  
10              
11 19     19   8428 use MetaCPAN::Client::Scroll;
  19         80  
  19         829  
12 19     19   193 use MetaCPAN::Client::Types qw< HashRef Int >;
  19         51  
  19         33607  
13              
14             with 'MetaCPAN::Client::Role::HasUA';
15              
16             has _clientinfo => (
17             is => 'ro',
18             isa => HashRef,
19             lazy => 1,
20             builder => '_build_clientinfo',
21             );
22              
23             has domain => (
24             is => 'ro',
25             default => sub {
26             $ENV{METACPAN_DOMAIN} and return $ENV{METACPAN_DOMAIN};
27             $_[0]->_clientinfo->{production}{domain};
28             },
29             );
30              
31             has base_url => (
32             is => 'ro',
33             lazy => 1,
34             default => sub {
35             $ENV{METACPAN_DOMAIN} and return $ENV{METACPAN_DOMAIN};
36             $_[0]->_clientinfo->{production}{url};
37             },
38             );
39              
40             has _is_agg => (
41             is => 'ro',
42             default => 0,
43             writer => '_set_is_agg'
44             );
45              
46             has debug => (
47             is => 'ro',
48             isa => Int,
49             default => 0,
50             );
51              
52             sub BUILDARGS {
53 21     21 1 54977 my ( $self, %args ) = @_;
54 21 100       148 $args{domain} and $args{base_url} = $args{domain};
55 21         398 return \%args;
56             }
57              
58             sub _build_clientinfo {
59 19     19   297 my $self = shift;
60              
61 19         50 my $info;
62 19 100       47 eval {
63 19         362 $info = $self->ua->get( 'https://clientinfo.metacpan.org' );
64 1         429294 $info = decode_json( $info->{content} );
65 1 50 33     71 is_hashref($info) and exists $info->{production} or die;
66 1         6 1;
67             }
68             or $info = +{
69             production => {
70             url => 'https://fastapi.metacpan.org', # last known production url
71             domain => 'https://fastapi.metacpan.org', # last known production domain
72             }
73             };
74              
75 19         394 return $info;
76             }
77              
78             sub fetch {
79 42     42 1 1557 my $self = shift;
80 42 50       185 my $url = shift or croak 'fetch must be called with a URL parameter';
81 42   100     265 my $params = shift || {};
82 42         134 $url =~ s{^/}{};
83 42         890 my $req_url = sprintf '%s/%s', $self->base_url, $url;
84 42         1353 my $ua = $self->ua;
85              
86 42 100       1510 my $result = keys %{$params}
  42         970  
87             ? $ua->post( $req_url, { content => encode_json $params } )
88             : $ua->get($req_url);
89              
90 42         5722742 return $self->_decode_result( $result, $req_url );
91             }
92              
93             sub ssearch {
94 10     10 1 601 my $self = shift;
95 10         29 my $type = shift;
96 10         26 my $args = shift;
97 10         31 my $params = shift;
98              
99 10   50     84 my $time = delete $params->{'scroller_time'} || '5m';
100 10   50     72 my $size = delete $params->{'scroller_size'} || 1000;
101              
102 10         250 my $scroller = MetaCPAN::Client::Scroll->new(
103             ua => $self->ua,
104             size => $size,
105             time => $time,
106             base_url => $self->base_url,
107             type => $type,
108             body => $self->_build_body($args, $params),
109             debug => $self->debug,
110             );
111              
112 10         1147 return $scroller;
113             }
114              
115             sub _decode_result {
116 42     42   213 my $self = shift;
117 42         139 my $result = shift;
118 42 50       298 my $url = shift or croak 'Second argument of a URL must be provided';
119              
120 42 50       226 is_hashref($result)
121             or croak 'First argument must be hashref';
122              
123 42         215 my $success = $result->{'success'};
124              
125 42 50       183 defined $success
126             or croak 'Missing success in return value';
127              
128             $success
129 42 50       172 or croak "Failed to fetch '$url': " . $result->{'reason'};
130              
131 42 50       811 my $content = $result->{'content'}
132             or croak 'Missing content in return value';
133              
134 42 100       323 $url =~ m|/pod/| and return $content;
135 41 100       224 $url =~ m|/source/| and return $content;
136              
137 40         99 my $decoded_result;
138             eval {
139 40         11038 $decoded_result = decode_json $content;
140 40         262 1;
141 40 50       159 } or do {
142 0         0 croak "Couldn't decode '$content': $@";
143             };
144              
145 40         623 return $decoded_result;
146             }
147              
148             sub _build_body {
149 10     10   405 my $self = shift;
150 10         90 my $args = shift;
151 10         32 my $params = shift;
152              
153             my $query = $args->{__MATCH_ALL__}
154 10 50       82 ? { match_all => {} }
155             : _build_query_rec($args);
156              
157             return +{
158 10         82 query => $query,
159             $self->_read_filters($params),
160             $self->_read_fields($params),
161             $self->_read_aggregations($params),
162             $self->_read_sort($params)
163             };
164             }
165              
166             my %key2es = (
167             all => 'must',
168             either => 'should',
169             not => 'must_not',
170             );
171              
172             sub _read_fields {
173 10     10   27 my $self = shift;
174 10         25 my $params = shift;
175              
176 10         28 my $fields = delete $params->{fields};
177 10         29 my $_source = delete $params->{_source};
178              
179 10         24 my @ret;
180              
181 10 50       47 if ( $fields ) {
182 0 0       0 is_arrayref($fields) or
183             croak "fields must be an arrayref";
184 0         0 push @ret => ( fields => $fields );
185             }
186              
187 10 50       52 if ( $_source ) {
188 0 0 0     0 is_arrayref($_source) or !is_ref($_source) or
189             croak "_source must be an arrayref or a string";
190 0         0 push @ret => ( _source => $_source );
191             }
192              
193 10         54 return @ret;
194             }
195              
196             sub _read_aggregations {
197 10     10   31 my $self = shift;
198 10         27 my $params = shift;
199              
200 10         50 my $aggregations = delete $params->{aggregations};
201 10 50       82 is_ref($aggregations) or return ();
202              
203 0         0 $self->_set_is_agg(1);
204 0         0 return ( aggregations => $aggregations );
205             }
206              
207             sub _read_filters {
208 10     10   31 my $self = shift;
209 10         30 my $params = shift;
210              
211 10         32 my $filter = delete $params->{es_filter};
212 10 50       73 is_ref($filter) or return ();
213              
214 0         0 return ( filter => $filter );
215             }
216              
217             sub _read_sort {
218 10     10   29 my $self = shift;
219 10         33 my $params = shift;
220              
221 10         31 my $sort = delete $params->{sort};
222 10 50       275 is_ref($sort) or return ();
223              
224 0         0 return ( sort => $sort );
225             }
226              
227             sub _build_query_rec {
228 26     26   63 my $args = shift;
229 26 50       81 is_hashref($args) or croak 'query args must be a hash';
230              
231 26         60 my %query = ();
232 26         56 my $basic_element = 1;
233              
234 26         62 KEY: for my $k ( qw/ all either not / ) {
235 78   100     321 my $v = delete $args->{$k} || next KEY;
236 8 50       29 is_hashref($v) and $v = [ $v ];
237 8 50       30 is_arrayref($v) or croak "invalid value for key $k";
238              
239 8         24 undef $basic_element;
240              
241 8         48 $query{'bool'}{ $key2es{$k} } =
242             [ map +( _build_query_rec($_) ), @$v ];
243              
244 8 100       45 $k eq 'either' and $query{'bool'}{'minimum_should_match'} = 1;
245             }
246              
247 26 100       103 $basic_element and %query = %{ _build_query_element($args) };
  19         67  
248              
249 26         175 return \%query;
250             }
251              
252             sub _build_query_element {
253 19     19   43 my $args = shift;
254              
255 19 50       37 scalar keys %{$args} == 1
  19         184  
256             or croak 'Wrong number of keys in query element';
257              
258 19         58 my ($key) = keys %{$args};
  19         71  
259 19         61 my $val = $args->{$key};
260              
261 19 50 33     184 !is_ref($val) and $val =~ /[\w\*]/
262             or croak 'Wrong type of query arguments';
263              
264 19         75 my $wildcard = $val =~ /[*?]/;
265 19 100       84 my $qtype = $wildcard ? 'wildcard' : 'term';
266              
267 19         116 return +{ $qtype => $args };
268             }
269              
270              
271             1;
272              
273             __END__