#!/usr/bin/perl require 5; #$DEBUG =1; $version = "5.0"; ################################################### # PASS.CGI v5.0 # Copyright 1998-2006 Right Connection, Inc. # For use by their customers only for integrating IPPS # Password Management to their website # # Please be sure and set all of the variables below. If they are # not properly set ....... the Password Management will not work # ################################################### ## Un-Comment ONLY ONE of these options depending upon what version of Apache you are running ## Apache 1.x series #BEGIN { @AnyDBM_File::ISA = qw(NDBM_File) } ## Apache 2.x Series #BEGIN { @AnyDBM_File::ISA = qw(SDBM_File) } # What is the directory where your encrypted password file is located ? $pass_dir = "/path/to/.htpasswd/directory"; # What is the name of your encrypte password file ? (Should be pass_dbm). $pass_file = "pass_dbm"; # What is the URL the NEW customer should be taken to when they sign-up? $members_url = "http://www.yourwebsite.com/members/"; # The BODY tag variables for the script $bgcolor = "FFFFFF"; $text = "000000"; $link = "FF0000"; $vlink = "FF00FF"; $alink = "FFFF00"; ################################################### # NO CHANGES ARE NEEDED BEYOND THIS POINT ################################################### use Fcntl; use AnyDBM_File (); &read_parse; $refering_url = $ENV{'HTTP_REFERER'}; $LOCK_EX = 2; $LOCK_UN = 8; if ($contents{'mode'} eq "" || $contents{'mode'} eq "add") { &new_signup; } if ($contents{'mode'} eq "stat") { &stat; } if ($contents{'mode'} eq "update") { &update(@user_pairs); } &error("No Commands were received"); exit; sub read_parse { local (*contents) = @_; local ( $request_method, $query_string, @key_value_pairs, $key_value, $key, $value, $data); $data_string = ""; $request_method = $ENV{'REQUEST_METHOD'}; if ($request_method eq "GET") { $query_string = $ENV{'QUERY_STRING'}; } elsif ($request_method eq "POST") { read (STDIN, $query_string, $ENV{'CONTENT_LENGTH'}); } @key_value_pairs = split (/&/, $query_string); foreach $key_value (@key_value_pairs) { ($key, $value) = split (/=/, $key_value); $value =~ tr/+/ /; $value =~ s/\r/\n/g; $value =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg; if (defined($FORM_DATA{$key})) { $contents{$key} = join ("\0", $contents{$key}, $value); } else { $contents{$key} = $value; } $data_string .= "$key - $value\n"; if ($contents{'userpair'} ne "") { push(@user_pairs,$contents{'userpair'}); } } if (@user_pairs) { $data_string .= "userpairs\n@user_pairs\n"; } } sub error { local($errormsg) = @_; print "Content-Type: text/html\n\n"; print "\n"; print "\n"; print "\n$errormsg!\n\n"; print "\n"; print "
\n

\n\n"; print "\n$errormsg\n\n"; print "

\n"; print "If you are recieving this Error Message and are using Internet Explorer \n"; print "4.x and above, your password will automatically be activated in approximately 15 minutes.\n"; if ($DEBUG) { print "\n"; } print ""; exit; } sub new_signup { if (($contents{'username'} eq "") || ($contents{'username'} eq " ")) { &error("Invalid User Name"); } if (($contents{'password'} eq "") || ($contents{'password'} eq " ")) { &error("Invalid Password"); } if ($refering_url !~ /secure.rightconnect.com/) { &error("Bad Refering URL - $refering_url"); } &salt_password; &add_to_file; &good_add; } sub salt_password { srand($$|time); @saltchars=('a..z','A..Z','0..9','.','/'); $salt=$saltchars[int(rand($#saltchars+1))]; $salt.=$saltchars[int(rand($#saltchars+1))]; $cpw = crypt($contents{'password'},$salt); } sub add_to_file { my %DB = (); my @range = (); my($mode, $flags) = (0666 , O_RDWR|O_CREAT); $key = $contents{'username'}; $file = $pass_dir . "/" . $pass_file; tie (%DB, "AnyDBM_File", $file, $flags, $mode) || die "Can't tie $file: $!"; $groups = '' if $groups eq '-'; $comment = '' if $comment eq '-'; $groups .= ":" . $comment if $comment; $cpw .= ":" . $groups if $groups; $DB{$key} = $cpw; untie %DB; } sub good_add { print "Connection: close\n"; print "Content-Type: text/html\n\n"; print "\n"; print "\n"; print "\nComplete\n\n"; print "\n"; print "\n"; print "
\n

\n\n"; print "Your Membership sign-up is complete.

You may now enter the \n"; print "MEMBERS AREA using your User ID of \n"; print "$contents{'username'} and Password of $contents{'password'}
\n"; if ($DEBUG) { print "\n"; } print "\n"; print "Version: " . $Version . "
\n"; print ""; exit; } sub stat { open(FILE, "$pass_dir/$pass_file") || &error("Can't stat file $pass_dir/$pass_file ($!)"); $filesize = -s FILE; close(FILE); &good_stat; } sub good_stat { print "Connection: close\n"; print "Content-Type: text/plain\n\n"; print "\n"; print "$filesize\n"; print "\n"; if ($DEBUG) { print "\n"; } exit; } sub update { my(@users) = @_; my %DB = (); my @range = (); my($mode, $flags) = (0666 , O_RDWR|O_CREAT); $key = $contents{'username'}; $file = $pass_dir . "/" . $pass_file; tie (%DB, "AnyDBM_File", $file, $flags, $mode) || die "Can't tie $file: $!"; foreach my $key (keys %DB) { delete $DB{$key}; } foreach $user (@users) { ($username, $cpw) = split(':',$user); $groups = '' if $groups eq '-'; $comment = '' if $comment eq '-'; $groups .= ":" . $comment if $comment; $cpw .= ":" . $groups if $groups; $DB{$username} = $cpw; } untie %DB; print "Connection: close\n"; print "Content-Type: text/plain\n\n"; print "\n"; print "OK\n"; print "\n"; if ($DEBUG) { print "\n"; } exit; }