line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Business::Stripe::Webhook;
|
2
|
|
|
|
|
|
|
|
3
|
5
|
|
|
5
|
|
356105
|
use JSON::PP;
|
|
5
|
|
|
|
|
87172
|
|
|
5
|
|
|
|
|
383
|
|
4
|
5
|
|
|
5
|
|
2173
|
use Digest::SHA qw(hmac_sha256_hex);
|
|
5
|
|
|
|
|
12645
|
|
|
5
|
|
|
|
|
350
|
|
5
|
5
|
|
|
5
|
|
2851
|
use Time::Piece;
|
|
5
|
|
|
|
|
49243
|
|
|
5
|
|
|
|
|
21
|
|
6
|
5
|
|
|
5
|
|
4178
|
use HTTP::Tiny;
|
|
5
|
|
|
|
|
254440
|
|
|
5
|
|
|
|
|
223
|
|
7
|
|
|
|
|
|
|
|
8
|
5
|
|
|
5
|
|
43
|
use strict;
|
|
5
|
|
|
|
|
15
|
|
|
5
|
|
|
|
|
121
|
|
9
|
5
|
|
|
5
|
|
27
|
use warnings;
|
|
5
|
|
|
|
|
16
|
|
|
5
|
|
|
|
|
6541
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
our $VERSION = '1.12';
|
12
|
|
|
|
|
|
|
$VERSION = eval $VERSION;
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
sub new {
|
15
|
8
|
|
|
8
|
1
|
1979
|
my $class = shift;
|
16
|
8
|
|
|
|
|
82
|
my %vars = @_;
|
17
|
|
|
|
|
|
|
|
18
|
8
|
|
|
|
|
33
|
$vars{'error'} = '';
|
19
|
|
|
|
|
|
|
|
20
|
8
|
|
|
|
|
41
|
$vars{'reply'} = {
|
21
|
|
|
|
|
|
|
'status' => 'noaction',
|
22
|
|
|
|
|
|
|
'sent_to' => [ ],
|
23
|
|
|
|
|
|
|
'sent_to_all' => 'false',
|
24
|
|
|
|
|
|
|
};
|
25
|
|
|
|
|
|
|
|
26
|
8
|
100
|
|
|
|
31
|
if (exists $vars{'payload'}) {
|
27
|
5
|
|
|
|
|
11
|
$vars{'webhook'} = eval { decode_json($vars{'payload'});};
|
|
5
|
|
|
|
|
22
|
|
28
|
5
|
100
|
|
|
|
138329
|
$vars{'error'} = 'Missing payload data' unless $vars{'webhook'};
|
29
|
|
|
|
|
|
|
} else {
|
30
|
|
|
|
|
|
|
# Obtaining payload from STDIN only
|
31
|
|
|
|
|
|
|
# exists for backward compatability
|
32
|
|
|
|
|
|
|
# This option is deprecated and will
|
33
|
|
|
|
|
|
|
# be removed in a future version
|
34
|
3
|
100
|
|
|
|
10
|
if (exists $ENV{'GATEWAY_INTERFACE'}) {
|
35
|
2
|
|
|
|
|
47
|
read(STDIN, $vars{'payload'}, $ENV{'CONTENT_LENGTH'});
|
36
|
2
|
100
|
|
|
|
18
|
$vars{'webhook'} = decode_json($vars{'payload'}) if $vars{'payload'};
|
37
|
2
|
100
|
|
|
|
43027
|
$vars{'error'} = 'No payload data' unless $vars{'webhook'};
|
38
|
|
|
|
|
|
|
} else {
|
39
|
1
|
|
|
|
|
3
|
$vars{'error'} = 'Looks like this is not a web request!';
|
40
|
|
|
|
|
|
|
}
|
41
|
|
|
|
|
|
|
}
|
42
|
|
|
|
|
|
|
|
43
|
8
|
|
|
|
|
47
|
return bless \%vars, $class;
|
44
|
|
|
|
|
|
|
}
|
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Returns true if last operation was success
|
47
|
|
|
|
|
|
|
sub success {
|
48
|
9
|
|
|
9
|
1
|
640
|
my $self = shift;
|
49
|
9
|
|
|
|
|
60
|
return !$self->{'error'};
|
50
|
|
|
|
|
|
|
}
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
# Returns error if last operation failed
|
53
|
|
|
|
|
|
|
sub error {
|
54
|
4
|
|
|
4
|
1
|
14
|
my $self = shift;
|
55
|
4
|
|
|
|
|
21
|
return $self->{'error'};
|
56
|
|
|
|
|
|
|
}
|
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# Deal with webhook calls
|
59
|
|
|
|
|
|
|
sub process {
|
60
|
6
|
|
|
6
|
1
|
33
|
my $self = shift;
|
61
|
|
|
|
|
|
|
|
62
|
6
|
|
|
|
|
25
|
$self->{'error'} = '';
|
63
|
|
|
|
|
|
|
|
64
|
6
|
50
|
|
|
|
24
|
if (!defined $self->{'payload'}) {
|
65
|
0
|
|
|
|
|
0
|
$self->_error("No payload to process");
|
66
|
0
|
|
|
|
|
0
|
return undef;
|
67
|
|
|
|
|
|
|
}
|
68
|
|
|
|
|
|
|
|
69
|
6
|
100
|
|
|
|
39
|
if (!$ENV{'HTTP_STRIPE_SIGNATURE'}) {
|
70
|
1
|
|
|
|
|
16
|
$self->_warning('Stripe-Signature HTTP heading missing - the request is not from Stripe');
|
71
|
1
|
|
|
|
|
67
|
return undef;
|
72
|
|
|
|
|
|
|
}
|
73
|
|
|
|
|
|
|
|
74
|
5
|
100
|
|
|
|
18
|
if ($self->{'signing_secret'}) {
|
75
|
3
|
|
|
|
|
15
|
my $sig = $self->check_signature;
|
76
|
3
|
50
|
|
|
|
10
|
return undef unless defined $sig;
|
77
|
3
|
100
|
|
|
|
10
|
if (!$sig) {
|
78
|
2
|
|
|
|
|
11
|
$self->_error('Invalid Stripe Signature');
|
79
|
2
|
|
|
|
|
136
|
return undef;
|
80
|
|
|
|
|
|
|
}
|
81
|
|
|
|
|
|
|
}
|
82
|
|
|
|
|
|
|
|
83
|
3
|
|
|
|
|
10
|
my $hook_type = $self->{'webhook'}->{'type'};
|
84
|
|
|
|
|
|
|
|
85
|
3
|
50
|
|
|
|
18
|
if (!$hook_type) {
|
86
|
0
|
|
|
|
|
0
|
$self->_error("Invalid webhook payload");
|
87
|
0
|
|
|
|
|
0
|
return undef;
|
88
|
|
|
|
|
|
|
}
|
89
|
|
|
|
|
|
|
|
90
|
3
|
|
|
|
|
22
|
$hook_type =~ s/\./-/g;
|
91
|
3
|
50
|
|
|
|
15
|
if (exists $self->{$hook_type}) {
|
92
|
3
|
|
|
|
|
10
|
$self->{'reply'}->{'status'} = 'success';
|
93
|
3
|
|
|
|
|
7
|
push @{$self->{'reply'}->{'sent_to'}}, $hook_type;
|
|
3
|
|
|
|
|
14
|
|
94
|
3
|
|
|
|
|
6
|
&{$self->{$hook_type}}($self->{'webhook'});
|
|
3
|
|
|
|
|
12
|
|
95
|
|
|
|
|
|
|
}
|
96
|
|
|
|
|
|
|
|
97
|
3
|
50
|
|
|
|
1954
|
if (exists $self->{'all-webhooks'}) {
|
98
|
0
|
|
|
|
|
0
|
$self->{'reply'}->{'sent_to_all'} = 'true';
|
99
|
0
|
|
|
|
|
0
|
&{$self->{'all-webhooks'}}($self->{'webhook'});
|
|
0
|
|
|
|
|
0
|
|
100
|
|
|
|
|
|
|
}
|
101
|
|
|
|
|
|
|
|
102
|
3
|
|
|
|
|
12
|
$self->{'reply'}->{'type'} = $self->{'webhook'}->{'type'};
|
103
|
|
|
|
|
|
|
|
104
|
3
|
|
|
|
|
9
|
return $self->{'reply'};
|
105
|
|
|
|
|
|
|
}
|
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# Check for correct Stripe Signature
|
108
|
|
|
|
|
|
|
sub check_signature {
|
109
|
3
|
|
|
3
|
1
|
8
|
my $self = shift;
|
110
|
|
|
|
|
|
|
|
111
|
3
|
|
|
|
|
11
|
$self->{'error'} = '';
|
112
|
|
|
|
|
|
|
|
113
|
3
|
50
|
|
|
|
17
|
if (!$self->{'signing_secret'}) {
|
114
|
0
|
|
|
|
|
0
|
$self->_warning('No signing secret has been supplied');
|
115
|
0
|
|
|
|
|
0
|
return undef;
|
116
|
|
|
|
|
|
|
}
|
117
|
3
|
50
|
|
|
|
12
|
if (!$ENV{'HTTP_STRIPE_SIGNATURE'}) {
|
118
|
0
|
|
|
|
|
0
|
$self->_warning('Stripe-Signature HTTP heading missing');
|
119
|
0
|
|
|
|
|
0
|
return undef;
|
120
|
|
|
|
|
|
|
}
|
121
|
|
|
|
|
|
|
|
122
|
3
|
|
|
|
|
48
|
my %sig_head = ($ENV{'HTTP_STRIPE_SIGNATURE'} . ',') =~ /(\S+?)=(\S+?),/g;
|
123
|
3
|
|
|
|
|
46
|
my $signed_payload = $sig_head{'t'} . '.' . $self->{'payload'};
|
124
|
|
|
|
|
|
|
|
125
|
3
|
50
|
|
|
|
17
|
if (!defined $sig_head{'v1'}) {
|
126
|
0
|
|
|
|
|
0
|
$self->_error("No v1");
|
127
|
0
|
|
|
|
|
0
|
return undef;
|
128
|
|
|
|
|
|
|
}
|
129
|
|
|
|
|
|
|
|
130
|
3
|
100
|
|
|
|
121
|
if (hmac_sha256_hex($signed_payload, $self->{'signing_secret'}) eq $sig_head{'v1'}) {
|
131
|
1
|
|
|
|
|
5
|
return 1;
|
132
|
|
|
|
|
|
|
}
|
133
|
2
|
|
|
|
|
9
|
return 0;
|
134
|
|
|
|
|
|
|
}
|
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# Send reply to Stripe
|
137
|
|
|
|
|
|
|
sub reply {
|
138
|
0
|
|
|
0
|
1
|
0
|
my $self = shift;
|
139
|
0
|
|
|
|
|
0
|
my %keys = @_;
|
140
|
|
|
|
|
|
|
|
141
|
0
|
|
|
|
|
0
|
$self->{'reply'}->{'timestamp'} = localtime->datetime;
|
142
|
0
|
0
|
|
|
|
0
|
if ($self->{'error'}) {
|
143
|
0
|
|
|
|
|
0
|
$self->{'reply'}->{'error'} = $self->{'error'};
|
144
|
0
|
|
|
|
|
0
|
$self->{'reply'}->{'status'} = 'failed';
|
145
|
|
|
|
|
|
|
}
|
146
|
|
|
|
|
|
|
|
147
|
0
|
|
|
|
|
0
|
foreach my $key(keys %keys) {
|
148
|
0
|
|
|
|
|
0
|
$self->{'reply'}->{$key} = $keys{$key};
|
149
|
|
|
|
|
|
|
}
|
150
|
|
|
|
|
|
|
|
151
|
0
|
|
|
|
|
0
|
print "Content-type: application/json\n\n";
|
152
|
0
|
|
|
|
|
0
|
print encode_json $self->{'reply'};
|
153
|
0
|
|
|
|
|
0
|
return;
|
154
|
|
|
|
|
|
|
}
|
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
# Retrieve subscription object from Stripe
|
157
|
|
|
|
|
|
|
sub get_subscription {
|
158
|
0
|
|
|
0
|
1
|
0
|
my ($self, $subscription, $secret) = @_;
|
159
|
|
|
|
|
|
|
|
160
|
0
|
0
|
|
|
|
0
|
if (!$subscription) {
|
161
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'Subscription missing';
|
162
|
0
|
|
|
|
|
0
|
$self->_error('Subscription missing');
|
163
|
0
|
|
|
|
|
0
|
return undef;
|
164
|
|
|
|
|
|
|
}
|
165
|
|
|
|
|
|
|
|
166
|
0
|
0
|
|
|
|
0
|
$self->{'api_secret'} = $secret if defined $secret;
|
167
|
|
|
|
|
|
|
|
168
|
0
|
0
|
|
|
|
0
|
if (!$self->{'api_secret'}) {
|
169
|
0
|
|
|
|
|
0
|
$self->{'error'} = 'No Secret Key supplied to fetch subscription';
|
170
|
0
|
|
|
|
|
0
|
return undef;
|
171
|
|
|
|
|
|
|
}
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
my $headers = {
|
174
|
|
|
|
|
|
|
'headers' => {
|
175
|
0
|
|
|
|
|
0
|
'Authorization' => 'Bearer ' . $self->{'api_secret'},
|
176
|
|
|
|
|
|
|
'Stripe-Version' => '2022-11-15',
|
177
|
|
|
|
|
|
|
},
|
178
|
|
|
|
|
|
|
'agent' => "Perl-Business::Stripe::Webhook-v$VERSION",
|
179
|
|
|
|
|
|
|
};
|
180
|
|
|
|
|
|
|
|
181
|
0
|
|
|
|
|
0
|
my $http = HTTP::Tiny->new;
|
182
|
0
|
|
|
|
|
0
|
return $http->get("https://api.stripe.com/v1/subscriptions/$subscription", $headers);
|
183
|
|
|
|
|
|
|
}
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub _error {
|
186
|
2
|
|
|
2
|
|
7
|
my ($self, $message) = @_;
|
187
|
|
|
|
|
|
|
|
188
|
2
|
|
|
|
|
7
|
$self->{'error'} = $message;
|
189
|
2
|
50
|
|
|
|
4
|
if (defined &{$self->{'error'}}) {
|
|
2
|
|
|
|
|
22
|
|
190
|
0
|
|
|
|
|
0
|
&{$self->{'error'}}($message);
|
|
0
|
|
|
|
|
0
|
|
191
|
|
|
|
|
|
|
} else {
|
192
|
2
|
|
|
|
|
51
|
STDERR->print("Stripe Webhook Error: $message\n");
|
193
|
|
|
|
|
|
|
}
|
194
|
|
|
|
|
|
|
}
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub _warning {
|
197
|
1
|
|
|
1
|
|
6
|
my ($self, $message) = @_;
|
198
|
|
|
|
|
|
|
|
199
|
1
|
50
|
33
|
|
|
7
|
return if $self->{'warning'} and $self->{'warning'} =~ /^nowarn/i;
|
200
|
1
|
|
|
|
|
17
|
$self->{'error'} = $message;
|
201
|
1
|
50
|
|
|
|
4
|
if (defined $self->{'warning'}) {
|
202
|
0
|
|
|
|
|
0
|
&{$self->{'warning'}}($message);
|
|
0
|
|
|
|
|
0
|
|
203
|
|
|
|
|
|
|
} else {
|
204
|
1
|
|
|
|
|
45
|
STDERR->print("Stripe Webhook Warning: $message\n");
|
205
|
|
|
|
|
|
|
}
|
206
|
|
|
|
|
|
|
}
|
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
__END__
|