script/derekovecs-server

#!/usr/bin/env perl

our $VERSION = '0.98';

use IDS::DeReKoVecs::Read;
use Mojolicious::Lite;
use Mojo::Cache;
use Mojo::JSON qw(decode_json encode_json to_json);
use base 'Mojolicious::Plugin';

use Encode qw(decode encode);
use Getopt::Std;
#use Mojo::Server::Daemon;
use Cwd;

my $mojo_config = $ENV{MOJO_CONFIG} // '../derekovecs-server.conf';
plugin Config => {file => $mojo_config};

my $DEFAULT_VECS = app->config->{w2v}->{vecs} // "../models/dereko-2021-i.vecs";
my $KORAP_URL = app->config->{w2v}->{korap_url} // "https://korap.ids-mannheim.de";

my $DEFAULT_NET_NAME = "";
if ($DEFAULT_VECS=~ /\.vecs/) {
  $DEFAULT_NET_NAME = $DEFAULT_VECS;
  $DEFAULT_NET_NAME =~ s/\.vecs/.net/;
}
my $DEFAULT_NET           = app->config->{w2v}->{net}            // $DEFAULT_NET_NAME;
my $DOWNTIME_CALENDAR_URL = app->config->{downtime_calendar_url} // '';
my $COMPARE_TO            = app->config->{w2v}->{compare_to}     // '';

app->static->paths->[0] = getcwd;

plugin 'Piwik';
plugin "RemoteAddr";
plugin 'Util::RandomString' => {
  piwik_rand_id => {
    alphabet => '0123456789abcdef',
    length   => 16
  }
};

plugin 'Log::Access';
plugin "RequestBase";
#plugin 'AutoReload';
plugin  Localize => {
  dict => {
    _  => sub { $_->locale },
  },
  resources => ['../derekovecs-server.dict']
};
our $opt_i = 0; # latin1-input?
our $opt_l = undef;
our $opt_m;
our $opt_M;
our $opt_n = $DEFAULT_NET;
our $opt_d;
our $opt_D;
our $opt_G;

our $mergedEnd=0;
our $opt_p = 5676;
our $opt_C;

# Crawlers that collect training data for language models walk the
# parameterised URLs of this server, and those are the most expensive thing it
# does: every word is a URL of its own, every result links to the next words,
# so the crawl space is the whole vocabulary and nothing of it can be served
# from a cache. They are turned away before anything is computed.
#
# The list is a regular expression and can be replaced in the configuration
# file, robots => {block_user_agents => '...'}; an empty value switches the
# blocking off. Ordinary search engines are deliberately not in it - they are
# kept out of the parameterised URLs by robots.txt and X-Robots-Tag instead,
# and the entry page stays indexable.
my $DEFAULT_BLOCKED_AGENTS = join('|',
  'AI2Bot', 'Amazonbot', 'anthropic-ai', 'Bytespider', 'CCBot', 'ChatGPT-User',
  'Claude-SearchBot', 'Claude-User', 'Claude-Web', 'ClaudeBot', 'cohere-ai',
  'cohere-training-data-crawler', 'Diffbot', 'DuckAssistBot', 'FacebookBot',
  'facebookexternalhit', 'FriendlyCrawler', 'GPTBot', 'ImagesiftBot',
  'Kangaroo Bot', 'Meta-ExternalAgent', 'Meta-ExternalFetcher', 'meta-webindexer',
  'OAI-SearchBot', 'omgili', 'PanguBot', 'Perplexity-User', 'PerplexityBot',
  'Scrapy', 'SemrushBot-OCOB', 'Timpibot', 'TikTokSpider', 'YouBot'
);

my $blocked_agents = app->config->{robots}->{block_user_agents} // $DEFAULT_BLOCKED_AGENTS;
my $blocked_agents_re = length($blocked_agents) ? qr/(?i:$blocked_agents)/ : undef;

# robots.txt for the ones that read it. A reverse proxy that mounts derekovecs
# below a path has to serve the site wide /robots.txt itself, crawlers only
# ask for it at the root of the host - this one is for installations that own
# their host name, and does no harm anywhere else.
my $ROBOTS_TXT = join("\n",
  '# Every URL with parameters is a result computed for one word, and the',
  '# vocabulary is large enough that following them is an endless crawl.',
  'User-agent: *',
  'Disallow: /*?',
  'Crawl-delay: 10',
  '',
  '# Collecting training data for language models is not what this service is',
  '# here for. Please use the corpus itself, https://www.ids-mannheim.de/dereko',
  (map { "User-agent: $_" }
     (split(/\|/, $DEFAULT_BLOCKED_AGENTS),
      # tokens that are only understood in robots.txt, there is no crawler of
      # that name to match against
      'Google-Extended', 'Applebot-Extended')),
  'Disallow: /',
  ''
);

hook before_dispatch => sub {
  my $c = shift;

  if ($c->req->url->path->to_string =~ m@(?:^|/)robots\.txt$@) {
    return $c->render(data => $ROBOTS_TXT, format => 'txt');
  }

  # Only the entry page is worth indexing, everything else is computed.
  if (length($c->req->url->query->to_string)) {
    $c->res->headers->header('X-Robots-Tag' => 'noindex, nofollow');
    $c->stash(noindex => 1);
  }

  my $ua = $c->req->headers->user_agent;
  if ($blocked_agents_re && defined($ua) && $ua =~ $blocked_agents_re) {
    $c->app->log->info('Blocked crawler ' . $c->remote_addr . ' "' . $ua . '" ' . $c->req->url);
    $c->res->headers->header('X-Robots-Tag' => 'noindex, nofollow');
    return $c->render(
      text   => "This service computes an answer for every request and is not a source of training data.\n"
              . "The corpus behind it is documented at https://www.ids-mannheim.de/dereko\n",
      status => 403,
      format => 'txt'
    );
  }
};

# Neighbourhood results are the biggest objects the server keeps around (one
# hash plus one vector array per neighbour), so this cache is deliberately
# small. It is per worker, i.e. the total footprint is
# workers * max_keys * result size. Set cache => {max_keys => 0} to switch the
# cache off.
my $CACHE_MAX_KEYS = app->config->{cache}->{max_keys} // 50;
my $cache = Mojo::Cache->new(max_keys => $CACHE_MAX_KEYS);

my %marked;
my $title="";
my $training_args="";

sub usage {
  print STDERR <<EOF;
non-server mode usage: MOJO_CONFIG=`pwd`/example.conf $0 [-h] [-d <file>]
-h        : this (help) message
-d file   : dump binary vecs as ascii text to <file>

server-mode invocation:

MOJO_CONFIG=`pwd`/example.conf morbo $0
EOF
  exit;
}

getopts('d:D:Gil:p:m:n:M:Ch') or usage();

configure_cache(
  no_cache             => $opt_C,
  collocators_max_keys => app->config->{cache}->{collocators_max_keys},
  profiles_max_keys    => app->config->{cache}->{profiles_max_keys}
);

if($opt_M) {
  open my $handle, '<:encoding(UTF-8)', $opt_M
    or die "Can't open '$opt_M' for reading: $!";
  while(<$handle>) {
    foreach my $mw (split /\s+/) {
      $marked{$mw}=1
    }
  }
  close($handle);
}

my $vecs_name = (@ARGV > 0 && -r $ARGV[0] ? $ARGV[0] : $DEFAULT_VECS);
init_net($vecs_name, $opt_n, ($opt_i? 1 : 0), 1);
if(open(FILE, "$vecs_name.args")) {
  $training_args = <FILE>;
}
close(FILE);
$title = fname2corpusname($vecs_name);

my $have_sprofiles = load_sprofiles($vecs_name);

if (app->config->{w2v}->{merge}) {
  $opt_m = app->config->{w2v}->{merge};
}

if($opt_m) {
  $mergedEnd = mergeVectors($opt_m);
  $title = "<span class=\"merged\">" . $title . "</span> vs. " . fname2corpusname($opt_m);
}


if($opt_d) { # -d: dump  vecs and exit
	dump_vecs($opt_d);
	exit;
}

if($opt_D) { # -D: dump  vecs for numpy and exit
	dump_for_numpy($opt_D);
	exit;
}

#my $daemon = Mojo::Server::Daemon->new(
#    app    => app,
#    listen => ['http://'.($opt_l ? $opt_l : '*').":$opt_p"]
#);

if($opt_G) {
  print "Filtering garbage\n";
  filter_garbage();
  print "Finished filtering garbage\n";
}

get '*/js/*' => sub {
	my $c = shift;
	my $url = $c->req->url;
	$url =~ s@/derekovecs/@/@g;
  $c->app->log->debug("GET: " . $url);
	$c->reply->static($url);
} => 'js';

get '*/css/*' => sub {
	my $c = shift;
	my $url = $c->req->url;
	$url =~ s@/derekovecs/@/@g;
  $c->app->log->debug("GET: " . $url);
	$c->reply->static($url);
} => 'css';

sub fname2corpusname {
  ($_) = @_;
  s@.*/@@;
  s@\.en@-en@;
  s@\..*@@;
  return $_;
}

sub getWord {
  ($_) = @_;
  if ($_ =~ /^\d+/) {
    return $_;
  } else {
    return getWordNumber($_);
  }
}


post '*/getVecsByRanks' => sub {
  my $self = shift;
  my $vec = getVecs($self->req->json);
  $self->render(json => $vec);
};

post '/getVecsByRanks' => sub {
  my $self = shift;
  my $vec = getVecs($self->req->json);
  $self->render(json => $vec);
};

any '*/getCollocationAssociation' => sub {
  my $self = shift;
  $self->render(data => getCollocationAssociation($self, getWord($self->param("w") ? $self->param("w") : $self->req->json), getWord($self->param("c"))), format=>'json');
} => 'getCollocationAssociation';

any '/getCollocationAssociation' => sub {
  my $self = shift;
  $self->render(data => getCollocationAssociation($self, getWord($self->param("w") ? $self->param("w") : $self->req->json), getWord($self->param("c"))), format=>'json');
} => 'getCollocationAssociation1';

any '*/getClassicCollocators' => sub {
  my $self = shift;
  $self->render(data => getClassicCollocatorsCached($self, getWord($self->param("w") ? $self->param("w",) : $self->req->json),
      $COMPARE_TO), format=>'json');
} => 'getClassicCollocators1';

any '/getClassicCollocators' => sub {
  my $self = shift;
  $self->render(data => getClassicCollocatorsCached($self, getWord($self->param("w") ? $self->param("w") : $self->req->json),
      $COMPARE_TO), format=>'json');
} => 'getClassicCollocators';

any '/getBiggestVocabDistances' => sub {
  my $self = shift;
  $self->render(data => getBiggestMergedDifferences(), format=>'json');
} => 'getBiggestVocabDistances1';

any '*/getBiggestVocabDistances' => sub {
  my $self = shift;
  $self->render(data => getBiggestMergedDifferences(), format=>'json');
} => 'getBiggestVocabDistances';

any '*/getPosWiseW2VCollocators' => sub {
  my $self = shift;
  my $format = $self->param("format") || 'json';
  $self->render(data => getPosWiseW2VCollocators($self->param("w"),
                                            ($self->param("max")? $self->param("max") : 200),
                                            ($self->param("cutoff")? $self->param("cutoff") :750000),
                                            ($self->param("threshold")? $self->param("threshold") : 0.2),
                                            $format),
                                            format=>$format);
};

any '/getPosWiseW2VCollocators' => sub {
  my $self = shift;
  my $format = $self->param("format") || 'json';
  $self->render(data => getPosWiseW2VCollocators($self->param("w"),
                                            ($self->param("max")? $self->param("max") : 200),
                                            ($self->param("cutoff")? $self->param("cutoff") : 750000),
                                            ($self->param("threshold")? $self->param("threshold") : 0.2),
                                            $format),
                                            format=>$format);
};

any '*/getSimilarProfiles' => sub {
  my $self = shift;
  $self->render(data => getSimilarProfilesCached($self, getWord($self->param("w") ? $self->param("w") : $self->req->json)), format=>'json');
};

any '/getSimilarProfiles' => sub {
  my $self = shift;
  $self->render(data => getSimilarProfilesCached($self, getWord($self->param("w") ? $self->param("w") : $self->req->json)), format=>'json');
};

any '*/getWord' => sub {
  my $self = shift;
  my $w = $self->param("w");
  my $rank = getWord($w);
  my $status = 200;
  if ($rank <= 0) {
    $rank = -1;
    $status = 404;
  }
  $self->render(data => encode_json({word => $w, frequencyRank => $rank}), format => 'json', status => $status);
};

any '/getWord' => sub {
  my $self = shift;
  my $w = $self->param("w");
  my $rank = getWord($w);
  my $status = 200;
  if ($rank <= 0) {
    $rank = -1;
    $status = 404;
  }
  $self->render(data => encode_json({word => $w, frequencyRank => $rank}), format => 'json', status => $status);
};

any '/getSimilarity' => sub {
  my $self = shift;
  my $w1 = $self->param("w1");
  my $w2 = $self->param("w2");
  $self->render(data => cos_similarity_as_json($w1, $w2), format=>'json');
};

any '*/getSimilarity' => sub {
  my $self = shift;
  my $w1 = $self->param("w1");
  my $w2 = $self->param("w2");
  $self->render(data => cos_similarity_as_json($w1, $w2), format=>'json');
};

any '*/getDowntimeCalendar' => sub {
  my $self = shift;
  my $calendar = getDowntimeCalendar($DOWNTIME_CALENDAR_URL);
  $self->render(data => $calendar, format=>'text');
};

any '/getDowntimeCalendar' => sub {
  my $self = shift;
  my $calendar = getDowntimeCalendar($DOWNTIME_CALENDAR_URL);
  $self->render(data => $calendar, format=>'text');
};

any '/getVocabSize' => sub {
  my $self = shift;
  $self->render(data => getVocabSize(), format=>'json');
};

any '*/getVocabSize' => sub {
  my $self = shift;
  $self->render(data => getVocabSize(), format=>'json');
};

any '/getVersion' => sub {
  my $self = shift;
  $self->render(data => to_json($VERSION), format=>'json');
};

any '*/getVersion' => sub {
  my $self = shift;
  $self->render(data => to_json($VERSION), format=>'json');
};

any '/getModelName' => sub {
  my $self = shift;
  $self->render(data => to_json($title), format=>'json');
};

any '*/getModelName' => sub {
  my $self = shift;
  $self->render(data => to_json($title), format=>'json');
};

get '*/img/*' => sub {
	my $c = shift;
	my $url = $c->req->url;
	$url =~ s@/derekovecs@@g;
  $c->app->log->debug("GET: " . $url);
	$c->reply->static($url);
};

get '/' => sub {
  my $c    = shift;
  $c->app->log->debug("get: ".$c->req->url->to_abs);
	my $word=$c->param('word');
  my $no_nbs=$c->param('n') || ($opt_m? 50 : 100);
  my $no_iterations=$c->param('N') || 2000;
  my $perplexity=$c->param('perplexity') || 20;
  my $epsilon=$c->param('epsilon') || 5;
  my $som=$c->param('som') || 0;
	my $searchBaseVocabFirst=$c->param('sbf') || 0;
  my $sort=$c->param('sort') || 0;
  my $csv=$c->param('csv') || 0;
  my $json=$c->param('json') || 0;
  my $cutoff=$c->param('cutoff') || 500000;
  my $dedupe=$c->param('dedupe') || 0;
  my $nosp=$c->param('nosp') || 0;
  my $res;
	my @lists;
	my @collocations;
	if(defined($word) && $word !~ /^\s*$/) {
		$c->inactivity_timeout(300);
		$word =~ s/\s+/ /g;
    if($opt_m && $word !~ /\|/) {
      $word .= "|$word";
    }
    for my $w (split(' *\| *', $word)) {
      if($opt_m) {
        if($searchBaseVocabFirst) {
          $searchBaseVocabFirst=0;
        } else {
          $searchBaseVocabFirst=1;
        }
      }
      my $key = join("\x1c", $w, $cutoff, $no_nbs, $sort, $dedupe, $searchBaseVocabFirst, $nosp);
      $res = $opt_C ? undef : $cache->get($key);
      if (defined $res) {
        $c->app->log->debug("Getting $w results from cache");
      } else {
        $c->app->log->debug('Looking for neighbours of '.$w);
        if($opt_i) {
          $res = get_neighbours(encode("iso-8859-1", $w), $no_nbs, $sort, $searchBaseVocabFirst, $cutoff, $dedupe, $nosp);
        } else {
          $res = get_neighbours($w, $no_nbs, $sort, $searchBaseVocabFirst, $cutoff, $dedupe, $nosp);
        }
        $cache->set($key => $res) unless $opt_C;
      }
      push(@lists, $res->{paradigmatic});
    }
  }
  
	$word =~ s/ *\| */ | /g;
  if($json) {
    return $c->render(json => {word => $word, list => \@lists, collocators=>$res->{syntagmatic}});
  } elsif($csv) {
    my $csv_data="";
    for (my $i=0; $i <= $no_nbs; $i++) {
      $csv_data .= $res->{paradigmatic}->[$i]->{word} . ", ";
    }
    for (my $i=0; $i < $no_nbs; $i++) {
      $csv_data .= $res->{syntagmatic}->[$i]->{word} . ", ";
    }
    chop $csv_data;
    chop $csv_data;
    $csv_data .= "\n";
    return $c->render(text=>$csv_data);
  } else {
    my $distantWords="";
    if(!defined($word) || $word !~ /^\s*$/) {
      $distantWords = getBiggestMergedDifferences();
    }
    $c->render(
      template             => "index",
      title                => $title,
      word                 => $word,
      distantWords         => $distantWords,
      cutoff               => $cutoff,
      no_nbs               => $no_nbs,
      no_iterations        => $no_iterations,
      epsilon              => $epsilon,
      perplexity           => $perplexity,
      show_som             => $som,
      searchBaseVocabFirst => $searchBaseVocabFirst,
      sort                 => $sort,
      training_args        => $training_args,
      mergedEnd            => $mergedEnd,
      haveSProfiles        => $have_sprofiles,
      dedupe               => $dedupe,
      marked               => \%marked,
      lists                => \@lists,
      collocators          => $res->{syntagmatic},
      version              => $VERSION,
      korap_url            => $KORAP_URL,
    );
  }
} => "paradigmaticAndSyntagmaticNbs";

helper(bitvec2window => sub {
         my ($self, $n) = @_;
         my $str = unpack("B32", pack("N", $n));
         $str =~ s/^\d{22}//;
         $str =~ s/^(\d{5})/$1x/;
         $str =~ s/0/·/g;
         $str =~ s/1/+/g;
         return $str;
      });

if(app->config->{Piwik} && app->config->{Piwik}->{url}) {
  hook(
      after_render => sub {
        my $c = shift;

        # Only track valid routes
        my $route = $c->current_route or return;

        # This won't forward personalized information
        my $hash = {
          action_url =>  $c->req->url->to_abs,
          action_name => $route,
          ua => $c->req->headers->user_agent,
          urlref => '',
          send_image => 0,
          dnt => 0,
          cip => $c->remote_addr,
          lang => $c->req->headers->accept_language,
          uid => $c->random_string('piwik_rand_id')
        };
        # $c->app->log->info("PIWIK: counting " . $hash->{action_url} . "\nremote:" . $c->remote_addr);
        # $c->app->log->info("PIWIK: tag " . $c->piwik_tag);

        # Send track
        $c->piwik->api_p(Track => $hash)->wait;

        # $c->app->log->info("PIWIK: counted.");
      }
  );
}

app->renderer->paths([app->home->rel_file('../templates')]);
app->start;
#$daemon->run;
# app->start;

# exit;