# Copyright (c) 2006 Simon Wilkinson
# All rights reserved. This program is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.

package Authen::SASL::Perl::GSSAPI;

use strict;

use vars qw($VERSION @ISA);
use GSSAPI qw(:all);

$VERSION= "0.01";
@ISA = qw(Authen::SASL::Perl);

my %secflags = (
  noplaintext => 1,
  noanonymous => 1,
);

sub _order { 4 }
sub _secflags {
  shift;
  scalar grep { $secflags{$_} } @_;
}

sub mechanism { 'GSSAPI' }

#---------------------------------------------------------------------------------
sub client_start {
  my $self = shift;
  my $status;
  my $principal = $self->service.'@'.$self->host;
  
  my $target;
  $status = GSSAPI::Name->import( $target, 
                                  $principal, 
				  GSSAPI::OID::gss_nt_hostbased_service );
  if ( $status->major == GSS_S_COMPLETE ) {
      $self->{gss_ctx} = new GSSAPI::Context;
      $self->{gss_state} = 0;

      my $tname;
      $status = $target->display($tname);
      if ( $status->major != GSS_S_COMPLETE ) {die "GSSAPI Error : ".$status; }
      __debug_message(  " Name import OK $tname"); 
      $self->{gss_name} = $target; 
      return $self->client_step( q{} );
  }
  else {
       die 'GSSAPI name import error ', $self->host, ' ', $status; 
       return $self->set_error("GSSAPI Error : ".$status);
  }
}
#---------------------------------------------------------------------------------
sub client_step
{
  my ($self, $challenge) = @_;

  my $status;

  if ($self->{gss_state}==0) {

      my $itime = 0;
      my $bindings = GSS_C_NO_CHANNEL_BINDINGS;
      my $imech = GSSAPI::OID::gss_mech_krb5;
      
      my $iflags = GSS_C_MUTUAL_FLAG | GSS_C_INTEG_FLAG  ;
      my $creds = GSS_C_NO_CREDENTIAL;
      my ( $omech,$otoken,$oflags,$otime);
      
      $status = $self->{gss_ctx}->init( $creds,
                                        $self->{gss_name} ,
                                        $imech, $iflags, $itime, $bindings, $challenge,
                                        $omech,$otoken,$oflags,$otime);

      if ( $status->major == GSS_S_COMPLETE ) {
         $self->{gss_state} = 1;
          __debug_message(' reached GSS_S_COMPLETE ');
      } 
      else {
         if ( $status->major != GSS_S_CONTINUE_NEEDED ) {
            die ' init() error', $status; 
            #return $self->set_error("GSSAPI Error : " . $status); 
         }
         __debug_message(' reached GSS_S_CONTINUE_NEEDED ');
      }
      return $otoken;
  } elsif ($self->{gss_state}==1) {
    
    
    # If the server has an empty output token when it COMPLETEs, Cyrus SASL
    # kindly sends us that empty token. We need to ignore it, which introduces
    # another round into the process. 
    return "" if $challenge eq "";
 
    my $unwrapped;
    $status = $self->{gss_ctx}->unwrap( $challenge, 
                                        $unwrapped, 
                                        undef, 
                                        undef);
    if ( $status->major != GSS_S_COMPLETE ) { die 'unwrap error', $status; }
    __debug_message(' reached UNWRAP');

    # XXX - Security layer support will require us to decode this packet

    # Need to set message to be 0x01, 0x00, 0x00, 0x00 for no security layers
    my $message = pack('CCCC', 0x01, 0x00, 0x00, 0x00);
    $message.= $self->_call('user') if ( $self->_call('user') );

    my $outtok;
    $status = $self->{gss_ctx}->wrap( 0, 
                                      0, 
                                      $message, 
                                      0, 
                                      $outtok,
                                     );
    if ( $status->major != GSS_S_COMPLETE ) { die 'wrap error', $status; }                                     
    $self->{gss_state}=0;
    __debug_message(' reached WRAP');
    return $outtok;
  }
}
#-----------------------------------------------------------------------------
sub __debug_message {
   print "\n DEBUG Authen::SASL::Perl::GSSAPI", @_;
}
#-----------------------------------------------------------------------------
__END__

=head1 NAME

Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class

=head1 SYNOPSIS

  use Authen::SASL qw(Perl);

  $sasl = Authen::SASL->new( mechanism => 'GSSAPI' );

=head1 DESCRIPTION

This method implements the client part of the GSSAPI SASL algorithm.


=head1 SEE ALSO

L<Authen::SASL>,
L<Authen::SASL::Perl>

=head1 AUTHORS

Written by Simon Wilkinson,
Documentation by Peter Marschall.

Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>

=head1 COPYRIGHT 

Copyright (c) 2006 Simon Wilkinson.
All rights reserved. This program is free software; you can redistribute 
it and/or modify it under the same terms as Perl itself.

=cut