#!/usr/bin/perl
# file KLEIDER/src/pinw/like.cgs
# <?install location = "cgi-bin/like"?>
# Verarbeitet einen "Like" (http://kleider.herbaer.de)
# 2020-09-04 Herbert Schiemann
# 2020-12-02 bugfix $s

use utf8;
use CGI::Simple::Util qw(unescape);
use DBI;
use Digest::MD5 qw(md5_base64);

binmode (STDOUT, ":encoding(utf8)");

# s=LOCATION&l=LANG&n=$NAME&v=VIEW
# Alle Angaben außer LOCATION sind optional
my $q = $ENV{"QUERY_STRING"} || "";

# LOCATION
my $s = unescape($1) if $q =~ /(?:^|&)s=([-_a-zA-Z0-9%.\/]+)(?:&|$)/;

# HASH-Teil der LOCATION
my $f = $1 if $s =~ s/#(.*)//;
my $r = $ENV{"REMOTE_ADDR"}     || "";
my $a = $ENV{"HTTP_USER_AGENT"} || "";

# Datenbankfelder
my $tm = time;
# Kennung der "story"
my $st = $1 if $s =~ /^(?:[^\/?]+\/)*?s([a-z0-9_]+)/;

# Nummer des Abschnitts der Bildergeschichte
my $sc = $1 if $f =~ /(?:^|_)s([1-9][0-9]*)(?:_|$)/;

# Kennung des Bildes
my $im = $1 if $f =~ /_([a-z0-9]{4,})/;

# Sprache
my $lg = lc($1) if $q =~ /(?:^|&)l=([a-zA-Z]+)/;
if (!$lg) {
   $lg = $ENV{"HTTP_ACCEPT_LANGUAGE"} || "";
   $lg =~ s/[-,;].*//;
   $lg = lc ($lg);
}
# VIEW: Ansicht (wie pinw, ...)
# Normalerweise nicht im Query-String angegeben,
# sondern Teil der Quell-URL $s=....
my $vw =
   $q =~ /(?:^|&)v=([-_a-zA-Z0-9%]+)(?:&|$)/ ? unescape ($1) :
   $s =~ /^(?:[^\/?]+\/)*?s[a-z0-9_]+\/([a-z]+)$/ ? $1 :
   "";
# Zur Kennzeichnung eines Besuchs: Digest von Adresse und User-Agent
my $vs = md5_base64("$r:$a");
# Login-Name
my $nm = $q =~ /(?:^|&)n=([-_a-zA-Z0-9%_.!~*'()]+)(?:&|$)/ ? md5_base64(unescape($1)) : "";

my $dbh = DBI -> connect (
   "DBI:mysql:${mysql.likedb.name}",
   "${mysql.likedb.user}",
   "${mysql.likedb.password}"
);
if (!$dbh) {
   print "Status: 503 Database Unavailable\n\n";
   exit;
}
my $stm = $dbh -> prepare (
   "INSERT INTO lk (tm, st, sc, im, lg, vw, vs, nm) VALUES (?, ?, ?, ?, ?, ?, ?, ?)"
   );
$stm -> execute ($tm, $st, $sc, $im, $lg, $vw, $vs, $nm);

print "Status: 204 no response\n\n";

# end of file KLEIDER/src/pinw/like.cgs