File Coverage

blib/lib/Business/Stripe/WebCheckout.pm
Criterion Covered Total %
statement 123 162 75.9
branch 37 72 51.3
condition 13 33 39.3
subroutine 16 17 94.1
pod 11 11 100.0
total 200 295 67.8


line stmt bran cond sub pod time code
1             package Business::Stripe::WebCheckout;
2            
3             # TODO - Pre release
4             #
5             # TODO - Post release
6             #
7             # 12-04-21 - Improve obtaining success/cancel URLs from environment
8             # 14-04-21 - Add P&P
9             # 16-04-21 - Properly implement live testing without real Stripe keys
10             #
11            
12 4     4   368732 use HTTP::Tiny;
  4         154603  
  4         152  
13 4     4   2492 use JSON::PP;
  4         49028  
  4         287  
14 4     4   2896 use Data::Dumper;
  4         26506  
  4         323  
15            
16 4     4   37 use strict;
  4         10  
  4         96  
17 4     4   24 use warnings;
  4         8  
  4         7553  
18            
19             our $VERSION = '1.0';
20             $VERSION = eval $VERSION;
21            
22             sub new {
23 5     5 1 1662 my $class = shift;
24 5         36 my %attrs = @_;
25            
26 5         12 my @products;
27 5         20 $attrs{'trolley'} = \@products;
28            
29 5   50     47 $attrs{'currency'} //= 'GBP';
30            
31 5         20 $attrs{'error'} = '';
32            
33 5   33     17 $attrs{'cancel-url'} //= "$ENV{'REQUEST_SCHEME'}://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}";
34 5   33     17 $attrs{'success-url'} //= "$ENV{'REQUEST_SCHEME'}://$ENV{'HTTP_HOST'}$ENV{'SCRIPT_NAME'}";
35 5 50 33     33 $attrs{'error'} = 'cancel-url and success-url cannot be derived from the environment and need to be provided' unless ($attrs{'cancel-url'} and $attrs{'success-url'});
36            
37             # This is changed during testing only
38 5   100     30 $attrs{'url'} //= 'https://api.stripe.com/v1/checkout/sessions';
39            
40 5 50 33     71 $attrs{'error'} = 'Public API key provided is not a valid key' if $attrs{'api-public'} and $attrs{'api-public'} !~ /^pk_/;
41 5 50       31 $attrs{'error'} = 'Secret API key provided is not a valid key' unless $attrs{'api-secret'} =~ /^sk_/;
42 5 50 33     30 $attrs{'error'} = 'Secret API key provided as Public key' if $attrs{'api-public'} and $attrs{'api-public'} =~ /^sk_/;
43 5 50       22 $attrs{'error'} = 'Public API key provided as Secret key' if $attrs{'api-secret'} =~ /^pk_/;
44 5 100       22 $attrs{'error'} = 'Secret API key is too short' unless length $attrs{'api-secret'} > 100;
45 5 50       16 $attrs{'error'} = 'Secret API key is missing' unless $attrs{'api-secret'};
46            
47 5         24 return bless \%attrs, $class;
48             }
49            
50             sub success {
51 11     11 1 1574 my $self = shift;
52 11         109 return !$self->{'error'};
53             }
54            
55             sub error {
56 0     0 1 0 my $self = shift;
57 0         0 return $self->{'error'};
58             }
59            
60             sub add_product {
61 4     4 1 24 my ($self, %product) = @_;
62 4         11 $self->{'error'} = '';
63            
64 4 50 33     32 unless ($product{'price'} > 0 and $product{'price'} !~ /\./) {
65 0         0 $self->{'error'} = 'Invalid price. Price is an integer of the lowest currency unit';
66 0         0 return;
67             }
68 4 50 33     29 unless ($product{'qty'} > 0 and $product{'qty'} !~ /\./) {
69 0         0 $self->{'error'} = 'Invalid qty. Qty is a positive integer';
70 0         0 return;
71             }
72            
73 4 50       13 unless ($product{'name'}) {
74 0         0 $self->{'error'} = 'No product name supplied';
75 0         0 return;
76             }
77 4         10 $self->{'intent'} = undef;
78             # Update existing Product by ID
79 4         7 foreach my $prod(@{$self->{'trolley'}}) {
  4         14  
80 3 50       10 if ($prod->{'id'} eq $product{'id'}) {
81 0         0 foreach my $field('name', 'description', 'qty', 'price') {
82 0         0 $prod->{$field} = $product{$field};
83             }
84 0         0 return scalar @{$self->{'trolley'}};
  0         0  
85             }
86             }
87            
88 4         7 my $new_product;
89 4         9 foreach my $field('id', 'name', 'description', 'qty', 'price') {
90 20         45 $new_product->{$field} = $product{$field};
91             }
92 4         7 push @{$self->{'trolley'}}, $new_product;
  4         17  
93             }
94            
95             sub list_products {
96 21     21 1 50 my $self = shift;
97 21         45 my @products;
98 21         30 foreach my $prod(@{$self->{'trolley'}}) {
  21         55  
99 39         77 push @products, $prod->{'id'};
100             }
101 21         94 return @products;
102             }
103            
104             sub get_product {
105 15     15 1 35 my ($self, $id) = @_;
106 15         29 $self->{'error'} = '';
107            
108 15 50       34 unless ($id) {
109 0         0 $self->{'error'} = 'Product ID missing';
110 0         0 return;
111             }
112            
113 15         27 foreach my $prod(@{$self->{'trolley'}}) {
  15         27  
114 30 100       64 if ($prod->{'id'} eq $id) {
115 15         116 return $prod;
116             }
117             }
118 0         0 $self->{'error'} = "Product ID $id not found";
119             }
120            
121             sub delete_product {
122 3     3 1 10 my ($self, $id) = @_;
123 3         8 $self->{'error'} = '';
124            
125 3 50       13 unless ($id) {
126 0         0 $self->{'error'} = 'Product ID missing';
127 0         0 return;
128             }
129            
130 3         8 for (my $i = 0; $i < scalar @{$self->{'trolley'}}; $i++) {
  6         20  
131 5 100       8 if (${$self->{'trolley'}}[$i]->{'id'} eq $id) {
  5         16  
132 2         5 $self->{'intent'} = undef;
133 2         4 splice @{$self->{'trolley'}}, $i, 1;
  2         6  
134 2         5 return scalar @{$self->{'trolley'}};
  2         6  
135             }
136             }
137 1         8 $self->{'error'} = "Product ID $id not found";
138             }
139            
140             # Private method called internally by get_intent and get_intent_id
141             # Attempts to obtain a new session intent from Stripe
142             # Returns existing session if it exists and Trolley hasn't changed
143             sub _create_intent {
144 4     4   12 my $self = shift;
145            
146 4 50       20 if ($self->{'intent'}) {
147 0         0 return $self->{'intent'};
148             }
149            
150 4   100     17 $self->{'reference'} //= __PACKAGE__;
151            
152 4         35 my $http = HTTP::Tiny->new;
153             my $headers = {
154 4         657 'Authorization' => 'Bearer ' . $self->{'api-secret'},
155             };
156            
157             # Update URL and headers during stripe-live tests
158 4 50       25 if ($self->{'url'} =~ /^https:\/\/www\.boddison\.com/) {
159 0         0 $headers->{'BODTEST'} = __PACKAGE__ . " v$VERSION";
160             $headers->{'Authorization'} = undef,
161 0 0       0 $self->{'url'} .= '?fail' if $self->{'api-test-fail'};
162             }
163            
164 4         19 my $vars = {
165             'headers' => $headers,
166             'agent' => 'Perl-WebCheckout/$VERSION'
167             };
168             my $payload = {
169             'cancel_url' => $self->{'cancel-url'},
170             'success_url' => $self->{'success-url'},
171             'payment_method_types[0]' => 'card',
172             'mode' => 'payment',
173 4         34 'client_reference_id' => $self->{'reference'},
174             };
175 4 50       14 $payload->{'customer_email'} = $self->{'email'} if $self->{'email'};
176            
177 4         10 my $i = 0;
178 4         11 foreach my $prod(@{$self->{'trolley'}}) {
  4         21  
179 0         0 $payload->{"line_items[$i][currency]"} = $self->{'currency'};
180 0         0 $payload->{"line_items[$i][name]"} = $prod->{'name'};
181 0 0       0 $payload->{"line_items[$i][description]"} = $prod->{'description'} if $prod->{'description'};
182 0         0 $payload->{"line_items[$i][quantity]"} = $prod->{'qty'};
183 0         0 $payload->{"line_items[$i][amount]"} = $prod->{'price'};
184 0         0 $i++;
185             }
186            
187 4         25 my $response = $http->post_form($self->{'url'}, $payload, $vars);
188            
189 4         549586 $self->{'error'} = '';
190 4 50       26 if ($response->{'success'}) {
191 0         0 $self->{'intent'} = $response->{'content'};
192             } else {
193 4         14 my $content = $response->{'content'};
194 4         13 eval {
195 4         35 $content = decode_json($response->{'content'});
196             };
197 4 50       8608 if ($@) {
198 0         0 $self->{'error'} = $content;
199             } else {
200 4         131 $self->{'error'} = $content->{'error'}->{'message'};
201             }
202             }
203             }
204            
205             sub get_intent {
206 1     1 1 8 my ($self, %attrs) = @_;
207            
208 1 50       11 $self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
209 1 50       8 $self->{'email'} = $attrs{'email'} if $attrs{'email'};
210            
211 1         6 $self->{'error'} = '';
212 1         7 return $self->_create_intent;
213             }
214            
215             sub get_intent_id {
216 3     3 1 12 my ($self, %attrs) = @_;
217            
218 3 50       18 $self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
219 3 50       18 $self->{'email'} = $attrs{'email'} if $attrs{'email'};
220            
221 3         9 $self->{'error'} = '';
222 3         14 my $intent = $self->_create_intent;
223 3 50       1616 if ($self->{'error'}) {
224 3         30 return $intent;
225             } else {
226 0         0 return decode_json($intent)->{'id'};
227             }
228             }
229            
230             sub get_ids {
231 2     2 1 9 my ($self, %attrs) = @_;
232            
233 2 50       17 $self->{'public-key'} = $attrs{'public-key'} if $attrs{'public-key'};
234            
235 2         10 $self->{'error'} = '';
236 2 50       9 unless ($self->{'api-public'}) {
237 0         0 $self->{'error'} = 'Required Public API Key missing';
238 0         0 return;
239             }
240            
241 2 50       7 $self->{'reference'} = $attrs{'reference'} if $attrs{'reference'};
242 2 50       8 $self->{'email'} = $attrs{'email'} if $attrs{'email'};
243            
244 2         9 my $intent_id = $self->get_intent_id;
245            
246 2         8 my %result;
247 2 50       8 if ($self->{'error'}) {
248 2         8 $result{'status'} = 'error';
249 2         7 $result{'message'} = $self->{'error'};
250             } else {
251 0         0 $result{'status'} = 'success';
252 0         0 $result{'api-key'} = $self->{'api-public'};
253 0         0 $result{'session'} = $intent_id;
254             }
255            
256 2 100       11 $attrs{'format'} = 'text' unless $attrs{'format'};
257 2 50       16 return encode_json(\%result) if lc($attrs{'format'}) eq 'json';
258 2   33     14 return $result{'message'} || "$result{'api-key'}:$result{'session'}";
259             }
260            
261             sub checkout {
262 1     1 1 3 my $self = shift;
263            
264 1         6 my $data = $self->get_ids( 'format' => 'text', @_);
265            
266 1 50       9 return if $self->{'error'};
267            
268 0           my ($key, $session) = split /:/, $data;
269            
270 0 0 0       unless ($key and $session) {
271 0           $self->{'error'} = 'Error getting key and session';
272 0           return;
273             }
274            
275 0           return <<"END_HTML";
276             Content-type: text/html
277            
278            
279            
280            
281            
288            
289            
290             END_HTML
291            
292             }
293            
294             1;
295            
296             __END__