💾 Archived View for thfr.info › cgi-source › popcat.cgi captured on 2024-05-26 at 14:59:00.
⬅️ Previous capture (2023-01-29)
-=-=-=-=-=-=-
#!/usr/bin/perl
# Copyright (c) 2022 Thomas Frohwein <mail@mail.thfr.info>
#
# Permission to use, copy, modify, and distribute this software for any
# purpose with or without fee is hereby granted, provided that the above
# copyright notice and this permission notice appear in all copies.
#
# THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
# WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
# ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
# WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
# ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
# OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
use strict;
use warnings;
use Fcntl qw( :flock );
use File::Spec::Functions qw( splitpath );
use IP::Country::Fast;
my ( undef, $directories, $this_script ) = splitpath( $ENV{'SCRIPT_NAME'} );
my $users_file = '/cgi-data/popcat/users.txt';
my $country_code_regex = '[A-Z]{2}';
my $gem_header_success = "20 text/gemini";
my $popcat_closed = <<"END_CLOSED";
XX XX
XXXX XXXX
XXXXXX XXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXX XXXXXXXXXXXXXXXXXXXXXXX XXXXXX
XXXXXXXXXXXXXXXXX XXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXX XXX XXX XXXXXXXXXXXXXXXX
XXXXXXXXXXXXX XXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXX
END_CLOSED
my $popcat_open = <<"END_OPEN";
XX XX
XXXX XXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXX XXXXXXXXXX XXXXXXXXXXXX XXXXXX
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
XXXXXXXXXXXXX XXXXXXXXXXXXXX
XXXXXXXXX XXXXXXXXXXX
XXXXXXX XXXXXXXXX
XXXXXX XXXXXXXX
XXXXX XXXXXX
XXXXXXXXXXXXXXXXXXXXX
END_OPEN
my ($cert_country, $prompt_country, $stored_country, $user_country);
my %country_codes = (
# A
'AF' => 'Afghanistan',
'AX' => 'Aland Islands',
'AL' => 'Albania',
'DZ' => 'Algeria',
'AS' => 'American Samoa',
'AD' => 'Andorra',
'AO' => 'Angola',
'AI' => 'Anguilla',
'AQ' => 'Antarctica',
'AG' => 'Antigua and Barbuda',
'AR' => 'Argentina',
'AM' => 'Armenia',
'AW' => 'Aruba',
'AU' => 'Australia',
'AT' => 'Austria',
'AZ' => 'Azerbaijan',
# B
'BS' => 'Bahamas',
'BH' => 'Bahrain',
'BD' => 'Bangladesh',
'BB' => 'Barbados',
'BE' => 'Belgium',
'BZ' => 'Belize',
'BJ' => 'Benin',
'BM' => 'Bermuda',
'BT' => 'Bhutan',
'BO' => 'Bolivia',
'BQ' => 'Bonaire',
'BA' => 'Bosnia and Herzegovina',
'BW' => 'Botswana',
'BV' => 'Bouvet Island',
'BR' => 'Brazil',
'IO' => 'British Indian Ocean Territory',
'BN' => 'Brunei Darussalam',
'BG' => 'Bulgaria',
'BF' => 'Burkina Faso',
'BI' => 'Burundi',
# C
'KH' => 'Cambodia',
'CM' => 'Cameroon',
'CA' => 'Canada',
'CV' => 'Cape Verde',
'KY' => 'Cayman Islands',
'CF' => 'Central African Republic',
'TD' => 'Chad',
'CL' => 'Chile',
'CN' => 'China',
'CX' => 'Christmas Island',
'CC' => 'Cocos (Keeling) Islands',
'CO' => 'Colombia',
'KM' => 'Comoros',
'CG' => 'Congo',
'CD' => 'Congo, Democratic Republic of the',
'CK' => 'Cook Islands',
'CR' => 'Costa Rica',
'HR' => 'Croatia',
'CW' => 'Curacao',
'CY' => 'Cyprus',
'CZ' => 'Czech Republic',
# D
'DK' => 'Denmark',
'DJ' => 'Djibouti',
'DM' => 'Dominica',
'DO' => 'Dominican Republic',
# E
'EC' => 'Ecuador',
'EG' => 'Egypt',
'SV' => 'El Salvador',
'GQ' => 'Equatorial Guinea',
'ER' => 'Eritrea',
'EE' => 'Estonia',
'ET' => 'Ethiopia',
# F
'FK' => 'Falkland Islands (Malvinas)',
'FO' => 'Faroe Islands',
'FJ' => 'Fiji',
'FI' => 'Finland',
'FR' => 'France',
'GF' => 'French Guiana',
'PF' => 'French Polynesia',
'TF' => 'French Southern Territories',
# G
'GA' => 'Gabon',
'GM' => 'Gambia',
'GE' => 'Georgia',
'DE' => 'Germany',
'GH' => 'Ghana',
'GI' => 'Gibraltar',
'GR' => 'Greece',
'GL' => 'Greenland',
'GD' => 'Grenada',
'GP' => 'Guadeloupe',
'GU' => 'Guam',
'GT' => 'Guatemala',
'GG' => 'Guernsey',
'GN' => 'Guinea',
'GW' => 'Guinea-Bissau',
'GY' => 'Guyana',
# H
'HT' => 'Haiti',
'HM' => 'Heard Island and McDonald Islands',
'VA' => 'Holy See (Vatican City State)',
'HN' => 'Honduras',
'HK' => 'Hong Kong',
'HU' => 'Hungary',
# I
'IS' => 'Iceland',
'IN' => 'India',
'ID' => 'Indonesia',
'IQ' => 'Iraq',
'IE' => 'Ireland',
'IM' => 'Isle of Man',
'IL' => 'Israel',
'IT' => 'Italy',
# J
'JM' => 'Jamaica',
'JP' => 'Japan',
'JE' => 'Jersey',
'JO' => 'Jordan',
# K
'KZ' => 'Kazakhstan',
'KE' => 'Kenya',
'KI' => 'Kiribati',
'KR' => 'Korea, Republic of',
'KW' => 'Kuwait',
'KG' => 'Kyrgyzstan',
# L
'LA' => 'Lao People\'s Democratic Republic',
'LV' => 'Latvia',
'LB' => 'Lebanon',
'LS' => 'Lesotho',
'LR' => 'Liberia',
'LY' => 'Libya',
'LI' => 'Liechtenstein',
'LT' => 'Lithuania',
'LU' => 'Luxembourg',
# M
'MO' => 'Macao',
'MG' => 'Madagascar',
'MW' => 'Malawi',
'MY' => 'Malaysia',
'MV' => 'Maldives',
'ML' => 'Mali',
'MT' => 'Malta',
'MH' => 'Marshall Islands',
'MQ' => 'Martinique',
'MR' => 'Mauritania',
'MU' => 'Mauritius',
'YT' => 'Mayotte',
'MX' => 'Mexico',
'FM' => 'Micronesia (Federated States of)',
'MD' => 'Moldova, Republic of',
'MC' => 'Monaco',
'MN' => 'Mongolia',
'ME' => 'Montenegro',
'MS' => 'Montserrat',
'MA' => 'Morocco',
'MZ' => 'Mozambique',
'MM' => 'Myanmar',
# N
'NA' => 'Namibia',
'NR' => 'Nauru',
'NP' => 'Nepal',
'NL' => 'Netherlands',
'NC' => 'New Caledonia',
'NZ' => 'New Zealand',
'NI' => 'Nicaragua',
'NE' => 'Niger',
'NG' => 'Nigeria',
'NU' => 'Niue',
'NF' => 'Norfolk Island',
'MK' => 'North Macedonia',
'MP' => 'Northern Mariana Islands',
'NO' => 'Norway',
# O
'OM' => 'Oman',
# P
'PK' => 'Pakistan',
'PW' => 'Palau',
'PS' => 'Palestine, State of',
'PA' => 'Panama',
'PG' => 'Papua New Guinea',
'PY' => 'Paraguay',
'PE' => 'Peru',
'PH' => 'Philippines',
'PN' => 'Pitcairn',
'PL' => 'Poland',
'PT' => 'Portugal',
'PR' => 'Puerto Rico',
# Q
'QA' => 'Qatar',
# R
'RE' => 'Reunion',
'RO' => 'Romania',
'RU' => 'Russion Federation',
'RW' => 'Rwanda',
# S
'BL' => 'Saint Barthelemy',
'SH' => 'Saint Helena, Ascension and Tristan da Cunha',
'KN' => 'Saint Kitts and Nevis',
'LC' => 'Saint Lucia',
'MF' => 'Saint Martin (French part)',
'PM' => 'Saint Pierre and Miquelon',
'VC' => 'Saint Vincent and the Grenadines',
'WS' => 'Samoa',
'SM' => 'San Marino',
'SA' => 'Saudi Arabia',
'SN' => 'Senegal',
'RS' => 'Serbia',
'SC' => 'Seychelles',
'SL' => 'Sierra Leone',
'SG' => 'Singapore',
'SX' => 'Sint Maarten (Dutch part)',
'SK' => 'Slovakia',
'SI' => 'Slovenia',
'SB' => 'Solomon Islands',
'SO' => 'Somalia',
'ZA' => 'South Africa',
'GS' => 'South Georgia and the South Sandwich Islands',
'SS' => 'South Sudan',
'ES' => 'Spain',
'LK' => 'Sri Lanka',
'SR' => 'Suriname',
'SJ' => 'Svalbard and Jan Mayen',
'SE' => 'Sweden',
'CH' => 'Switzerland',
'ST' => 'Sao Tome and Principe',
# T
'TW' => 'Taiwan',
'TJ' => 'Tajikistan',
'TZ' => 'Tanzania, United Republic of',
'TH' => 'Thailand',
'TG' => 'Togo',
'TK' => 'Tokelau',
'TO' => 'Tonga',
'TT' => 'Trinidad and Tobago',
'TN' => 'Tunisia',
'TM' => 'Turkmenistan',
'TC' => 'Turks and Caicos Islands',
'TV' => 'Tuvalu',
# U
'UG' => 'Uganda',
'UA' => 'Ukraine',
'AE' => 'United Arab Emirates',
'GB' => 'United Kingdom',
'US' => 'United States',
'UM' => 'United States Minor Outlying Islands',
'UY' => 'Uruguay',
'UZ' => 'Uzbekistan',
# V
'VU' => 'Vanuatu',
'VE' => 'Venezuela',
'VN' => 'Vietnam',
'VG' => 'Virgin Islands, British',
'VI' => 'Virgin Islands, U.S.',
# W
'WF' => 'Wallis and Futuna',
'EH' => 'Western Sahara',
# Y
'YE' => 'Yemen',
# Z
'ZM' => 'Zambia',
'ZW' => 'Zimbabwe',
# Restricted (https://www.ssl.com/country-codes/)
'CU' => 'Cuba',
'IR' => 'Iran, Islamic Republic of',
'KP' => 'Korea, Democratic People\'s Republic of',
'SD' => 'Sudan',
'SY' => 'Syrian Arab Republic',
);
sub update_file_counts {
my ($key, $file, $array_ref) = @_;
unless ( defined( $array_ref ) ) { # if no array passed; define a throwaway one
my @sub_array;
$array_ref = \@sub_array;
}
my $count;
# Lock, then read count from $file or set to 1
open(my $fh, '+<', $file) or die "Open: $!";
flock($fh, LOCK_EX) or die "Locking: $!";
@$array_ref = <$fh>;
if ( my ( $target_line ) = grep( /^\Q$key\E/, @$array_ref ) ) {
my ($old_count) = $target_line =~ /(\d+)$/;
($stored_country) = $target_line =~ / ($country_code_regex) /;
$count = $old_count + 1;
foreach (@$array_ref) {
# update entry; add the country by selecting the appropriate one
my $country_entry = $prompt_country || $stored_country || $cert_country || '';
s/^\Q$key \E.*/$key $country_entry $count/;
}
}
else {
push( @$array_ref, $key . " 1\n" ); # new entry
$count = 1;
}
# Write updated table to file and close
seek($fh, 0, 0) or die "Seeking: $!";
print $fh @$array_ref or die "Printing: $!";
truncate($fh, tell($fh)) or die "Truncating: $!";
flock($fh, LOCK_UN) or die "Cannot unlock file - $!";
close $fh or die "Closing: $!";
return $count;
}
# If no client certificate, prompt for one.
unless ( $ENV{'TLS_CLIENT_HASH'} ) {
print "60 Enter country code when generating the client certificate to participate in country statistics\r\n";
exit;
}
# if "$this_script?country_list", list countries with link to prompt
if ( $ENV{'QUERY_STRING'} eq 'country_list' ) {
print "$gem_header_success\r\n";
print "# Select country for POPCAT statistics\n";
foreach my $c (sort { $country_codes{$a} cmp $country_codes{$b} } keys %country_codes) {
print "=> $this_script?country=$c $country_codes{$c} ($c)\n";
}
exit;
}
# if "$this_script?country=XX", set $prompt_country
# check if country code is valid, otherwise don't set $prompt_country
my ($country_candidate) = $ENV{'QUERY_STRING'} =~ /^country=($country_code_regex)$/;
if ( $country_candidate and $country_codes{$country_candidate} ) {
$prompt_country = $country_candidate;
}
($cert_country) = ( $ENV{'TLS_CLIENT_ISSUER'} =~ m|/C=($country_code_regex)| );
# get counts
my @users;
my $user_count = update_file_counts( $ENV{'TLS_CLIENT_HASH'}, $users_file, \@users );
$user_country = $prompt_country || $stored_country || $cert_country || '<None>';;
# calculate country counts
my %country_counts;
foreach my $user_line ( @users ) {
my ($country) = $user_line =~ / ($country_code_regex) /;
my ($count) = $user_line =~ /(\d+)$/;
unless ($country) { $country = '<None>'; }
# update count for $country (initialize if doesn't exist)
unless ( $country_counts{$country} ) {
$country_counts{$country} = 0;
}
$country_counts{$country} += $count;
}
my $user_country_count = $country_counts{$user_country};
print "$gem_header_success\r\n";
print '# ' . uc( $this_script ) . "\n";
print "```\n";
my $line_length = 39; # longest line in the ascii art popcat_open/closed
my $count_length = length($user_count);
my $padding = int( ( $line_length - $count_length ) / 2 );
print ' ' x $padding . "$user_count\n\n";
if ( $user_count % 2 ) {
print $popcat_closed;
}
else {
print $popcat_open;
}
print "```\n";
if ( $user_country eq '<None>' ) {
my $ip_country = IP::Country::Fast->new()->inet_atocc( $ENV{'REMOTE_ADDR'} );
print "\n### Select your country to continue\n";
if ( $country_codes{$ip_country} ) {
print "=> $this_script?country=$ip_country POP! for $country_codes{$ip_country}!\n";
}
print "=> $this_script?country_list POP! and choose country...\n";
}
else {
print "=> $this_script POP!\n";
}
print "\n";
# Statistics
my $worldwide = 0;
foreach my $c (values %country_counts) {
$worldwide += $c;
}
print "Worldwide: $worldwide\n";
if ( $user_country eq '<None>' ) {
print "$user_country: $user_country_count\n";
}
else{
print "$country_codes{$user_country}: $user_country_count\n";
print "=> $this_script?country_list (change country)\n";
}
print "## Country Leaderboard\n";
foreach my $cc (sort { $country_counts{$b} <=> $country_counts{$a} } keys %country_counts) {
if ( $cc eq '<None>' ) {
print "$cc: $country_counts{$cc}\n";
}
else {
print "$country_codes{$cc}: $country_counts{$cc}\n";
}
}
print "\n=> /cgi-source/$this_script View $this_script Source Code\n";