=head1 OVERVIEW

An OpenID server must perform three tasks:

=over

=item 1.

Examine the incoming request to determine its nature and validity.

=item 2.

Make a decision about how to respond to this request.

=item 3.

Format the response according to the protocol.

=back

The first and last of these tasks may performed by
the L</decodeRequest> and
L</encodeResponse> methods of the
Server object.  Who gets to do the intermediate task -- deciding
how to respond to the request -- will depend on what type of request it
is.

If it's a request to authenticate a user (a C<checkid_setup> or
C<checkid_immediate> request), you need to decide if you will assert
that this user may claim the identity in question.  Exactly how you do
that is a matter of application policy, but it generally involves making
sure the user has an account with your system and is logged in, checking
to see if that identity is hers to claim, and verifying with the user that
she does consent to releasing that information to the party making the
request.

Examine the properties of the L</CheckIDRequest> object, and if
and when you've come to a decision, form a response by calling
C<</CheckIDRequest->answer>>.

Other types of requests relate to establishing associations between client
and server and verifying the authenticity of previous communications.
The Server instance contains all the logic and data necessary to
respond to
such requests; just pass it to the L</handleRequest> method.

=head2 OpenID Extensions

Do you want to provide other information for your users
in addition to authentication?  Version 1.2 of the OpenID
protocol allows consumers to add extensions to their requests.
For example, with sites using the L<Simple Registration Extension|http://www.openidenabled.com/openid/simple-registration-extension/>,
a user can agree to have their nickname and e-mail address sent to a
site when they sign up.

Since extensions do not change the way OpenID authentication works,
code to handle extension requests may be completely separate from the
L</OpenIDRequest> class here.  But you'll likely want data sent back by
your extension to be signed.  L</OpenIDResponse> provides methods with
which you can add data to it which can be signed with the other data in
the OpenID signature.

For example:

    # when request is a checkid_* request
    response = request.answer(True)
    # this will a signed 'openid.sreg.timezone' parameter to the response
    response.addField('sreg', 'timezone', 'America/Los_Angeles')

=head2 Stores

The OpenID server needs to maintain state between requests in order
to function.  Its mechanism for doing this is called a store.  The
store interface is defined in L<Net::OpenID::JanRain::Stores>.
Additionally, several concrete store implementations are provided, so that
most sites won't need to implement a custom store.  For a store backed
by flat files on disk, see L<Net::OpenID::JanRain::Stores::FileStore>.
For stores based on PostGreSQL, MySQL or SQLite, see the 
L<Net::OpenID::JanRain::Stores::SQLStore|Net::OpenID::JanRain::Stores::SQLStore>
module.

=cut

package Net::OpenID::JanRain::Server::Request;

use strict;
use warnings;
use Carp;

=head1 Net::OpenID::JanRain::Server::Request

The parent class for several types of requests.  None of these classes
are to be instantiated by the user, but this class will never
be encountered except as a parent.

=head2 Method

=head3 mode

Returns the C<openid.mode> parameter of this request.

=cut

my $errorClass = 'Net::OpenID::JanRain::Server::ProtocolError';

sub mode {
    my $self = shift;
    return $self->{mode};
}

package Net::OpenID::JanRain::Server::CheckAuthRequest;
our @ISA = qw( Net::OpenID::JanRain::Server::Request );
use Carp;
use strict;
use warnings;

use Net::OpenID::JanRain::Util qw( hashToPairs );

use constant {
    OPENID_PREFIX  =>  'openid.',
};

=head2 Net::OpenID::JanRain::Server::CheckAuthRequest

A request object for C<openid.mode=check_authentication>.
This request is best handled by the L</handleRequest> method of
the L</Net::OpenID::JanRain::Server> object.

However, it does possess an C<answer> method which takes a 
L</Net::OpenID::JanRain::Server::Signatory> object.

=cut

sub new {
    my ($caller, $assoc_handle, $sig, $signed) = @_;
    my $invalidate_handle = shift;

    my $class = ref($caller) || $caller;

    my $self = {
      mode              => 'check_authentication',
      assoc_handle      => $assoc_handle,
      sig               => $sig,
      signed            => $signed,
      invalidate_handle => $invalidate_handle,
    };

    bless($self, $class);
}

sub fromQuery {
    my ($caller, $query) = @_;

    my $assoc_handle = $query->{OPENID_PREFIX . 'assoc_handle'};
    my $sig = $query->{OPENID_PREFIX . 'sig'};
    my $signed_list = $query->{OPENID_PREFIX . 'signed'};
    my $invalidate_handle = $query->{OPENID_PREFIX . 'invalidate_handle'};

    unless (defined($assoc_handle) and 
            defined($sig) and 
            defined($signed_list)) {
        return $errorClass->new($query, "check_authentication request missing required parameters.");
    }
    
    my @signed_list = split ',', $signed_list;
    my %vq = %$query;
    $vq{OPENID_PREFIX . 'mode'} = 'id_res';

    my $signed_pairs = hashToPairs(\%vq, \@signed_list, OPENID_PREFIX);
    return $errorClass->new($query, "Query missing arg in signed list") unless $signed_pairs;
    
    my $self = {
                mode => 'check_authentication',
                assoc_handle => $assoc_handle,
                signed => $signed_pairs,
                sig => $sig,
                invalidate_handle => $invalidate_handle,
                };

    bless($self);
}

sub answer {
    my ($self, $signatory) = @_;

    my $is_valid = $signatory->verify($self->{assoc_handle}, $self->{sig}, $self->{signed});

    $signatory->invalidate($self->{assoc_handle}, 1);
    my $response = Net::OpenID::JanRain::Server::Response->new($self);
    $response->addFields('',{'is_valid' => (($is_valid and "true") or "false")});

    if ($self->{invalidate_handle}) {
        my $assoc = $signatory->getAssociation($self->{invalidate_handle}, 0);
        $response->addFields('',{'invalidate_handle' => $self->{invalidate_handle}}) unless $assoc;
    }
    return $response;
}


package Net::OpenID::JanRain::Server::AssociateRequest;
our @ISA = qw( Net::OpenID::JanRain::Server::Request );

use strict;
use warnings;
use Carp;
use Crypt::DH;
use Net::OpenID::JanRain::Util qw( toBase64 fromBase64 );
use Net::OpenID::JanRain::CryptUtil qw( base64ToNum
                                        numToBase64 
                                        numToBytes
                                        sha1
                                        DEFAULT_DH_MOD 
                                        DEFAULT_DH_GEN );

use constant {
    OPENID_PREFIX  =>  'openid.',
};

=head2 Net::OpenID::JanRain::Server::AssociateRequest

A request object for C<openid.mode=associate>.
This request is best handled by the L</handleRequest> method of
the L</Net::OpenID::JanRain::Server> object.

However, it does possess an C<answer> method which takes an
L<Net::OpenID::JanRain::Association|Net::OpenID::JanRain::Association>
object.  It also has accessor methods C<assoc_type> and C<session_type>.

=cut


sub new {
    my ($caller, $session_type, $pubkey);

    my $class = ref($caller) || $caller;
    
    my $self;
    if ($session_type eq 'DH-SHA1') {
        $self = {
            mode            => 'associate',
            session_type    => $session_type,
            pubkey          => $pubkey,
            dh              => Crypt::DH->new(p => DEFAULT_DH_MOD,
                                              g => DEFAULT_DH_GEN ),
        };
    }
    else {
        $self = {
            session_type    => $session_type,
        }
    }
    bless($self, $class);
}

sub fromQuery {
    my ($caller, $query) = @_;
    my $class = ref($caller) || $caller;


    my $assoc_type = $query->{OPENID_PREFIX . 'assoc_type'} || 'HMAC-SHA1';

    unless ($assoc_type eq 'HMAC-SHA1') {
        return $errorClass->new($query, "Unknown association type '$assoc_type'");
    }
    
    my $session_type = $query->{OPENID_PREFIX . 'session_type'};

    my $self = {};
    unless ($session_type) {
        $session_type = 'plaintext';
    }
    if ($session_type eq 'DH-SHA1') {
        my $raw_cpub = $query->{OPENID_PREFIX . 'dh_consumer_public'};
        unless ($raw_cpub) {
            return $errorClass->new($query, 
                    'DH-SHA1 associate request has no public key');
        }
        my $cpub = base64ToNum($raw_cpub); 
        unless (defined($cpub)) {
            return $errorClass->new($query, 
                    'DH public key improperly encoded');
        }        

        my $dh_modulus = $query->{OPENID_PREFIX . 'dh_modulus'};
        if (defined($dh_modulus)) {
            $dh_modulus = base64ToNum($dh_modulus);
            unless (defined($dh_modulus)) {
                 return $errorClass->new($query, 
                    'DH modulus improperly encoded');           
            }
        }
        else {
            $dh_modulus = DEFAULT_DH_MOD;
        }
        my $dh_gen = $query->{OPENID_PREFIX . 'dh_gen'};
        if (defined($dh_gen)) {
            $dh_gen = base64ToNum($dh_gen);
            unless (defined($dh_gen)) {
                 return $errorClass->new($query, 
                    'DH gen improperly encoded');           
            }
        }
        else {
            $dh_gen = DEFAULT_DH_GEN;
        }
        
        $self = {
            mode         => 'associate',
            session_type => 'DH-SHA1',
            assoc_type   => $assoc_type,
            pubkey       => $cpub,
            dh           => Crypt::DH->new(g => $dh_gen, p => $dh_modulus),
        };
    }
    elsif ($session_type eq 'plaintext') {
        $self = {
            mode         => 'associate',
            session_type => 'plaintext',
            assoc_type   => $assoc_type,
        }
    }
    else {
        return $errorClass->new($query, "Unknown session type '$session_type'");
    }
    bless($self, $class);
}

sub answer {
    my ($self, $assoc) = @_;
    
    my $response = Net::OpenID::JanRain::Server::Response->new($self);

    $response->addFields('',{
        assoc_handle    => $assoc->handle,
        expires_in      => $assoc->expiresIn(),
        assoc_type      => 'HMAC-SHA1',
        });
    if ($self->session_type eq 'DH-SHA1') {
        my $dh = $self->{dh};
        $dh->generate_keys;
        my $dh_secret = $dh->compute_secret($self->{pubkey});
        my $enc_mac_key = $assoc->{secret} ^ sha1(numToBytes($dh_secret));
        my $spub = $dh->pub_key;
        $response->addFields('',{
            session_type        => $self->session_type,
            dh_server_public    => numToBase64($spub),
            enc_mac_key         => toBase64($enc_mac_key),
            });
    }
    elsif ($self->session_type eq 'plaintext') {
        $response->addFields('',{mac_key => toBase64($assoc->secret)});
    }
    else {
    # XXX - kablooie
    }
    return $response;
}

sub session_type {
    my $self = shift;
    return $self->{session_type};
}

sub assoc_type {
    my $self = shift;
    return $self->{assoc_type};
}

package Net::OpenID::JanRain::Server::CheckIDRequest;
our @ISA = qw( Net::OpenID::JanRain::Server::Request );

use strict;
use warnings;
use URI;

use constant {
    OPENID_PREFIX  =>  'openid.',
};

=head2 Net::OpenID::JanRain::Server::CheckIDRequest

This object represents requests where C<openid.mode=checkid_setup> or
C<openid.mode=checkid_immediate>.  It is returned by the L</decodeRequest>
method of L<Net::OpenID::JanRain::Server>.

=head3 Methods

=cut

sub new {
    my ($caller, $identity, $return_to, $optional) = @_;
    my $trust_root = $optional->{trust_root};
    my $immediate = $optional->{immediate};
    my $assoc_handle = $optional->{assoc_handle};
    my $class = ref($caller) || $caller;

    my $self = {
        assoc_handle => $assoc_handle,
        identity     => $identity,
        return_to    => $return_to,
        trust_root   => $trust_root || $return_to,
    };
    if ($immediate) {
        $self->{immediate} = 1;
        $self->{mode} = 'checkid_immediate';
    }
    else {
        $self->{immediate} = 0;
        $self->{mode} = 'checkid_setup';
    }

    my ($tr_valid, $message) = 
            checkTrustRoot($self->{trust_root}, $self->{return_to});
    unless ($tr_valid) {
        carp $message;
        return undef;
    }

    bless($self, $class);
}

sub fromQuery {
    my ($caller, $query) = @_;
    my $class = ref($caller) || $caller;

    my $mode = $query->{OPENID_PREFIX.'mode'};
    my $self;
    if ($mode eq "checkid_immediate") {
        $self = {
            immediate   => 1,
            mode        => 'checkid_immediate',
            trust_root  => $query->{OPENID_PREFIX.'trust_root'} 
                            || $query->{OPENID_PREFIX.'return_to'},
            assoc_handle=> $query->{OPENID_PREFIX.'assoc_handle'},
        };
    }
    else {
        $self = {
            immediate   => 0,
            mode        => 'checkid_setup',
            trust_root  => $query->{OPENID_PREFIX.'trust_root'}
                            || $query->{OPENID_PREFIX.'return_to'},
            assoc_handle=> $query->{OPENID_PREFIX.'assoc_handle'},
        };
    }
    my @required = ('identity', 'return_to'); 

    for my $field (@required) {
        my $value = $query->{OPENID_PREFIX.$field};
        unless ($value) {
            return $errorClass->new($query, "$field is a required field for a $mode request");
        }
        $self->{$field} = $value;
    }

    my ($tr_valid, $message) = 
            checkTrustRoot($self->{trust_root}, $self->{return_to});
    return $errorClass->new($query, $message) unless $tr_valid;

    bless($self, $class);
}

=head4 answer

 $response = $request->answer($allow, $server_url);

=over

=item $allow

A boolean value: if true, sends an C<id_res> response.  If false,
sends a C<cancel> response if the request is not immediate, and
C<setup_needed> if it is immediate.

=item $server_url

This argument is required if the request is immediate, and should be the
URL of the server endpoint, used to construct the setup URL.

=back

=cut

sub answer {
    my $self = shift;
    my $allow = shift;
    my $server_url = shift;
    
    my $response = Net::OpenID::JanRain::Server::Response->new($self);
    
    if($allow) {
        $response->addFields('',{
            mode        => 'id_res',
            identity    => $self->identity,
            return_to   => $self->return_to,
            }, 1);
    }
    else {
        if ($self->immediate) {
            croak('server_url is required for allow=false in immediate mode')
                unless $server_url;
            # Make a new request just like me, but with immediate=False.
            my $setup_request = Net::OpenID::JanRain::Server::CheckIDRequest->new(
                    $self->identity, $self->return_to, $self->trust_root,
                    0, $self->assoc_handle);
            my $setup_url = $setup_request->encodeToURL($server_url);
            $response->addFields('',{ mode           => 'id_res',
                                      user_setup_url => $setup_url
                                    }, 0); # unsigned
        }
        else {
            $response->addFields('',{mode => 'cancel'},0); # unsigned
        }
    }
    return $response;
}

=head3 encodeToURL

Takes the server endpoint URL and returns a URL which would generate this
request.

=cut

sub encodeToURL {
    my ($self, $server_url) = @_;
    
    my $q = {
        OPENID_PREFIX.'mode'        => $self->mode,
        OPENID_PREFIX.'identity'    => $self->identity,
        OPENID_PREFIX.'return_to'   => $self->return_to
        };
    $q->{OPENID_PREFIX.'trust_root'} = $self->trust_root if $self->trust_root;
    $q->{OPENID_PREFIX.'assoc_handle'} = $self->assoc_handle if $self->assoc_handle;
    
    return appendArgs($server_url, $q);
}

=head3 getCancelURL

Returns a URL to redirect the user to send a cancel message to the consumer.
Calling this method will cause croakage if the request is in immediate mode.

=cut

sub getCancelURL {
    my $self = shift;

    croak('Cancel is not an appropriate response to an immediate mode request') if $self->immediate;

    return appendArgs($self->return_to, {OPENID_PREFIX.'mode'=>'cancel'});
}

=head3 checkTrustRoot

 $is_return_to_valid_against_trust_root = checkTrustRoot($trust_root, $return_to);

=cut

# in Util now, maybe should be removed?
sub checkTrustRoot {
    my ($trust_root, $return_to) = @_;

    my $rt = URI->new($return_to);
    my $tr = URI->new($trust_root);
    
    return 0, "return_to URL invalid against trust_root: scheme"
        unless $rt->scheme eq $tr->scheme;

    # Check the host
    my $trh = $tr->host;
    if($trh =~ s/^\*\.//) { # wildcard trust root
        return 0, "return_to URL invalid against trust_root: wchost"
            unless ($rt->host =~ /\w*\.?$trh/ and $rt->port == $tr->port);
    }
    else { # no wildcard
        return 0, "return_to URL invalid against trust_root: host"
            unless $tr->host_port eq $rt->host_port;
    }
    
    # Check the path and query
    my $trp = $tr->path_query;
    return 0, "return_to URL invalid against trust_root: path"
        unless $rt->path_query =~ /^$trp/;

    # success
    return 1, "return_to URL valid against trust_root";
}

=head3 Accessor Methods

=over

=item C<trust_root>

=item C<identity>

=item C<return_to>

=item C<immediate>

=item C<assoc_handle>

=back

=cut

sub trust_root {
    my $self = shift;
    return $self->{trust_root};
}

sub return_to {
    my $self = shift;
    return $self->{return_to};
}

sub identity {
    my $self = shift;
    return $self->{identity};
}

sub immediate {
    my $self = shift;
    return $self->{immediate};
}

sub assoc_handle {
    my $self = shift;
    return $self->{assoc_handle};
}

package Net::OpenID::JanRain::Server::Response;

use strict;
use warnings;

use Net::OpenID::JanRain::Util qw( hashToKV );

use constant {
    OPENID_PREFIX  =>  'openid.',
};

use Net::OpenID::JanRain::Util qw( appendArgs );

=head1 Net::OpenID::JanRain::Server::Response

This object is returned by the C<answer> methods of
L</Net::OpenID::JanRain::Server::Request> objects.

=head2 Methods

=cut

sub new {
    my ($caller, $request) = @_;
    
    my $class = ref($caller) || $caller;
    
    my $self = {
        request => $request,
        fields => {},
        };

    bless($self, $class);
}

=head3 whichEncoding

Returns 'url' if the response should be returned in a redirect URL,
and 'kvform' if the response should be returned as a plaintext KV form
response.

=cut

sub whichEncoding {
    my $self = shift;
    if($self->request->mode eq 'checkid_immediate' or $self->request->mode eq 'checkid_setup') {
        return 'url';
    }
    else {
        return 'kvform';
    }
}

=head3 signed

Returns a boolean value indicating whether the response should be signed.

=cut

sub signed {
    my $self = shift;

    return $self->{signed};
}

=head3 encodeToURL

Returns a URL for redirecting the user to send the response.

=cut

sub encodeToURL {
    my $self = shift;
    my $fields = {};
    while (my ($key, $value) = each %{$self->{fields}}) {
        my $gnocchi = OPENID_PREFIX.$key;
        $fields->{$gnocchi} = $value;
    }
    return appendArgs($self->request->return_to, $fields);
}

=head3 encodeToKVForm

Returns a KV form string to put in the body of the HTTP response.

=cut

sub encodeToKVForm {
    my $self = shift;
    return hashToKV($self->fields);
}

=head3 addField

 $response->addField($namespace, $key, $value, $signed);

Adds an OpenID field to the response, possibly in an extension namespace.

=head4 Arguments

=over

=item namespace

The namespace to put the field in.  '' or undef will put the field in the
root openid namespace.

=item key

=item value

=item signed

Whether this field should be signed.  Defaults to true if the response
is to a C<checkid_setup> or C<checkid_immediate> request, and false 
otherwise.

=back

=cut

sub addField {
    my $self = shift;
    my $namespace = shift;
    my $key = shift;
    my $value = shift;
    my $signed = shift;
    $signed = ($self->request->mode eq 'checkid_setup' or $self->request->mode eq 'checkid_immediate') unless defined($signed);

    $key = "$namespace.".$key if $namespace;
    $self->{fields}->{$key} = $value;


    if($signed) {
        $self->{signed} = [] unless defined($self->{signed});
        push @{$self->{signed}}, $key;
    }

}

=head3 addFields

 $response->addFields($namespace, \%fields, $signed);

Much like C<addField>, but takes a hash reference containing a number
key/value pairs.

=cut

sub addFields {
    my $self = shift;
    my $namespace = shift;
    my $fields = shift;
    my $signed = shift;

    while (my ($key, $value) = each %$fields) {
        $self->addField($namespace, $key, $value, $signed);
    }
}

=head3 fields

An accessor method for the fields hash ref.

=cut

sub fields {
    my $self = shift;
    return $self->{fields};
}

=head3 request

Returns the request this response is responding to.

=cut

sub request {
    my $self = shift;
    return $self->{request};
}


package Net::OpenID::JanRain::Server::WebResponse;

use strict;
use warnings;

=head1 Net::OpenID::JanRain::Server::WebResponse

This object is meant to be easily encoded into an HTTP response in your
application.

=head2 Accessor Methods

=over

=item code

The HTTP code to use on your response.

=item headers

A hash reference of headers to put on your response.

=item body

The body of the response.

=back

=cut

sub new {
    my ($caller, $code, $headers, $body) = @_; #XXX optionals

    my $class = ref($caller) || $caller;

    my $self = {
        code    => $code,
        headers => $headers,
        body    => $body,
        };

    bless($self,$class);
}

sub code {
    my $self = shift;
    return $self->{code};
}

sub headers {
    my $self = shift;
    return $self->{headers};
}

sub body {
    my $self = shift;
    return $self->{body};
}

package Net::OpenID::JanRain::Server::ProtocolError;

use strict;
use warnings;
use constant {
    OPENID_PREFIX  =>  'openid.',
};

use Net::OpenID::JanRain::Util qw( appendArgs hashToKV );

=head1 Net::OpenID::JanRain::Server::ProtocolError

Objects of this class are returned by XXX when the consumer sends us an
improper request.  It may be encoded to a web response in the same manner
that a L</Net::OpenID::JanRain::Server::Response> object is encoded.

=cut

sub new {
    my $caller = shift;
    my $query = shift;
    my $text = shift;
    my $class = ref($caller) || $caller;

    my $self = {query => $query};
    if ($text) {
        $self->{text} = $text;
    }
    else {
        warn "Error without text";
    }

    bless($self, $class);
}

=head3 text

Returns a string describing the error.

=cut

sub text {
    my $self = shift;
    return $self->{text};
}

=head3 query

returns the query that led to the error.

=cut

sub query {
    my $self = shift;
    return $self->{query};
}

=head3 hasReturnTo

Do we have a return_to URL to send the error back to the server?
(only relevant when the c<whichEncoding> method returns 'url')

=cut

sub hasReturnTo {
    my $self = shift;
    $self->{query} and return 1 if $self->{query}->{OPENID_PREFIX.'return_to'};
    return 0;
}

=head3 encodeToURL

Generates and returns a URL for redirecting the user to alert the consumer
of the error.

=cut

sub encodeToURL {
    my $self = shift;
    my $return_to = $self->{query}->{OPENID_PREFIX.'return_to'};
    
    unless ($return_to) {
        carp("OpenID ProtocolError has no return_to URL to encode onto");
        return undef;
    }

    return appendArgs($return_to, {'openid.mode'  => "error", 
                                   'openid.error' => $self->{text}});
}

=head3 encodeToKVForm

Generates and returns a KV form string for returning in the body of the
response to the consumer.

=cut

sub encodeToKVForm {
    my $self = shift;

    return hashToKV({mode=>'error', error=>$self->text});
}

=head3 fields

Returns a hash ref of the response fields.

=cut

sub fields {
    my $self = shift;
    return {mode=>'error', error=>$self->text};
}

=head3 whichEncoding

Returns a string, either 'url', or 'kvform', based on how the error
should be encoded for transmission.

=cut

sub whichEncoding {
    my $self = shift;

    return undef unless $self->{query};

    my $mode = $self->{query}->{OPENID_PREFIX.'mode'};
    my $return_to = $self->{query}->{OPENID_PREFIX.'return_to'};

    if(($mode eq 'checkid_setup' or $mode eq 'checkid_immediate') and
        $self->hasReturnTo()) {
        return 'url';
    } else {
        return 'kvform';
    }
}

package Net::OpenID::JanRain::Server::Signatory;

use strict;
use warnings;
use Carp;

use Net::OpenID::JanRain::Util qw( toBase64 );
use Net::OpenID::JanRain::CryptUtil qw( randomString );

my $SECRET_LIFETIME = 14 * 24 * 60 * 60; # seconds in a fortnight

# keys have a bogus server URL in them because the filestore
# really does expect that key to be a URL.  This seems a little
# silly for the server store, since I expect there to be only one
# server URL.
my $_normal_key = 'http://localhost/|normal';
my $_dumb_key = 'http://localhost/|dumb';

=head1 Net::OpenID::JanRain::Server::Signatory

This object signs responses and checks signatures.  One is contained
inside every  C<Net::OpenID::JanRain::Server> object.

If you use the
L</encodeResponse> method of the C<Net::OpenID::JanRain::Server> object,
you won't have to know how this object works.  All the object state is
in the OpenID store.

=cut

sub new {
    my ($caller, $store) = @_;

    my $class = ref($caller) || $caller;

    unless ($store->isa('Net::OpenID::JanRain::Stores')) {
        carp "Need an instance of Net::OpenID::JanRain::Stores";
        return undef;
    }
    
    my $self = {store => $store};
    bless($self, $class);
}

=head3 verify

 $is_valid = $signatory->verify($assoc_handle, $sig, $signed_pairs);

=cut

sub verify {
    my ($self, $assoc_handle, $sig, $signed_pairs) = @_;

    my $assoc = $self->getAssociation($assoc_handle, 1);
    
    return 0 unless ($assoc);
    my $expected_sig = toBase64($assoc->signPairs($signed_pairs));

    return $sig eq $expected_sig;
}

=head3 sign

 $signatory->sign($response);

=cut

sub sign {
    my ($self, $response) = @_;

    my $assoc_handle = $response->request->assoc_handle;

    my $assoc;
    if ($assoc_handle) {
        $assoc = $self->getAssociation($assoc_handle, 0);
        unless ($assoc) {
            # We don't have that association.  Send the invalidate handle
            # message back, and fall back on dumb mode.
            $response->addFields('',{invalidate_handle => $assoc_handle});
            $assoc = $self->createAssociation(1);
        }
    }
    else {
        $assoc = $self->createAssociation(1);
    }
    $response->addFields('', {assoc_handle => $assoc->handle}, 0);
    $assoc->addSignature($response->{fields}, $response->signed); 

    return $response;
}

=head3 createAssociation

 $assoc = $signatory->createAssociation($dumbp);

=cut

sub createAssociation {
    my $self = shift;
    my $dumb = shift;
    
    my $assoc_type = 'HMAC-SHA1';
    my $secret = randomString(20);
    my $uniq = toBase64(randomString(4));
    my $now = time;
    my $handle = "_${assoc_type}_${now}_${uniq}_";
    
    $handle = "_d$handle" if $dumb;
    
    my $assoc = Net::OpenID::JanRain::Association->fromExpiresIn(
        $SECRET_LIFETIME, $handle, $secret, $assoc_type);

    if ($dumb) {
        $self->{store}->storeAssociation($_dumb_key, $assoc);
    }
    else {
        $self->{store}->storeAssociation($_normal_key, $assoc);
    }
    return $assoc;
}

=head3 getAssociation

$assoc = $signatory->getAssociation($assoc_handle, $dumb);

=cut

sub getAssociation {
    my ($self, $assoc_handle, $dumb) = @_;
    
    unless (defined($assoc_handle)) {
        carp("assoc_handle must be defined");
        return undef;
    }

    my $key;
    if ($dumb) {
        $key = $_dumb_key;
    }
    else {
        $key = $_normal_key;
    }
    my $store = $self->{store};
    my $assoc = $store->getAssociation($key, $assoc_handle);
    if (defined($assoc) and $assoc->expiresIn == 0) {
        # oid_log("requested association $assoc_handle is expired");
        $store->removeAssociation($key, $assoc_handle);
        return undef;
    }
    return $assoc;
}

=head3 invalidate

 $signatory->invalidate($assoc_handle, $dumb);

=cut

sub invalidate {
    my ($self, $assoc_handle, $dumb) = @_;

    if ($dumb) {
        $self->{store}->removeAssociation($_dumb_key, $assoc_handle);
    }
    else {
        $self->{store}->removeAssociation($_normal_key, $assoc_handle);
    }
}

package Net::OpenID::JanRain::Server;

use strict;
use warnings;
use Net::OpenID::JanRain::Util qw( appendArgs hashToKV );
use Carp;

use constant {
    OPENID_PREFIX  =>  'openid.',
};

my $signatoryClass='Net::OpenID::JanRain::Server::Signatory';
my $webResponseClass='Net::OpenID::JanRain::Server::WebResponse';

=head1 Net::OpenID::JanRain::Server

This object handles requests for an OpenID server.

Queries in hash-ref form may be turned into
L</Net::OpenID::JanRain::Server::Request> objects with the
L</decodeRequest> method.

Requests which are not C<checkid> requests may be passed to the
L<handleRequest> method, and a response will be returned.

L</Net::OpenID::JanRain::Server::Response> objects may be transformed
into L</Net::OpenID::JanRain::Server::WebResponse> objects with the
L<endodeResponse> method, which will also sign the responses if necessary.

=head2 Methods

=head3 new

 $server = new Net::OpenID::JanRain::Server($store);

Instantiate this object with an instance of C<Net::OpenID::JanRain::Stores>.

=cut

sub new {
    my ($caller, $store) = @_;
    my $class = ref($caller) || $caller;

    my $signatory = $signatoryClass->new($store);
    unless (defined($signatory)) {
        carp "Failed to instantiate signatory";
        return undef;
    }
    
    my $self = {
###        store     => $store,
        signatory => $signatory
    };

    bless($self, $class);
}

=head3 handleRequest

Call this method on a L</Net::OpenID::JanRain::Server::Request> object
that is not a L</Net::OpenID::JanRain::Server::CheckIDRequest> and 
the appropriate L</Net::OpenID::JanRain::Server::Response> object will
be returned.

=cut

sub handleRequest {
    my ($self, $request) = @_;

    my $mode = $request->mode;
    if ($mode eq 'check_authentication') {
        return $self->openid_check_authentication($request);
    }
    elsif ($mode eq 'associate') {
        return $self->openid_associate($request);
    }
    else {
        warn "No handler for mode $mode";
        return undef;
    }
}

=head3 signatory

An accessor method to get the signatory object used by the server.

=cut

sub signatory {
    my $self = shift;
    return $self->{signatory};
}

sub openid_check_authentication {
    my ($self, $request) = @_;
    return $request->answer($self->{signatory});
}

sub openid_associate {
    my ($self, $request) = @_;
    my $signatory = $self->{signatory};
    my $assoc = $signatory->createAssociation(0);
    return $request->answer($assoc);
}

=head3 decodeRequest

 $response = $server->decodeRequest(\%query);

This method takes a hash ref of an OpenID query and returns an
L</Net::OpenID::JanRain::Server::Request> object.

=cut

sub decodeRequest {
    my ($self, $query) = @_;
    
    return undef unless %$query;

    my $oidp = 'openid.';
    $oidp =~ s/\./\\./; # escape the dang .
    my $myquery = {};
    while(my ($k, $v) = each %$query) {
        $myquery->{$k} = $v if $k =~ /^$oidp/;
    }
    return undef unless %$myquery;

    my $mode = $myquery->{OPENID_PREFIX.'mode'};

    return $errorClass->new($query, "Query is missing mode") unless $mode;

    if($mode eq 'checkid_setup' or $mode eq 'checkid_immediate') {
        return Net::OpenID::JanRain::Server::CheckIDRequest->fromQuery($query);
    }
    elsif($mode eq 'check_authentication') {
        return Net::OpenID::JanRain::Server::CheckAuthRequest->fromQuery($query);
    }
    elsif($mode eq 'associate') {
        return Net::OpenID::JanRain::Server::AssociateRequest->fromQuery($query);
    }
    else {
        return $errorClass->new($query, "Unknown mode $mode");
    }
}

=head3 encodeResponse

 $web_response = $server->encodeResponse($response);

This method takes a L</Net::OpenID::JanRain::Server::Response> object
and returns the appropriate L</Net::OpenID::JanRain::Server::WebResponse>
object.

=cut

sub encodeResponse {
    my ($self, $response) = @_;
    
    my $encode_as = $response->whichEncoding();

    if ($encode_as eq 'kvform') {
        my $wr = $webResponseClass->new(200, {}, $response->encodeToKVForm);
    }
    elsif($encode_as eq 'url') {

        if ($response->signed) {
            unless ($response->fields->{sig}) {
                my $signatory = $self->{signatory};
                $signatory->sign($response);
            }
        }
        my $wr = $webResponseClass->new(302, 
            {Location => $response->encodeToURL}, undef);
    }
}