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   132 use strict;
  19         35  
  19         571  
2 19     19   101 use warnings;
  19         36  
  19         802  
3             package MetaCPAN::Client::Request;
4             # ABSTRACT: Object used for making requests to MetaCPAN
5             $MetaCPAN::Client::Request::VERSION = '2.029000';
6 19     19   109 use Moo;
  19         34  
  19         100  
7 19     19   6387 use Carp;
  19         75  
  19         1363  
8 19     19   9202 use JSON::MaybeXS qw;
  19         153185  
  19         1199  
9 19     19   146 use Ref::Util qw< is_arrayref is_hashref is_ref >;
  19         47  
  19         914  
10              
11 19     19   8512 use MetaCPAN::Client::Scroll;
  19         83  
  19         835  
12 19     19   207 use MetaCPAN::Client::Types qw< HashRef Int >;
  19         43  
  19         33227  
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 53402 my ( $self, %args ) = @_;
54 21 100       121 $args{domain} and $args{base_url} = $args{domain};
55 21         384 return \%args;
56             }
57              
58             sub _build_clientinfo {
59 19     19   269 my $self = shift;
60              
61 19         44 my $info;
62 19 100       49 eval {
63 19         356 $info = $self->ua->get( 'https://clientinfo.metacpan.org' );
64 1         353926 $info = decode_json( $info->{content} );
65 1 50 33     123 is_hashref($info) and exists $info->{production} or die;
66 1         4 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         396 return $info;
76             }
77              
78             sub fetch {
79 44     44 1 1500 my $self = shift;
80 44 50       174 my $url = shift or croak 'fetch must be called with a URL parameter';
81 44   100     248 my $params = shift || {};
82 44         142 $url =~ s{^/}{};
83 44         889 my $req_url = sprintf '%s/%s', $self->base_url, $url;
84 44         1270 my $ua = $self->ua;
85              
86 44 100       1487 my $result = keys %{$params}
  44         1014  
87             ? $ua->post( $req_url, { content => encode_json $params } )
88             : $ua->get($req_url);
89              
90 44         6034967 return $self->_decode_result( $result, $req_url );
91             }
92              
93             sub ssearch {
94 10     10 1 456 my $self = shift;
95 10         30 my $type = shift;
96 10         23 my $args = shift;
97 10         24 my $params = shift;
98              
99 10   50     59 my $time = delete $params->{'scroller_time'} || '5m';
100 10   50     54 my $size = delete $params->{'scroller_size'} || 1000;
101              
102 10         217 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         1046 return $scroller;
113             }
114              
115             sub _decode_result {
116 44     44   220 my $self = shift;
117 44         130 my $result = shift;
118 44 50       293 my $url = shift or croak 'Second argument of a URL must be provided';
119              
120 44 50       256 is_hashref($result)
121             or croak 'First argument must be hashref';
122              
123 44         167 my $success = $result->{'success'};
124              
125 44 50       221 defined $success
126             or croak 'Missing success in return value';
127              
128             $success
129 44 50       183 or croak "Failed to fetch '$url': " . $result->{'reason'};
130              
131 44 50       720 my $content = $result->{'content'}
132             or croak 'Missing content in return value';
133              
134 44 100       292 $url =~ m|/pod/| and return $content;
135 43 100       233 $url =~ m|/source/| and return $content;
136              
137 42         99 my $decoded_result;
138             eval {
139 42         10672 $decoded_result = decode_json $content;
140 42         242 1;
141 42 50       140 } or do {
142 0         0 croak "Couldn't decode '$content': $@";
143             };
144              
145 42         597 return $decoded_result;
146             }
147              
148             sub _build_body {
149 10     10   358 my $self = shift;
150 10         33 my $args = shift;
151 10         40 my $params = shift;
152              
153             my $query = $args->{__MATCH_ALL__}
154 10 50       65 ? { match_all => {} }
155             : _build_query_rec($args);
156              
157             return +{
158 10         54 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         24 my $params = shift;
175              
176 10         30 my $fields = delete $params->{fields};
177 10         28 my $_source = delete $params->{_source};
178              
179 10         24 my @ret;
180              
181 10 50       51 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       35 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         57 return @ret;
194             }
195              
196             sub _read_aggregations {
197 10     10   29 my $self = shift;
198 10         25 my $params = shift;
199              
200 10         26 my $aggregations = delete $params->{aggregations};
201 10 50       64 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   29 my $self = shift;
209 10         33 my $params = shift;
210              
211 10         29 my $filter = delete $params->{es_filter};
212 10 50       65 is_ref($filter) or return ();
213              
214 0         0 return ( filter => $filter );
215             }
216              
217             sub _read_sort {
218 10     10   58 my $self = shift;
219 10         28 my $params = shift;
220              
221 10         30 my $sort = delete $params->{sort};
222 10 50       258 is_ref($sort) or return ();
223              
224 0         0 return ( sort => $sort );
225             }
226              
227             sub _build_query_rec {
228 26     26   59 my $args = shift;
229 26 50       89 is_hashref($args) or croak 'query args must be a hash';
230              
231 26         60 my %query = ();
232 26         54 my $basic_element = 1;
233              
234 26         76 KEY: for my $k ( qw/ all either not / ) {
235 78   100     242 my $v = delete $args->{$k} || next KEY;
236 8 50       26 is_hashref($v) and $v = [ $v ];
237 8 50       27 is_arrayref($v) or croak "invalid value for key $k";
238              
239 8         19 undef $basic_element;
240              
241 8         62 $query{'bool'}{ $key2es{$k} } =
242             [ map +( _build_query_rec($_) ), @$v ];
243              
244 8 100       40 $k eq 'either' and $query{'bool'}{'minimum_should_match'} = 1;
245             }
246              
247 26 100       80 $basic_element and %query = %{ _build_query_element($args) };
  19         73  
248              
249 26         132 return \%query;
250             }
251              
252             sub _build_query_element {
253 19     19   59 my $args = shift;
254              
255 19 50       38 scalar keys %{$args} == 1
  19         102  
256             or croak 'Wrong number of keys in query element';
257              
258 19         51 my ($key) = keys %{$args};
  19         69  
259 19         83 my $val = $args->{$key};
260              
261 19 50 33     190 !is_ref($val) and $val =~ /[\w\*]/
262             or croak 'Wrong type of query arguments';
263              
264 19         72 my $wildcard = $val =~ /[*?]/;
265 19 100       65 my $qtype = $wildcard ? 'wildcard' : 'term';
266              
267 19         109 return +{ $qtype => $args };
268             }
269              
270              
271             1;
272              
273             __END__