#!/usr/bin/env perl
use warnings;
use strict;

use LWP::UserAgent    ();
use HTML::TreeBuilder ();
use File::Slurper     qw(read_text read_lines write_text);
use URI::Escape       qw(uri_escape);
use Getopt::Long      qw(GetOptions);
use HTML::Entities    qw(encode_entities);

use Data::Dumper;
$Data::Dumper::Indent = 1;

my $couchdb_api   = 'https://docs.couchdb.org/en/stable';
my $couchdb_index = "$couchdb_api/http-routingtable.html";
my $couchdb_cache = '/tmp/couch-cache';
my $metacpan      = 'https://metacpan.org/dist/Couch-DB/view/';

GetOptions
	'refresh|r!' => \(my $refresh = 0),
	;

my %index;         # from the couchdb website
my %impls_by_call; # from this module
my %impls_by_use;  # from this module

my %http_order;
$http_order{$_} = keys %http_order for qw/GET POST PUT COPY DELETE/;

####
###### parse the couchdb api index
####

sub fill_index()
{
	my $routing;
	if($refresh || ! -r $couchdb_cache || -M $couchdb_cache > 14)
	{	print "Loading new routing table from couchdb.org\n";
		my $ua = LWP::UserAgent->new;
		my $overview = $ua->get($couchdb_index);
		$routing     = $overview->decoded_content;
		write_text $couchdb_cache, $routing;
	}
	else
	{	$routing     = read_text $couchdb_cache;
	}
	
	my $tree = HTML::TreeBuilder->new_from_content($routing);
	#my $table = $tree->elementify->find('table');
	foreach my $tr ($tree->elementify->find('table')->find('tr'))
	{	my (undef, $which, $what) = $tr->find('td');
		my ($a)  = $which->find('a') or next;
		my $href = $a->attr('href');
		my $call = $a->find_by_attribute(class => 'xref')->content->[0];

		# Mistake in 3.3.3 docs
		$call    = 'POST /{db}/_design/{ddoc}/_update/{func}/{docid}'
			if $call eq 'PUT /{db}/_design/{ddoc}/_update/{func}/{docid}';

		my ($http_method, $endpoint) = split " ", $call, 2;
		my $descr = $what->as_text;
	
		my %def    = (
			call        => $call,
			http_method => $http_method,
			endpoint    => $endpoint,
			doclink     => "$couchdb_api/$href",
			descr       => $descr,
		);
		$index{$call} = \%def;
	}

	# These are only described in notes in 3.3.3
	foreach my $endpoint ('/{db}/_local_docs/queries', '/{db}/_design_docs/queries')
	{	my %def = %{$index{'POST /{db}/_all_docs/queries'}};
		$def{call}     = "POST $endpoint";
		$def{endpoint} = $endpoint;
		$def{descr}    = '';
		$index{"POST $endpoint"} = \%def;
	}

	warn "Found ", scalar keys %index, " calls in the API docs\n";

}

####
###### parse the docs from implementation
####

my @modules = (
	{ file => 'lib/Couch/DB.pm',			base => '$couch' },
	{ file => 'lib/Couch/DB/Client.pm',		base => '$client' },
	{ file => 'lib/Couch/DB/Cluster.pm',	base => '$cluster' },
	{ file => 'lib/Couch/DB/Database.pm',	base => '$db' },
	{ file => 'lib/Couch/DB/Document.pm',	base => '$doc' },
 	{ file => 'lib/Couch/DB/Design.pm',		base => '$ddoc' },
	{ file => 'lib/Couch/DB/Node.pm',		base => '$node' },
);

sub fill_impls_by_call()
{
  MODULE:
	foreach my $module (@modules)
	{	my $last_use;
		my $package;

		my $file = $module->{file};
		unless(-e $file)
		{	print "Module $file does not exist yet.\n";
			next MODULE;
		}

		my $manpage  = $metacpan . ($file =~ s/\.pm$/.pod/r);

		foreach my $line (read_lines $file)
		{	$package = $1
				if $line =~ m/^package\s+([\w:]+)/;

			$last_use = "$module->{base}->$1($2)"
				if $line =~ m/^=method\s+(\w+)\s*(.*)/;

			my ($call, $status) = $line =~ /\[CouchDB API "([^"]+)".*?(|UNTESTED|TODO|UNSUPPORTED|PARTIAL)\]/
				or next;

			my ($http_method, $endpoint) = split " ", $call, 2;

			my $link = $manpage . '#' . uri_escape($last_use =~ s/.*->/\$obj->/r =~ s/\s/-/gr);
			my $use  = $status eq 'UNSUPPORTED' ? ''
			  : '<a href="' . $link . '">' . encode_entities($last_use) . '</a>';

			my %impl = (
				package     => $package,
				call        => $call,
				status      => $status || 'DONE',
				http_method => $http_method,
				endpoint    => $endpoint,
				use         => $use,
			);

			push @{$impls_by_call{$call}}, \%impl;
			push @{$impls_by_use{$use}}, \%impl if length $use;
		}
	}

	warn "Found ", scalar keys %impls_by_call, " calls implemented.\n";
}

####
###### MAIN
####

fill_index;
#warn Dumper \%index;

fill_impls_by_call;
#warn Dumper \%impls_by_call;

my %http_method_counts;
map $http_method_counts{$_->{http_method}}++, @$_ for values %impls_by_call;
warn Dumper \%http_method_counts;

my %status_counts;
map $status_counts{$_->{status}}++, @$_ for values %impls_by_call;
warn Dumper \%status_counts;

my %mistakes = map +($_ => 1), keys %impls_by_call;
delete @mistakes{keys %index};

warn "Implementation mismatch: $_\n" for sort keys %mistakes;

sub progress()
{	print <<__PROGRESS;
  <h2>Development progress counts</h2>

  <p>The implementation is really new, therefore, not everything is ready and
  complete.  Below, you find the follow conditions.
  <table id="status-explain">
  <tr><td>DONE</td>
      <td class="count">$status_counts{DONE}</td>
      <td>Minimally tested: sometimes visual inspection only.</td></tr>
  <tr><td>PARTIAL</td>
      <td class="count">$status_counts{PARTIAL}</td>
      <td>Minimally tested, not completely implemented.</td></tr>
  <tr><td>UNTESTED</td>
      <td class="count">$status_counts{UNTESTED}</td>
      <td>Implemented but never tried.</td></tr>
  <tr><td>TODO</td>
      <td class="count">$status_counts{TODO}</td>
      <td>Implementation not started.</td></tr>
  <tr><td>UNSUPPORTED</td>
      <td class="count">$status_counts{UNSUPPORTED}</td>
      <td>For some reason, it seems useless to implement this.</td></tr>
  </table>
__PROGRESS
}

sub cdb2mod()
{	print <<__HEADER;
  <h2 name="cdb2mod">CouchDB endpoint &rarr; Couch::DB method</h2>
  <ul>
  <li><a href="#mod2cdb">Couch::DB method &rarr; CouchDB endpoint</a></li>
  </ul>

  <table id="cdb2mod">
  <tr><th style="width: 50%"><a href="https://docs.couchdb.org/en/stable/">CouchDB API "stable"</a> and official summary</th>
      <th>impl status</th>
      <th>Couch::DB use</th></tr>

__HEADER

	foreach my $index (sort { $a->{endpoint} cmp $b->{endpoint} || $a->{http_method} cmp $b->{http_method}} values %index)
	{	my @impls = @{$impls_by_call{$index->{call}} || [ ]};
		@impls <= 2 or die $index->{call};  # CSS descr issue

		my $first = shift @impls || { status => 'MISSING', use => '' };

		print <<__ROW1;
  <tr class="first">
      <td class="api"><a href="$index->{doclink}">$index->{call}</a></td>
      <td class="status">$first->{status}</td>
      <td class="use">$first->{use}</td></tr>
__ROW1

		my $sec   = shift @impls;

		print $sec ? <<__ROW2a : <<__ROW2b;
  <tr><td class="descr"><p>$index->{descr}</p></td>
      <td class="status">$sec->{status}</td>
      <td class="use">$sec->{use}</td></tr>
__ROW2a
  <tr><td class="descr"><p>$index->{descr}</p></td>
      <td>&nbsp;</td>
      <td>&nbsp;</td></tr>
__ROW2b

	}

	print <<__FOOTER;
  </table>
__FOOTER
}


sub mod2cdb()
{
	print <<__HEADER;
  <h2 name="mod2cdb">Couch::DB method &rarr; CouchDB endpoint</h2>
  <ul>
  <li><a href="#cdb2mod">CouchDB endpoint &rarr; Couch::DB method</a></li>
  </ul>

  <table id="mod2cdb">
  <tr><th>Couch::DB use</th>
      <th>impl status</th>
      <th style="width: 50%"><a href="https://docs.couchdb.org/en/stable/">CouchDB API "stable"</a></th></tr>

__HEADER

	foreach my $use (sort keys %impls_by_use)
	{	my @calls;
		foreach my $impl (@{$impls_by_use{$use}})
		{	my $call = $index{$impl->{call}} or die $impl->{call};
			$call->{status} = $impl->{status};
			push @calls, $call;
		}
		my ($first, @other) = sort { $http_order{$a->{http_method}} <=> $http_order{$b->{http_method}} } @calls;

		print <<__ROW1;
  <tr><td class="use">$use</td>
      <td class="status">$first->{status}</td>
      <td class="api"><a href="$first->{doclink}">$first->{call}</a></td></tr>
__ROW1

		print <<__ROW_FOLLOW for @other;
  <tr><td>&nbsp;</td>
      <td class="status">$_->{status}</td>
      <td class="api"><a href="$_->{doclink}">$_->{call}</a></td></tr>
__ROW_FOLLOW
	}

	print <<__FOOTER;
  </table>
__FOOTER
}

### COMPOSE THE PAGE

print <<__PAGE_HEADER;
<!DOCTYPE html>
<html lang="en-EN">
<head>
  <title>Reference table</title>
  <meta charset="utf-8" />

  <style>
	BODY      { background: #f4f4f4; margin: 3em 5em }
    TR.first  { margin-top: 4px }
	TH        { background: lightgreen; padding: 3px 2ex }
    TD        { vertical-align: top; padding: 0 2ex }
    TD.api    { background: white }
    TD.use    { background: yellow }
    TD.api  A { text-decoration: none; font-family: monospace }
    TD.use  A { text-decoration: none; font-family: monospace }
	TD.descr P { margin: 0 0 10px 0; }
    TH { text-align: left }
    .count { text-align: right }
	TABLE#status-explain { padding-left: 3em }
  </style>
</head>
<body>
  <h1>Reference tables</h1>

  <p>This page is generated when anything in the implementation changes,
  at least every release.  Sorry for the current ugly presentation: functionality
  first.</p>
__PAGE_HEADER

progress;
cdb2mod;
mod2cdb;

print <<__PAGE_FOOTER;
</body>
</html>
__PAGE_FOOTER

