1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
|
#!/usr/bin/perl
use strict;
# Modules
use CGI::Carp;
use CGI qw(:standard escapeHTML);
use LWP::UserAgent;
# CGI.pm versioning issue
$CGI::USE_PARAM_SEMICOLONS = 0;
# Revision Notes
# 09/20/01 - initial release
# 10/24/01 - added error emails for flock and seek failures
# 01/09/02 - changed email support to sendmail
# 16/10/09 - Added handling for subscr_cancel IPN message so user will be deleted
# Version Number
# 1.2
# © 2002 PayPal, Inc. and others. All rights reserved.
# This code is subject to the Terms and Conditions in
# the accompanying Beta Software License Agreement
# User Constants - customize these to YOUR installation (see manual)
# -------------------------------------------------------------------
# Set this to the path of your .htpassword file
my $PASSWORD_FILE = '';
# Set this to the path of your processed_txns file
my $TRANSACTION_FILE = '';
# You only need to change this if you are running with https
# see the manual for details
my $PAYPAL_URL = 'http://www.paypal.com/cgi-bin/webscr';
# If you have an initial trial period set it here. For example one
# month would be '1 M'
my $PERIOD1 = '';
# If you have a second trial period set it here. For example one
# month would be '1 M'
my $PERIOD2 = '';
# Set this to your recurring or normal period. For example one
# month would be '1 M'
my $PERIOD3 = '';
# Set this to the dollar amount for your initial trial period. For
# example a free trial would be '0.00'
my $AMOUNT1 = '';
# Set this to the dollar amount for your second trial period. For
# example a $1.00 trial would be '1.00'
my $AMOUNT2 = '';
# Set this to the dollar amount for your recurring or normal period.
# For example $1.00 would be '1.00'
my $AMOUNT3 = '';
# Set this to the path of sendmail. On Linux and FreeBSD systems this
# is typically '/usr/sbin/sendmail', on Solaris systems it is usually
# found at '/usr/lib/sendmail'
my $SENDMAIL_PATH = '';
# Set this to the email address you'd like to have error notification
# messages sent to
my $ADMIN_EMAIL = '';
# Set this to your primary PayPal email address
my @PAYMENT_EMAILS = ('');
# -------------------------------------------------------------------
main();
sub main {
# acknowlege the ipn from PayPal
if (ack_ipn()) {
# decide what to do with msg received
handle_ipn();
}
# IPN was successfully processed
respond(1);
}
sub ack_ipn {
# ack the ipn
my $ua = new LWP::UserAgent;
# build the request
my $req = new HTTP::Request("POST", $PAYPAL_URL);
$req->content_type("application/x-www-form-urlencoded");
$req->content(query_string() . "&cmd=_notify-validate");
# get the response
my $resp = $ua->request($req);
if (($resp->is_success) && ($resp->content eq "VERIFIED")) {
return 1;
} else {
# attempt to identify error
if (($resp->is_success) && ($resp->content eq "INVALID")) {
error_notify("Notification received was NOT from PayPal - Message was ignored.",
"acknowledge IPN", 0, 0);
}
else {
error_notify("Notification could not be acknowledged due to a network or PayPal issue. "
."PayPal will retry until it succeeds.", "acknowledge IPN", 1, 0);
}
return undef;
}
}
sub handle_ipn {
# handle the msg received
if ((param("txn_type") eq "subscr_signup") && (validate_signup())) {
# make sure a username was sent
if (!param("username")) {
error_notify("No username found. Check your subscription button or link.", "add user", 0, 1);
return;
}
# add subscriber to password file
add_user(param("username"), param("password"), param("subscr_id"));
} elsif ((param("txn_type") eq "subscr_eot") || (param("txn_type") eq "subscr_cancel")){
# make sure a username was sent
if (!param("username")) {
error_notify("No username found. Check your subscription button or link.", "remove user", 0, 1);
return;
}
# remove subscriber from password file
remove_user(param("username"));
} else {
# ignore message
}
}
sub validate_signup {
# validate the terms and amounts
if ((param("period1") ne $PERIOD1)
|| (param("period2") ne $PERIOD2)
|| (param("period3") ne $PERIOD3)
|| (param("amount1") ne $AMOUNT1)
|| (param("amount2") ne $AMOUNT2)
|| (param("amount3") ne $AMOUNT3)) {
error_notify("This customer did not sign-up according to your payment terms. " .
"Although payment was accepted the account was not activated.",
"validate subscription terms", 0, 1);
return undef;
}
# validate the receiver email
my $valid = undef;
foreach (@PAYMENT_EMAILS) {
if (param("receiver_email") eq $_) {
$valid = 1;
}
}
if (!$valid)
{
error_notify("An IPN was received that did not match your primary email " .
"address - Message was ignored.",
"validate receiver email ", 0, 0);
return undef;
}
file_open($TRANSACTION_FILE, "+<");
# validate transaction id
if (find_txn(param("subscr_id"))) {
# transaction was previously processed
file_close($TRANSACTION_FILE);
error_notify("An IPN was received that was already processed " .
"- Message was ignored.", "validate subscription id", 0, 0);
return undef;
} else {
file_close($TRANSACTION_FILE);
}
return 1;
}
sub error_notify {
# sends notification that an error has occured
my $err_str = shift;
my $action = shift;
my $kill = shift;
my $req_action = shift;
my $message = "The following error message was generated while trying to $action: \n\t$err_str\n\n\n";
$message .= "User Information\n";
$message .= "\tSubscriber's Username: " . param("username") . "\n";
$message .= "\tSubscriber's Email: " . param("payer_email") . "\n";
$message .= "\tSubscription Number: " . param("subscr_id") . "\n";
$message .= "\tTransaction Type: " . param("txn_type") . "\n";
my $subject = "Subscription Error";
if ($req_action) {
$subject .= " - Requires Action";
} else {
$subject .= " - No Action Required";
}
# if an email is not specified write to error_log only
if (($ADMIN_EMAIL) && ($SENDMAIL_PATH)) {
my %mail = ( To => $ADMIN_EMAIL,
From => $ADMIN_EMAIL,
Subject => $subject,
Message => $message,
);
sendmail(%mail);
}
# put it into the error log
if ($kill) {
# IPN will retry
respond(0);
croak $message;
} else {
carp $message;
}
}
sub sendmail {
# send email using sendmail
my %mail;
my $key;
while (@_) {
$key = shift @_;
$mail{$key} = shift @_;
}
if (!open(SENDMAIL, "|$SENDMAIL_PATH -t")) {
carp "Unable to open sendmail pipe.";
}
print SENDMAIL "To: $mail{'To'}\n";
print SENDMAIL "From: $mail{'From'}\n";
print SENDMAIL "Subject: $mail{'Subject'}\n";
print SENDMAIL "Content-type: text/plain\n\n";
print SENDMAIL "$mail{'Message'}";
if (!close(SENDMAIL)) {
carp "Unable to close sendmail pipe.";
}
}
sub file_open {
my $open_file = shift;
my $open_str = shift;
# open the file
if (!open(FILE, "$open_str$open_file")) {
error_notify("Unable to access: $open_file - $!\n", "open file", 1, 1);
}
# lock access to this file
if (!flock(FILE, 2)) {
error_notify("Unable to get lock on file: $open_file\n", "open file", 1, 1);
}
if (!seek(FILE, 0, 0)) {
error_notify("Unable to seek to the start of the file: $open_file\n", "open file", 1, 1);
}
}
sub file_close {
my $close_file = shift;
# unlock the file
if (!flock(FILE, 8)) {
error_notify("Unable to unlock file: $close_file\n", "close file", 1, 1);
}
if (!close(FILE)) {
error_notify("Unable to close: $close_file - $!\n", "close file", 0, 0);
}
}
sub find_login {
my $new = shift;
my $login;
my $password;
my $remainder;
# for each line, break into parts
while(<FILE>) {
chop;
($login, $password, $remainder) = split(/:/, $_, 3);
if ($login eq $new) {
return 1;
}
}
return undef;
}
sub find_txn {
my $new_txn = shift;
# look for this txn id
while(<FILE>) {
if (/^$new_txn/) {
return 1;
}
}
return undef;
}
sub add_user {
my $login = shift;
my $password = shift;
my $txn = shift;
file_open($PASSWORD_FILE, "+<");
# check to see if this user already exists
if (find_login($login)) {
error_notify("Username: $login already exists", "add user", 0, 1);
} else {
# seek to the end of the file
if (!seek(FILE, 0, 2)) {
error_notify("Unable to seek to the end of the file: $PASSWORD_FILE\n", "add user", 1, 1);
}
# add the necessary line
print FILE "$login\:$password\n";
}
file_close($PASSWORD_FILE);
file_open($TRANSACTION_FILE, "+<");
# seek to the end of the file
if (!seek(FILE, 0, 2)) {
error_notify("Unable to seek to the end of the file: $TRANSACTION_FILE\n", "add user", 1, 1);
}
# add the necessary line
print FILE "$txn\n";
file_close($TRANSACTION_FILE);
}
sub remove_user {
my $login = shift;
my @others;
file_open($PASSWORD_FILE, "+<");
while(<FILE>) {
if (!/^$login\:/) {
# stuff lines into array
push(@others, $_);
}
}
if (@others) {
# seek to start of file
if (!seek(FILE, 0, 0)) {
error_notify("Unable to seek to the start of the file: $PASSWORD_FILE\n", "remove user", 1, 1);
}
# write out all the users
foreach (@others) {
print FILE $_;
}
# truncate the file to the current position
truncate(FILE, tell(FILE));
}
file_close($PASSWORD_FILE);
}
sub respond {
# handle the http reponse
my $is_success = shift;
if ($is_success) {
print header(-status=>('204 No Content'));
}
else {
print header(-status=>('500 Internal Server Error'));
}
} |
Script perl avec plusieurs .htpasswd
Répondre avec citation
Partager