#!/usr/bin/perl -w

# Copyright 2022 Kevin Ryde
#
# This file is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by the Free
# Software Foundation; either version 3, or (at your option) any later
# version.
#
# This file is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
# or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
# for more details.
#
# You should have received a copy of the GNU General Public License along
# with this file.  See the file COPYING.  If not, see
# <http://www.gnu.org/licenses/>.


# Usage: nthprimeweb-fetch [--gp] --prime 9999
#
# Downloaded prime and pi values are cached in an SQLite3 database
#
#     ~/.nthprimeweb/nthprimeweb.sqdb
#
# where ~ mean the use home directory as determined by File::HomeDir.


use 5.006;
use strict;
use warnings;
use DBI;
use DBD::SQLite;
use FindBin;
use Getopt::Long;
use File::HomeDir;
use File::Slurp;
use HTTP::Request::Common;
use LWP::UserAgent;
$|=1;

# uncomment this to run the ### lines
# use Smart::Comments;

our $VERSION = 0;
my $option_verbose = 0;

my $nthprimeweb_url = 'https://primes.utm.edu/nthprime/index.php';

my $homedir = File::HomeDir->my_home;
my $nthprimeweb_dir = File::Spec->catfile($homedir,
                                       '.nthprimeweb');
my $db_filename = File::Spec->catfile($nthprimeweb_dir,
                                      'nthprimeweb.sqdb');


#-----------------------------------------------------------------------------
# Database

# Return true if $dbh contains a table named $table.
sub table_exists {
  my ($dbh, $table) = @_;
  my $sth = $dbh->table_info (undef, undef, $table, undef);
  my $exists = $sth->fetchrow_arrayref ? 1 : 0;
  $sth->finish;
  return $exists;
}

use constant::defer dbh => sub {
  mkdir($nthprimeweb_dir);
  my $dbh = DBI->connect
    ("dbi:SQLite:dbname=$db_filename",
     '', '', {RaiseError=>1});

  if (! table_exists($dbh,'extra')) {
    print "Create $db_filename\n";

    $dbh->do (<<'HERE');
  CREATE TABLE prime (
    n      TEXT  NOT NULL  PRIMARY KEY,
    prime  TEXT  NOT NULL);
HERE
    $dbh->do (<<'HERE');
  CREATE TABLE pi (
    n   TEXT  NOT NULL  PRIMARY KEY,
    pi  TEXT  NOT NULL);
HERE
    $dbh->do (<<'HERE');
  CREATE TABLE extra (
    key    TEXT  NOT NULL  PRIMARY KEY,
    value  TEXTL)
HERE
  }

  return $dbh;
};

sub database_read {
  my ($table,$n) = @_;
  my $sth = dbh()->prepare_cached
    ("SELECT $table FROM $table WHERE n=?");
  my $aref = dbh()->selectall_arrayref($sth,undef,$n);
  $aref = $aref->[0] || return undef; # if no rows
  my ($prime) = @$aref;
  return $prime;
}

sub database_write {
  my ($table,$n,$value) = @_;

  my $sth = dbh()->prepare_cached
    ("INSERT OR REPLACE INTO $table (n,$table)
      VALUES (?,?)");
  $sth->execute ($n,$value);
}


#-----------------------------------------------------------------------------
# Download

my $ua = LWP::UserAgent->new (keep_alive => 1);
$ua->default_header ('Accept-Encoding' => scalar HTTP::Message::decodable());
$ua->agent($FindBin::Script . '/' . $VERSION . ' ');

# diagnostic output
$ua->add_handler (request_send => sub {
                    my ($req, $ua, $headers) = @_;
                    if ($option_verbose) {
                      $|=1;
                      print "request:\n";
                      print $req->method," ",$req->uri,"\n";
                      print $req->headers->as_string,"\n";
                      print $req->decoded_content(raise_error=>0),"\n";
                      print "\n";
                    }
                    return;
                  });
$ua->add_handler (response_header => sub {
                    my ($resp, $ua, $headers) = @_;
                    if ($option_verbose) {
                      print "response: ",length($resp->as_string)," bytes\n";
                      print $resp->status_line,"\n";
                      print $resp->headers->as_string;
                      print "\n";
                    }
                  });

my %table_to_posts = (prime => ['nth','n'],
                      pi    => ['piofx','x']);
sub download {
  my ($table,$n) = @_;
  ### download ...
  ### $table
  my ($anchor,$field) = @{$table_to_posts{$table}};
  my $req = HTTP::Request::Common::POST
    ($nthprimeweb_url,
     Content_Type  => 'form-data',
     Content       =>
     { CAN_MULTIPART  => 1,
       $field         => $n,
     });

  my $resp = $ua->request($req);
  File::Slurp::write_file("/tmp/found.html",$resp->decoded_content);
  unless ($resp->is_success) {
    output_error($resp->status_line,"\n",
                 $resp->headers->as_string,
                 $resp->decoded_content (charset => 'None'));
  }
  return $resp;
}

sub parse_response_str {
  my ($content) = @_;
  ### $content
  my ($table,$n,$value);
  if ($content =~ m{The ([0-9,]+).*? prime is ([0-9,]+)\.}) {
    $table = 'prime';
    $n = $1;
    $value = $2;
  } elsif ($content =~ m{There are ([0-9,]+).*? primes less than or equal to ([0-9,]+)\.}) {
    # eg. There are 1,229 primes less than or equal to 10,000.
    $table = 'pi';
    $value = $1;
    $n = $2;
  } else {
    output_error("Cannot parse response");
  }
  foreach ($n,$value) { tr/,//d; }
  return ($table,$n,$value);
}

sub read_or_download {
  my ($table,$n) = @_;
  if (my $value = database_read($table,$n)) {
    return $value;
  }
  my $resp = download ($table,$n);
  my $str = $resp->decoded_content;
  my ($got_table, $got_n, $value)  = parse_response_str($str);
  $table eq $got_table or output_error("oops, parse different function");
  $n eq $got_n or output_error("oops, parse different N");
  database_write($table,$n,$value);
  return $value;
}

# Return string $str with characters escaped as necessary to make a GP
# syntax string literal.  The return is ready to go inside "" quotes.
sub GP_string_escape {
  my ($str) = @_;
  $str =~ s/([\\"])/\\$1/g;
  $str =~ s/\n/\\n/g;
  $str =~ s/\r/\\r/g;
  return $str;
}
sub output_error {
  print "error(\"",
    (map {GP_string_escape($_)} @_),
    "\")\n";
  exit 0;
}

#------------------------------------------------------------------------------
# Main

my $option_gp = 1;
my $option_table = 'prime';
{
  # callback option arg in perl 5.8 is a string, but in 5.10 it's a
  # Getopt::Long::Callback object, must stringize to get the plain name
  my $set_table = sub {
    my ($opt) = @_;
    $option_table = "$opt";
  };

  GetOptions (require_order => 1,
              'verbose:i'  => \$option_verbose,
              version => sub {
                print "$FindBin::Script version ",main->VERSION,"\n";
                exit 0;
              },
              gp    => \$option_gp,
              'check-version:s' => sub {
                my ($opt,$value) = @_;
                ### check-version: $value
              },
              prime => sub { $option_table = 'prime'; },
              pi    => sub { $option_table = 'pi'; },
              '<>' => sub {
                my ($n) = @_;
                # stringize to avoid Getopt::Long object
                $n = "$n";
                $n =~ /^\d+$/ or output_error("Not a number: ",$n);
                $n =~ s/^0+(.)/$1/;
                print read_or_download($option_table,$n),"\n";
              },
             )
    or exit 1;
}

exit 0;
