# 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;

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

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

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

sub mechanism { 'GSSAPI' }

sub _init {
  my ($pkg, $self) = @_;
  bless $self, $pkg;

  # set default security properties
  $self->property('minssf',      0);
  $self->property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
  $self->property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
  $self->property('externalssf', 0);
  $self;
}

sub client_start {
  my $self = shift;
  my $status;
  my $principal = $self->service.'@'.$self->host;

  # GSSAPI::Name->import is the *constructor*,
  # storing the new GSSAPI::Name into $target.
  # GSSAPI::Name->import is not the standard
  # import() method as used in Perl normally
  my $target;
  $status = GSSAPI::Name->import($target, $principal, gss_nt_service_name)
    or return $self->set_error("GSSAPI Error : ".$status);
  $self->{gss_name}  = $target;
  $self->{gss_ctx}   = new GSSAPI::Context;
  $self->{gss_state} = 0;
  $self->{gss_layer} = undef;
  $self->{gss_cred}  = $self->_call('pass') || GSS_C_NO_CREDENTIAL;
  $self->{gss_mech}  = $self->_call('gssmech') || gss_mech_krb5;

  # reset properties for new session
  $self->property(maxout => undef);
  $self->property(ssf    => undef);

  return $self->client_step('');
}

sub client_step {
  my ($self, $challenge) = @_;
  my $debug = $self->{debug};

  my $status;

  if ($self->{gss_state} == 0) {
    my $outtok;
    my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props
    my $outflags;
    $status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name}, 
			     $self->{gss_mech},
			     $inflags, 
			     0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef, 
			     $outtok, $outflags, undef);

    print STDERR "state(0): ".
		$status->generic_message.';'.$status->specific_message.
		"; output token sz: ".length($outtok)."\n"
	if ($debug & 1);
    if (GSSAPI::Status::GSS_ERROR($status->major)) {
      return $self->set_error("GSSAPI Error (init): ".$status);
    }
    if ($status->major == GSS_S_COMPLETE) {
      $self->{gss_state} = 1;
    }
    return $outtok;
  }
  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. 
    print STDERR "  state(1): challenge is EMPTY\n"
		if ($debug and $challenge eq '');
    return ''  if ($challenge eq '');
 
    my $unwrapped;
    $status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef)
      or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status);

    return $self->set_error("GSSAPI Error : invalid security layer token")
      if (length($unwrapped) != 4);

    # the security layers the server supports: bitmask of
    #   1 = no security layer,
    #   2 = integrity protection,
    #   4 = confidelity protection
    # which is encoded in the first octet of the response;
    # the remote maximum buffer size is encoded in the next three octets
    #
    my $layer = ord(substr($unwrapped, 0, 1, chr(0)));
    my ($rsz) = unpack('N',$unwrapped);

    # get local receive buffer size
    my $lsz = $self->property('maxbuf');

    # choose security layer
    my $choice = $self->_layer($layer,$rsz,$lsz);
    return $self->set_error("GSSAPI Error: security too weak") unless $choice;

    $self->{gss_layer} = $choice;

    if ($choice > 1) {
	# determine maximum plain text message size for peer's cipher buffer
	my $psz;
	$status = $self->{gss_ctx}->wrap_size_limit($choice == 4, 0, $rsz, $psz)
	    or return $self->set_error("GSSAPI Error (wrap size): ".$status);
	return $self->set_error("GSSAPI wrap size = 0") unless ($psz);
	$self->property(maxout => $psz);
    } else {
	# our advertised buffer size should be 0 if no layer selected
	$lsz = 0;
    }

    print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n"
	if ($debug & 1);

    # set SSF property
    # Note: choice 1 (no layer) and 2 (integrity only) will produce
    # the expected ssf values of 0 and 1 respectively.
    # choice 4 (confidentiality) would require an estimate of the strength
    # of the actual encryption ciphers in use and this isn't available
    # from the GSSAPI routines. For now, just err on the safe side.
    $self->property(ssf => ($choice - 1));

    my $message = pack('CCCC', $choice,
			($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff);

    # append authorization identity if we have one
    my $authz = $self->_call('authname');
    $message .= $authz if ($authz);

    my $outtok;
    $status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok)
      or return $self->set_error("GSSAPI Error (wrap token): ".$status);
    
    $self->{gss_state} = 0;
    return $outtok;
  }
}

# default layer selection
sub _layer {
  my ($self, $theirmask, $rsz, $lsz) = @_;
  my $maxssf = $self->property('maxssf') - $self->property('externalssf');
  $maxssf = 0 if ($maxssf < 0);

  my $minssf = $self->property('minssf') - $self->property('externalssf');
  $minssf = 0 if ($minssf < 0);

  return undef if ($maxssf < $minssf);    # sanity check

  # ssf values > 1 mean integrity and confidentiality
  # ssf == 1 means integrity but no confidentiality
  # ssf < 1 means neither integrity nor confidentiality
  # no security layer can be had if buffer size is 0
  my $ourmask = 0;
  $ourmask |= 1 if ($minssf < 1);
  $ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
  $ourmask |= 4 if ($maxssf > 1);
  $ourmask &= 1 unless ($rsz and $lsz);

  # mask the bits we dont have
  $ourmask &= $theirmask;

  # select the highest bit still set
  return 4 if ($ourmask & 4);
  return 2 if ($ourmask & 2);
  return 1 if ($ourmask & 1);
  return undef;
}

sub encode {  # input: self, plaintext buffer,length (length not used here)
  my $self = shift;
  my $wrapped;
  my $status = $self->{gss_ctx}->wrap($self->{gss_layer} == 4, 0, $_[0], undef, $wrapped);
  $self->set_error("GSSAPI Error (encode): " . $status), return
    unless ($status);
  return $wrapped;
}

sub decode {  # input: self, cipher buffer,length (length not used here)
  my $self = shift;
  my $unwrapped;
  my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef);
  $self->set_error("GSSAPI Error (decode): " . $status), return
    unless ($status);
  return $unwrapped;
}

__END__

=head1 NAME

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

=head1 SYNOPSIS

  use Authen::SASL qw(Perl);

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

  $sasl = Authen::SASL->new( mechanism => 'GSSAPI',
 			     callback => { pass => $mycred });

=head1 DESCRIPTION

This method implements the client part of the GSSAPI SASL algorithm,
as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt.

With a valid Kerberos 5 credentials cache (aka TGT) it allows
to connect to I<service>@I<host> given as the first two parameters
to Authen::SASL's client_start() method.  Alternatively, a GSSAPI::Cred
object can be passed in via the Authen::SASL callback hash using
the `pass' key.

Please note that this module does not currently implement a SASL
security layer following authentication. Unless the connection is
protected by other means, such as TLS, it will be vulnerable to
man-in-the-middle attacks. If security layers are required, then the
Authen::SASL::Cyrus GSSAPI module should be used instead.

=head2 CALLBACK

The callbacks used are:

=over 4

=item authname

The authorization identity to be used in SASL exchange

=item gssmech

The GSS mechanism to be used in the connection

=item pass 

The GSS credentials to be used in the connection (optional)

=back


=head1 EXAMPLE

 #! /usr/bin/perl -w

 use strict;

 use Net::LDAP 0.33;
 use Authen::SASL 2.10;

 # -------- Adjust to your environment --------
 my $adhost      = 'theserver.bla.net';
 my $ldap_base   = 'dc=bla,dc=net';
 my $ldap_filter = '(&(sAMAccountName=BLAAGROL))';

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

 eval {
     $ldap = Net::LDAP->new($adhost,
                            onerror => 'die')
       or  die "Cannot connect to LDAP host '$adhost': '$@'";
     $ldap->bind(sasl => $sasl);
 };

 if ($@) {
     chomp $@;
     die   "\nBind error         : $@",
           "\nDetailed SASL error: ", $sasl->error,
           "\nTerminated";
 }

 print "\nLDAP bind() succeeded, working in authenticated state";

 my $mesg = $ldap->search(base   => $ldap_base,
                          filter => $ldap_filter);

 # -------- evaluate $mesg 

=head2 PROPERTIES

The properties used are:

=over 4

=item maxbuf

The maximum buffer size for receiving cipher text

=item minssf

The minimum SSF value that should be provided by the SASL security layer.
The default is 0

=item maxssf

The maximum SSF value that should be provided by the SASL security layer.
The default is 2**31

=item externalssf

The SSF value provided by an underlying external security layer.
The default is 0

=item ssf

The actual SSF value provided by the SASL security layer after the SASL
authentication phase has been completed. This value is read-only and set
by the implementation after the SASL authentication phase has been completed.

=item maxout

The maximum plaintext buffer size for sending data to the peer.
This value is set by the implementation after the SASL authentication
phase has been completed and a SASL security layer is in effect.

=back


=head1 SEE ALSO

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

=head1 AUTHORS

Written by Simon Wilkinson, with patches and extensions by Achim Grolms
and 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, Achim Grolms and Peter Marschall.
All rights reserved. This program is free software; you can redistribute 
it and/or modify it under the same terms as Perl itself.

=cut