|  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__
  |