<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># 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.05";
@ISA = qw(Authen::SASL::Perl);

my %secflags = (
  noplaintext =&gt; 1,
  noanonymous =&gt; 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-&gt;property('minssf',      0);
  $self-&gt;property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
  $self-&gt;property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
  $self-&gt;property('externalssf', 0);
  # the cyrus sasl library allows only one bit to be set in the
  # layer selection mask in the client reply, we default to
  # compatibility with that bug
  $self-&gt;property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
  $self;
}

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

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

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

  return $self-&gt;client_step('');
}

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

  my $status;

  if ($self-&gt;{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-&gt;{gss_ctx}-&gt;init($self-&gt;{gss_cred}, $self-&gt;{gss_name}, 
			     $self-&gt;{gss_mech},
			     $inflags, 
			     0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef, 
			     $outtok, $outflags, undef);

    print STDERR "state(0): ".
		$status-&gt;generic_message.';'.$status-&gt;specific_message.
		"; output token sz: ".length($outtok)."\n"
      if ($debug &amp; 1);

    if (GSSAPI::Status::GSS_ERROR($status-&gt;major)) {
      return $self-&gt;set_error("GSSAPI Error (init): ".$status);
    }
    if ($status-&gt;major == GSS_S_COMPLETE) {
      $self-&gt;{gss_state} = 1;
    }
    return $outtok;
  }
  elsif ($self-&gt;{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-&gt;{gss_ctx}-&gt;unwrap($challenge, $unwrapped, undef, undef)
      or return $self-&gt;set_error("GSSAPI Error (unwrap challenge): ".$status);

    return $self-&gt;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-&gt;property('maxbuf');

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

    $self-&gt;{gss_layer} = $choice;

    if ($choice &gt; 1) {
	# determine maximum plain text message size for peer's cipher buffer
	my $psz;
	$status = $self-&gt;{gss_ctx}-&gt;wrap_size_limit($choice &amp; 4, 0, $rsz, $psz)
	    or return $self-&gt;set_error("GSSAPI Error (wrap size): ".$status);
	return $self-&gt;set_error("GSSAPI wrap size = 0") unless ($psz);
	$self-&gt;property(maxout =&gt; $psz);
	# set SSF property; if we have just integrity protection SSF is set
	# to 1. If we have confidentiality, SSF would be an estimate of the
	# strength of the actual encryption ciphers in use which is not
	# available through the GSSAPI interface; for now just set it to
	# the lowest value that signifies confidentiality.
	$self-&gt;property(ssf =&gt; (($choice &amp; 4) ? 2 : 1));
    } else {
	# our advertised buffer size should be 0 if no layer selected
	$lsz = 0;
	$self-&gt;property(ssf =&gt; 0);
    }

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

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

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

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

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

  my $minssf = $self-&gt;property('minssf') - $self-&gt;property('externalssf');
  $minssf = 0 if ($minssf &lt; 0);

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

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

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

  return $ourmask unless $self-&gt;property('COMPAT_CYRUSLIB_REPLY_MASK_BUG');
	
  # in cyrus sasl bug compat mode, select the highest bit set
  return 4 if ($ourmask &amp; 4);
  return 2 if ($ourmask &amp; 2);
  return 1 if ($ourmask &amp; 1);
  return undef;
}

sub encode {  # input: self, plaintext buffer,length (length not used here)
  my $self = shift;
  my $wrapped;
  my $status = $self-&gt;{gss_ctx}-&gt;wrap($self-&gt;{gss_layer} &amp; 4, 0, $_[0], undef, $wrapped);
  $self-&gt;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-&gt;{gss_ctx}-&gt;unwrap($_[0], $unwrapped, undef, undef);
  $self-&gt;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-&gt;new( mechanism =&gt; 'GSSAPI' );

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

  $sasl-&gt;client_start( $service, $host );

=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&lt;service&gt;@I&lt;host&gt; 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
L&lt;Authen::SASL::XS&gt; 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 = '(&amp;(sAMAccountName=BLAAGROL))';

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

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

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

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

 my $mesg = $ldap-&gt;search(base   =&gt; $ldap_base,
                          filter =&gt; $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&lt;Authen::SASL&gt;,
L&lt;Authen::SASL::Perl&gt;

=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
&lt;perl-ldap@perl.org&gt;

=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
</pre></body></html>