use warnings;
use strict;

package Net::OAuth2::Scheme::Mixin::VTable;
BEGIN {
  $Net::OAuth2::Scheme::Mixin::VTable::VERSION = '0.02';
}
# ABSTRACT: the 'vtable', 'vtable_cache', and 'vtable_pull_queue' option groups

use Net::OAuth2::Scheme::Option::Defines;

#      parse_token
#        @token -> validator_id, @payload
#      vtable_lookup
#        validator_id -> @validator
#      validate
#        @validator, @payload -> valid?, issue_time, expires_in, scope, client_id

#   @token = (token_string [, param => value]*)
#   @validator = (@secrets [, expiration, scope, ext])
# Token scheme determines format of @secrets, @payload and @validator
# Expiration+@scope may live in either @payload or @validator
#
# What needs to be communicated/shared privately
# between Authorization and Resource servers
#    RS -> AS:  server_id
#    AS -> RS:  vtable == (secret_id -> expiration, @data) hash/map

# INTERFACE vtable
# DEFINES
# (AS) vtable_insert
# (RS) vtable_lookup
Define_Group vtable => 'shared_cache',
  qw(vtable_insert vtable_lookup);

# IMPLEMENTATION vtable_shared_cache FOR vtable
# SUMMARY
#   secure shared cache, everybody can read/write
# REQUIRES
#   vtable_cache
# NOTES
#   vtable_insert = vtable_put
#   vtable_lookup = vtable_get
#   this works for
#   (*) AS and RS being the same process
#   (*) AS and RS being on the same host
#       cache is file-based or shared-memory cache
#   (*) AS and RS are on the same server farm
#       cache is memcached
sub pkg_vtable_shared_cache {
    my __PACKAGE__ $self = shift;
    if ($self->is_auth_server) {
        $self->install( vtable_insert => $self->uses('vtable_put'));
    }
    if ($self->is_resource_server) {
        $self->install( vtable_lookup => $self->uses('vtable_get'));
    }
    return $self;
}

# IMPLEMENTATION vtable_authserv_push FOR vtable
# SUMMARY
#   RS-local cache with AS pushing each new entry
# REQUIRES
#   vtable_cache (+ (RS) vtable_put)
#   vtable_push(entry) => send entry
#   push handler => recv entry, vtable_pushed(entry)
# EXPORTS
#   vtable_pushed (for push handler)
# NOTES
#   vtable_insert = vtable_push
#   vtable_lookup = vtable_get
#   vtable_pushed = vtable_put

sub pkg_vtable_authserv_push {
    my __PACKAGE__ $self = shift;
    if ($self->is_auth_server) {
        $self->install( vtable_insert => $self->uses('vtable_push'));
    }
    if ($self->is_resource_server) {
        $self->install( vtable_lookup => $self->uses('vtable_get'));
        $self->install( vtable_pushed => $self->uses('vtable_put'));
        $self->export('vtable_pushed');
    }
    return $self;
}

# IMPLEMENTATION vtable_resource_pull FOR vtable
# SUMMARY
#   RS-local cache with RS pulling on cache miss
# REQUIRES
#   vtable_cache
#   vtable_pull_queue
#   vtable_pull => send query, return response
#   pull handler => recv query, respond vtable_dump(query)
# EXPORTS
#   vtable_dump  (for pull handler)
# NOTES
#   vtable_insert = vtable_enqueue
#   vtable_lookup is
#     vtable_get or
#     (vtable_load(vtable_pull(vtable_query)) and
#      retry vtable_get)

sub pkg_vtable_resource_pull {
    my __PACKAGE__ $self = shift;
    if ($self->is_auth_server) {
        $self->install( vtable_insert => $self->uses('vtable_enqueue'));
        $self->export('vtable_dump');
    }
    if ($self->is_resource_server) {
        my ( $vtable_get, $vtable_load, $vtable_query, $vtable_pull) = $self->uses_all
          (qw(vtable_get   vtable_load   vtable_query   vtable_pull));
        $self->install( vtable_lookup => sub {
            my $v_id = shift;
            my ($error, @found) = $vtable_get->($v_id);
            unless ($error || @found) {
                ($error) = $vtable_load->($vtable_pull->($vtable_query->()));
                return $error if $error;
                ($error,@found) = $vtable_get->($v_id);
            }
            return ($error, @found);
        });
    }
    return $self;
}

# INTERFACE vtable_cache
# DEFINES
#  vtable_put : id,expiration,@stuff ->;
#  vtable_get : id -> expiration,@stuff
Define_Group vtable_cache => 'object',
  qw(vtable_put vtable_get);


Default_Value cache_grace => 300;
Default_Value cache_prefix => 'vtab';

# vtable_cache_object
# IMPLEMENTS vtable_cache
# REQUIRES
#   cache => Cache::Memory, Cache::File, or Cache::Memcached object
# OPTIONS
#   cache_grace => number;
#     delay cache expiration by this many seconds (default = 300)
#   cache_prefix => string
#     keys are prefixed with this (default = 'vtab:')
sub pkg_vtable_cache_object {
    my __PACKAGE__ $self = shift;
    my ( $cache,     $grace,     $prefix) = $self->uses_all(
       qw(cache cache_grace cache_prefix));

    $prefix .= ':' if length($prefix) && $prefix !~ m/:\z/;
    $self->croak("cache_prefix ($prefix) cannot contain interior colon (:)")
        if length($prefix) && $prefix =~ m{:[^:]};

    $self->install( vtable_get => sub {
        my $v = $cache->thaw($prefix . $_[0]);
        return (undef, @{defined($v) ? $v : []});
    });
    $self->install( vtable_put => sub {
        my $id = shift;
        $cache->freeze($prefix . $id, [@_], $_[0] + $grace);
        return ();
    });
}

# INTERFACE vtable_pull_queue
# DEFINES
# (AS) vtable_enqueue
#      vtable_dump
# (RS) vtable_query
#      vtable_load
Define_Group vtable_pull_queue => 'default',
  qw(vtable_enqueue
     vtable_dump
     vtable_query
     vtable_load);

# default implementation
# REQUIRES
# (RS) vtable_put
sub pkg_vtable_pull_queue_default {
    my __PACKAGE__ $self = shift;
    if ($self->is_auth_server) {
        my $cache_grace = $self->uses('cache_grace');
        my $vpqueue = {};
        my $latest = [];

        $self->install( vtable_enqueue => sub {
            my ($v_id, $expiration, $now) = @_;

            # insert maintaining @$latest in order of increasing expiration
            my $i = $#{$latest};
            --$i while ($i >= 0 && $latest->[$i]->[1] > $expiration);
            splice @{$latest}, $i+1, 0, [@_];

            # prune expired entries from @$latest
            $i = 0;
            ++$i while ($i < @$latest && $latest->[$i]->[1] + $cache_grace < $now);
            splice @{$latest}, 0, $i;

            # prune expired entries from each batch of %$vpqueue
            for my $entries (values %{$vpqueue}) {
                $i = $#{$entries};
                --$i while ($i >= 0 && $entries->[$i]->[1] + $cache_grace < $now);
                splice @{$entries}, $i+1;
            }
            # remove empty batches from %$vpqueue
            delete @{$vpqueue}{grep {!@{$vpqueue->{$_}}} keys %{$vpqueue}};

            # never fails (?)
            return ();
        });

        $self->install( vtable_dump => sub {
            my ($now, $last_recv) = @_;
            # remove batches whose receipt has been acknowledged
            delete @{$vpqueue}{grep {$_ <= $last_recv} keys %$vpqueue};

            # insert @$latest entries into vpqueue
            if (@$latest) {
                unless (exists $vpqueue->{$now}) {
                    # make a new batch
                    $vpqueue->{$now} = [reverse @{$latest}];
                }
                else {
                    # merge into current batch; this should be rare
                    # and when it happens @$latest should be short
                    my $nqueue = $vpqueue->{$now};
                    for my $e (@{$latest}) {
                        my $i = 0;
                        ++$i while ($i < @{$nqueue} && $nqueue->[$i]->[1] > $e->[1]);
                        splice @{$nqueue}, $i, 0, $e;
                    }
                }
                $latest = [];
            }
            # send everything
            my @r = ();
            push @r, @$_ for values %{$vpqueue};
            return (undef, $now, \@r);
        });
    }
    if ($self->is_resource_server) {
        my $vtable_put = $self->uses('vtable_put');
        my $last_recv;
        $self->install( vtable_query => sub {
            my $now = time();
            return ($now, (defined($last_recv) && $now == $last_recv
                           ? $last_recv - 1 : $last_recv));
        });
        $self->install( vtable_load => sub {
            my ($error, $now, $recvd) = @_;
            return ($error) if $error;
            for my $entry (@$recvd) {
                $vtable_put->(@$entry);
            }
            $last_recv = $now;
            return (undef, scalar(@$recvd));
        });
    }
    return $self;
}


1;


__END__
=pod

=head1 NAME

Net::OAuth2::Scheme::Mixin::VTable - the 'vtable', 'vtable_cache', and 'vtable_pull_queue' option groups

=head1 VERSION

version 0.02

=head1 DESCRIPTION

This is an internal module that implements the abstract shared cache
for sharing secrets between authorization servers and resource
servers.

See L<Net::OAuth2::Scheme::Factory> for actual option usage.

=head1 AUTHOR

Roger Crew <crew@cs.stanford.edu>

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2012 by Roger Crew.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

