Pm/Security.pm
Copying Source is Forbidden
665 lines of code
1
package Security;
2
3
#/
4
# a module to encapsulate security-related functions
5
#/
6
7
use strict;
8
use warnings;
9
use Exporter;
10
use vars qw($VERSION @ISA @EXPORT_OK @EXPORT);
11
use CGI::Carp qw(fatalsToBrowser);
12
use Crypt::PBKDF2; # this is NOT my code. For details about PBKDF2 visit: https://metacpan.org/pod/Crypt::PBKDF2
13
use LWP::Simple;
14
15
our $pb = Crypt::PBKDF2->new(
16
hash_class => 'HMACSHA3',
17
iterations => 1024*2,
18
output_len => 128,
19
salt_len => 64
20
);
21
22
23
24
################################################################################################
25
################################################################################################
26
################################################################################################
27
28
29
30
$VERSION = 1.00;
31
@ISA = qw(Exporter);
32
@EXPORT = qw(
33
banned
34
login
35
logout
36
password_correct
37
);
38
@EXPORT_OK = qw(
39
_tests
40
41
allowed
42
banned
43
bounced
44
encrypt
45
password_correct
46
password_set
47
get_client_IP
48
get_site_IP
49
get_login
50
login
51
logout
52
count_creations
53
count_visitor
54
count_hits
55
remove_test_accounts
56
57
$pb
58
);
59
60
61
################################################################################################
62
################################################################################################
63
################################################################################################
64
65
66
#use Bc_chef qw(cookie_get cookie_set cookie_delete);
67
#use Bc_misc qw(get_param new_id valid_hex);
68
#use Bc_sql qw($DB $LOGGEDIN sql_execute);
69
#use Date qw(get_date);
70
71
use lib "./Pm";
72
73
require Bc_chef;
74
require Bc_misc;
75
require Bc_sql;
76
require Date;
77
78
79
########################
80
sub count_creations(;$) {
81
#*
82
# to count every visit to the "sign-up page"
83
# does not return a value (unless $rv == 1)
84
#*
85
my ($param) = @_; # a param (optional, default=get_client_IP())
86
if (!$param) { $param = get_client_IP(); }
87
my $rv = 0; # set to 1 to enable debugging, or 0 to disable debugging
88
my $localhost = "127.0.0.1";
89
90
if ($param ne $localhost or $rv eq 1) {
91
92
# is the visitor's IP already in DB?
93
# add it if not, otherwise, increment "count"
94
# and set last visit date to today
95
96
my $sql = "select * from create_visits where IP=" . $Bc_sql::DB->quote($param);
97
my $result = Bc_sql::sql_execute($sql, "security::count_creations() sql failure");
98
my $now = Date::get_date("db");
99
$now =~ s/^ //;
100
101
if (ref $result eq "HASH") {
102
# we have a hit, increment "count" and set the last visit date to today
103
my $count = $result->{count} + 1;
104
my $updatesql = "update create_visits set count=" . $Bc_sql::DB->quote($count) . ",";
105
$updatesql .= " last_visit_date=" . $Bc_sql::DB->quote($now);
106
$updatesql .= " where ID=" . $Bc_sql::DB->quote($result->{ID});
107
108
if ($rv eq 1) { $rv = $updatesql; }
109
110
if (!Bc_sql::sql_execute($updatesql, "security::count_creations().update_visit_count")) {
111
# some error occured! oh dear
112
die "omg, something went horribly awry!";
113
}
114
} else {
115
# we got no hits (which is okay), or 2+ hits (which is BAD)
116
if (@$result > 1) {
117
# too many results...
118
# just ignore this for now, i guess
119
if ($rv eq 1) {
120
$rv = "too many results returned (security::count_creations())";
121
}
122
} else {
123
# no results, so...add the new visitor
124
my $addsql = "insert into create_visits values (NULL, " .
125
$Bc_sql::DB->quote($param) . ", " .
126
"'1', " .
127
$Bc_sql::DB->quote($now) .
128
")";
129
130
if ($rv eq 1) { $rv = $addsql; }
131
132
if (!Bc_sql::sql_execute($addsql, "security::count_creations().add_new_visitor")) {
133
# some error occured! oh dear
134
die "omg, something went horribly awry!";
135
}
136
}
137
}
138
} else {
139
if ($rv eq 1) {
140
$rv = "local host visitor"
141
}
142
}
143
144
if ($rv) {
145
return $rv; # a value is returned if $rv is INITIALLY a 1
146
}
147
#usage: count_creations();
148
}
149
150
########################
151
sub count_visitor(;$) {
152
#*
153
# to count every visit to the "home page" ONLY
154
# does not return a value (unless $rv == 1)
155
#*
156
my ($param) = @_; # a param (optional, default=get_client_IP())
157
if (!$param) { $param = get_client_IP(); }
158
my $rv = 0; # set to 1 to enable debugging, or 0 to disable debugging
159
my $localhost = "127.0.0.1";
160
161
if ($param ne $localhost or $rv eq 1) {
162
163
# is the visitor's IP already in DB?
164
# add it if not, otherwise, increment "count"
165
# and set last visit date to today
166
167
my $sql = "select * from visits where IP=" . $Bc_sql::DB->quote($param);
168
my $result = Bc_sql::sql_execute($sql, "security::count_visitor() sql failure");
169
my $now = Date::get_date("db");
170
$now =~ s/^ //;
171
172
if (ref $result eq "HASH") {
173
# we have a hit, increment "count" and set the last visit date to today
174
my $count = $result->{count} + 1;
175
my $updatesql = "update visits set count=" . $Bc_sql::DB->quote($count) . ",";
176
$updatesql .= " last_visit_date=" . $Bc_sql::DB->quote($now);
177
$updatesql .= " where ID=" . $Bc_sql::DB->quote($result->{ID});
178
179
if ($rv eq 1) { $rv = $updatesql; }
180
181
if (!Bc_sql::sql_execute($updatesql, "security::count_visits().update_visit_count")) {
182
# some error occured! oh dear
183
die "omg, something went horribly awry!";
184
}
185
} else {
186
# we got no hits (or we got lotsa hits, which is BAD and shouldn't have happened!)
187
if (@$result > 1) {
188
# too many results...
189
# just ignore this for now, i guess
190
if ($rv eq 1) {
191
$rv = "too many results returned (security::count_visitor())";
192
}
193
} else {
194
# no results, so...add the new visitor
195
my $addsql = "insert into visits values (";
196
$addsql .= "NULL, ";
197
$addsql .= $Bc_sql::DB->quote($param) . ", ";
198
$addsql .= "'1', ";
199
$addsql .= $Bc_sql::DB->quote($now);
200
$addsql .= ")";
201
202
if ($rv eq 1) { $rv = $addsql; }
203
204
if ($param and !Bc_sql::sql_execute($addsql, "security::count_visits().add_new_visitor")) {
205
# some error occured! oh dear
206
die "omg, something went horribly awry! ($addsql)";
207
}
208
}
209
}
210
} else {
211
if ($rv eq 1) {
212
$rv = "local host visitor"
213
}
214
}
215
216
if ($rv) {
217
return $rv; # a value is returned if $rv is INITIALLY a 1
218
}
219
#usage: count_visitor();
220
}
221
222
########################
223
sub count_hits(;$) {
224
#*
225
# to count every visit to other "pages"
226
# does not return a value (unless $rv != 0)
227
# where $params keys are:
228
# ip = client IP address
229
# url = url client is visiting
230
# debug = toggle debug on/off (sets $rv)
231
#*
232
my ($params) = @_; # a hashref to a list of params (optional)
233
my $rv = 0; # set to 1 to enable debugging, or 0 to disable debugging (default = 0)
234
my $localhost = "127.0.0.1";
235
236
if (ref $params eq "HASH") {
237
if (not $params->{ip}) { $params->{ip} = get_client_IP(); }
238
if (not $params->{url}) { $params->{url} = $ENV{REQUEST_URI}; }
239
if ($params->{debug}) { $rv = 1; }
240
241
if ($params->{ip} ne $localhost or $rv eq 1) {
242
my $sql = "select * from page_visits where" .
243
" IP=" . $Bc_sql::DB->quote($params->{ip}) .
244
" and URL=" . $Bc_sql::DB->quote($params->{url});
245
my $result = Bc_sql::sql_execute($sql, "Security::count_hits->check hit", 1); # returns an array of hash refs
246
# $result will be an array reference.
247
# the array should be zero or one in length only
248
249
if (@$result) {
250
if (@$result == 1) {
251
# this IP visited this URL before
252
my $updatesql = "update page_visits set" .
253
" count=" . $Bc_sql::DB->quote($result->[0]->{count}+1) . " " .
254
"where" .
255
" IP=" . $Bc_sql::DB->quote($result->[0]->{IP}) .
256
" and URL=" . $Bc_sql::DB->quote($result->[0]->{URL});
257
my $updated = Bc_sql::sql_execute($updatesql, "Security::count_hits()->update");
258
if ($updated) {
259
# update successful, move along! Nothing to see here.
260
} else {
261
# update failed, oh deary my. that couldn't/shouldn't have happened!
262
if ($rv) { $rv = $updated; }
263
}
264
} # end if (@$result == 1)
265
else {
266
# too many results (or zero results), oh deary my. that couldn't/shouldn't have happened!
267
if ($rv) {
268
# should loop through the array, and populate $rv with the data
269
$rv = @$result;
270
}
271
} # end else of if (@$result == 1)
272
} # end if (@$result)
273
else {
274
# this IP has not visited this URL before
275
my $insertsql = "insert into page_visits values(NULL, " .
276
$Bc_sql::DB->quote($params->{ip}) . ", " .
277
"'1', " .
278
$Bc_sql::DB->quote(Date::get_date("db")) . ", " .
279
$Bc_sql::DB->quote($ENV{REQUEST_URI}) . ", " .
280
$Bc_sql::DB->quote(Bc_misc::referrer()) .
281
")";
282
my $inserted = Bc_sql::sql_execute($insertsql, "");
283
if ($inserted) {
284
# great, new visit added
285
} else {
286
# oh, this shouldn't have happened!
287
if ($rv) {
288
$rv = "sql is: $insertsql\n" .
289
"sql_execute said: $inserted\n";
290
}
291
}
292
} # end else of if (@$result)
293
} # end if ($params->{ip} ne $localhost or $rv eq 1)
294
else {
295
# no URL provided!
296
if ($rv) {
297
$rv = "number of params given: " . (keys %$params) . "<br>\n";
298
foreach my $p (keys %$params) {
299
$rv .= "\$params->{$p}=$params->{$p}<br>\n";
300
}
301
}
302
} # end else of if ($params->{ip} ne $localhost or $rv eq 1)
303
} # end if (ref $params eq "HASH")
304
else {
305
# $params is not a hash reference
306
my $ip = get_client_IP();
307
if (!$ip) { $ip = $localhost; }
308
if ($ip ne $localhost) {
309
my $url = $ENV{REQUEST_URI};
310
my $sql = "insert into page_visits values(NULL, " .
311
$Bc_sql::DB->quote($ip) . ", " .
312
"'1', " .
313
$Bc_sql::DB->quote(Date::get_date("db")) . ", " .
314
$Bc_sql::DB->quote($url) . ", " .
315
$Bc_sql::DB->quote(Bc_misc::referrer()) .
316
")";
317
if (not Bc_sql::sql_execute($sql, "Security::count_visits->invalid hash reference")
318
and $rv) {
319
$rv = "sql failed: $sql";
320
}
321
} # end if ($ip ne $localhost) {
322
} # end else of if (ref $params eq "HASH")
323
324
# (initialize $rv to 0 to disable this)
325
if ($rv) {
326
return $rv; # a value is returned if $rv is INITIALLY a 1
327
}
328
#usage: count_hits();
329
}
330
331
########################
332
sub allowed(;$) {
333
#*
334
# a combo of 'banned' and user_exists()
335
# !this function is not yet complete!
336
# effectively the exact opposite of <a href="#bounced">bounced(;$)</a>
337
#*
338
my ($uid) = @_; # a uid (optional, default = $Bc_sql::LOGGEDIN)
339
if (not $uid) { $uid = $Bc_sql::LOGGEDIN; }
340
341
if (Bc_sql::user_exists($uid) and not banned()) {
342
return 1; # 1 when user is allowed access;
343
}
344
345
return 0; # 0 when the user is not allowed access
346
#usage: if (not allowed($uid)) { print "access denied"; }
347
}
348
349
########################
350
sub banned(;$) {
351
#*
352
# gets the banned status of a uid
353
#*
354
my ($uid) = @_; # a uid (optional, default = $Bc_sql::LOGGEDIN)
355
if (not $uid) { $uid = $Bc_sql::LOGGEDIN; }
356
my $query = "select banned from users where ID=" . $Bc_sql::DB->quote($uid);
357
my $result = Bc_sql::sql_execute($query, "Security.pm - banned"); # should result in a 0 or a hash with one key: a UID
358
# $result is a hash reference
359
if (ref $result eq "HASH") {
360
if ($result->{banned} eq 2) {
361
my $sql = "select * from bans where BID=" . $Bc_sql::DB->quote($uid);
362
$result = Bc_sql::sql_execute($sql, "banned");
363
364
return $result; # a hash reference to the banned data when the user is banned
365
}
366
}
367
368
return 0; # 0 when the user is not banned
369
#usage: if (banned($uid)) { print "yer banned, bitch"; }
370
}
371
372
########################
373
sub bounced(;$) {
374
#*
375
# will determine if the user has the security
376
# clearance to access the requested URI
377
# !this function is not yet complete!
378
# effectively the exact opposite of <a href="#allowed">allowed(;$)</a>
379
#*
380
my ($uid) = @_; # a uid (optional, default = $Bc_sql::LOGGEDIN)
381
if (not $uid) { $uid = $Bc_sql::LOGGEDIN; }
382
383
return 0; # 1 if access denied, or 0 if access granted
384
#usage: if (bounced($uid)) { print "yer bounced, cupcake!"; }
385
}
386
387
########################
388
sub encrypt($;$) {
389
#*
390
# encrypts a string
391
# returns a hash reference =>
392
# {hashed_pw} = the password in hashed format
393
# {salt} = the plaintext salt
394
#*
395
my ($str, $salt) = @_; # a string && the salt
396
my $rv = {};
397
398
if (!$salt) {
399
$salt = Bc_misc::new_id(128);
400
}
401
402
my $estr = $pb->generate($str, $salt);
403
if ($estr ne $str) { $rv->{hashed_pw} = $estr; $rv->{salt} = $salt; }
404
405
return $rv; # a irreversably encrypted version of the given string, or nothing if this fails
406
}
407
408
########################
409
sub password_set($$$;$) {
410
#*
411
# changes the password for a given $uid (or nickname)
412
# !this function has not been tested!
413
414
# the password is given in plain-text. it could be easily
415
# stored as such (in a text file, or in the database). this
416
# subroutine will not do that!<br>
417
418
419
# the password will be encrypted before updating the database.
420
# the algorithm used is one way - it can encrypt, but there are
421
# no mechanics to decrypt it.
422
#*
423
my ($uid, $pw, $newpw, $col) = @_; # a uid && the current pword && the new pword && db column name for user ID
424
if (not $col) { $col = "uid"; }
425
my $rv = 0;
426
427
if (Bc_sql::user_exists($uid)) {
428
# first, check if the encrypted version of pw matches
429
# the encrypted pw in the database
430
# so, encrypt pw and retrieve $uid's pw from db
431
$pw = encrypt($pw);
432
my $DBpw = User::get_user_stat($uid, "password");
433
if ($pw eq $DBpw) {
434
# given pw matches retrieved pw, encrypt $newpw
435
$newpw = encrypt($newpw);
436
# and, update db password for $uid
437
my $sql = "update users set password=" . $Bc_sql::DB->quote($newpw) . " where $col=" . $Bc_sql::DB->quote($uid);
438
if (Bc_sql::sql_execute($sql, "sql failed in Security::password_set(...)")) {
439
$rv = 1;
440
}
441
}
442
}
443
444
return $rv; # 1 on success, 0 on failure
445
#usage: if (password_set($uid, $curr_pw, $new_pw)) { print "password updated"; }
446
}
447
448
########################
449
sub password_correct($$) {
450
#*
451
# determines if a given password matches the password associated with $uid
452
# like <a href="#password_set">password_set</a>, this takes a plain-text password,
453
# encrypts it, and compares that to what is found in the db
454
#*
455
my ($uid, $givenpw) = @_; # a uid && a password
456
my $rv = 0;
457
458
if (not Bc_sql::user_exists($uid)) {
459
# given a username instead of an ID?
460
# check for it
461
$uid = User::get_uid_byNickname($uid);
462
}
463
464
# now, retrieve the irreversably encrypted version of the user's pw
465
my $upw = User::get_user_stat($uid, "password");
466
467
$givenpw = encrypt($givenpw);
468
if ($givenpw eq $upw) {
469
$rv = 1; # 1 if the pword is correct
470
}
471
472
# $givenpw will now go out of scope, and be removed from memory
473
return $rv; # 1 if pw is correct else 0
474
#usage: if (password_correct($uid, $pw)) { print notice_redir("/", "loggedin"); }
475
}
476
477
########################
478
sub get_client_IP() {
479
#*
480
# retrieves the client's IP address
481
#*
482
#@_; # (no parameters)
483
my $clientIP = $ENV{REMOTE_ADDR};
484
485
return $clientIP; # an IP address (eg: 123.12.1.0)
486
#usage: my $client_ip = get_client_IP();
487
}
488
489
########################
490
sub get_site_IP() {
491
#*
492
# retrieves the site's IP address
493
#*
494
#@_; # (no parameters)
495
chomp (my $ip = get('http://icanhazip.com'));
496
497
return $ip; # an IP address (eg: 123.12.1.0)
498
#usage: my $site_ip = get_client_IP();
499
}
500
501
########################
502
sub login($$;$$$) {
503
#*
504
# to login (or not)
505
# set $type to 0 for <i>session only</i> (default) or
506
# 1 for <i>persistent</i> cookie storage
507
# if a user has logged in from another device, this
508
# will purge the login data, and reset it to this
509
# incarnation. technically, the login data in the
510
# database will not match the cookie data, and thus
511
# this would normally fail. But, instead of trying
512
# to figure out how to keep the other device logged
513
# in, i opted to just invalidate the device's login
514
# data.<br>
515
# this subroutine will return one of the following:
516
# 0 = sql failure
517
# -99 = no session ID found
518
# -88 = password failure
519
# -77 = invalid nickname
520
# $sid = session ID
521
#*
522
my ($nn, $pw, $type, $tn, $tc) = @_; # a nickname && a password && session (cookie) type (optional, session (0) or persistent (1)) && table name && table column
523
if (not $tn) { $tn = "loggedin"; }
524
if (not $tc) { $tc = "UID"; }
525
my $rv = -77;
526
my $uid = User::get_uid_byNickname($nn);
527
528
# now, the database isn't updated when user just closes their
529
# browser! if it's a "persistent" login, the cookie exists in
530
# the browser. but, if the cookie was "session only", then
531
# the cookie is gone, but the website (database) doesn't know that
532
# so, we gotta check the database to see if this UID is "loggedin"
533
# or not. if there is an associated login, then...invalidate that
534
# login data ONLY IF the cookie data doesn't match the login data
535
# then insert a new record with the new data, otherwise, just
536
# create a new record with the login data
537
my $s = "select * from $tn where $tc=" . $Bc_sql::DB->quote($uid);
538
my $result = Bc_sql::sql_execute($s, "login.pl - $s");
539
if (ref $result eq "HASH") {
540
$rv = -99; # no session ID found
541
} else {
542
if ($uid) {
543
my %ustats = User::get_user_stats($uid);
544
if (password_correct($uid, $pw)) {
545
my $numChars = 512; # an arbitrarily gigantic number of hexidecimal characters
546
my $sid = Bc_misc::new_id($numChars);
547
while (Bc_sql::sid_exists($sid)) { $sid = Bc_misc::new_id($numChars); }
548
my $sql = "insert into loggedin values(NULL, " . $Bc_sql::DB->quote($uid) . ", " . $Bc_sql::DB->quote($sid) . ", " . $Bc_sql::DB->quote($type) . ")";
549
if (Bc_sql::sql_execute($sql, "login - $sql")) {
550
$rv = $sid;
551
} else {
552
$rv = 0;
553
}
554
} else {
555
$rv = -88; # password mismatch
556
}
557
}
558
}
559
560
return $rv; # see description for return values
561
#usage: login($uid, $pw);
562
}
563
564
########################
565
sub logout() {
566
#*
567
# to logout and redir client to homepage
568
# simple function which simply deletes the login cookie
569
# from your browser's cookie cache. the login data in
570
# the database will be deleted when the user next logs
571
# in. client is then redirected to homepage.
572
#*
573
#@_; # (no parameters)
574
my $rv = cookie_delete("loggedin");
575
$rv .= Redir::notice_redir("/", "Successfully logged out");
576
577
return $rv; # a scalar
578
#usage: print logout();
579
}
580
581
########################
582
sub remove_test_accounts() {
583
#*
584
# to remove test accounts from the database
585
#*
586
#@_; # (no parameters)
587
my $DEBUG = 1;
588
my $rv = "";
589
590
my $sql = "delete from users where nickname like 'test%'";
591
my $deleted = sql_execute($sql, "Security::remove_test_accounts()");
592
593
if ($DEBUG) {
594
if ($deleted eq -1) {
595
$rv = "sql error: $sql";
596
} elsif ($deleted eq -2) {
597
$rv = "no test accounts found";
598
} else {
599
$rv = "test accounts deleted";
600
}
601
602
return $rv; # null, or debug output (when enabled)
603
}
604
605
#usage: remove_test_accounts();
606
}
607
608
########################
609
########################
610
########################
611
########################
612
########################
613
########################
614
########################
615
########################
616
########################
617
########################
618
########################
619
########################
620
########################
621
########################
622
########################
623
########################
624
########################
625
########################
626
########################
627
########################
628
########################
629
########################
630
########################
631
########################
632
########################
633
########################
634
635
########################
636
sub _tests(;$) {
637
#*
638
# to test all <i>Pm::Security</i> functions
639
#*
640
my ($extended) = @_; # show extended data (optional)
641
my $rv = "";
642
my $test = "";
643
my @test = ();
644
645
use Socket;
646
my $iaddr = inet_aton(get_site_IP());
647
my $caddr = inet_aton(get_client_IP());
648
my $name = gethostbyaddr($iaddr, AF_INET);
649
my $cname = gethostbyaddr($caddr, AF_INET);
650
651
if ($Bc_sql::DB) {
652
$test = 'boobies';
653
$rv .= Html::display_debug_one("password_correct(\$Bc_sql::LOGGEDIN, \"$test\")", password_correct($Bc_sql::LOGGEDIN, $test));
654
$rv .= Html::display_debug_one("get_client_IP()", "<a href=\"http://" . $cname . "/\">" . $cname . "</a> (ip: " . get_client_IP() . ")");
655
$rv .= Html::display_debug_one("get_site_IP()", "<a href=\"http://" . $name . "/\">" . $name . "</a> (ip: " . get_site_IP() . ")");
656
$rv .= Html::display_debug_one("encrypt(\"$test\")", encrypt($test));
657
} else {
658
$rv .= "DB connection error!<br>\n";
659
}
660
661
return $rv; # a scalar of the results of all tests
662
#usage: print _tests(1);
663
}
664
665
1;