1# Copyright (c) 2006 Simon Wilkinson
2# All rights reserved. This program is free software; you can redistribute
3# it and/or modify it under the same terms as Perl itself.
4
5package Authen::SASL::Perl::GSSAPI;
6
7use strict;
8
9use vars qw($VERSION @ISA);
10use GSSAPI;
11
12$VERSION= "0.05";
13@ISA = qw(Authen::SASL::Perl);
14
15my %secflags = (
16  noplaintext => 1,
17  noanonymous => 1,
18);
19
20sub _order { 4 }
21sub _secflags {
22  shift;
23  scalar grep { $secflags{$_} } @_;
24}
25
26sub mechanism { 'GSSAPI' }
27
28sub _init {
29  my ($pkg, $self) = @_;
30  bless $self, $pkg;
31
32  # set default security properties
33  $self->property('minssf',      0);
34  $self->property('maxssf',      int 2**31 - 1);    # XXX - arbitrary "high" value
35  $self->property('maxbuf',      0xFFFFFF);         # maximum supported by GSSAPI mech
36  $self->property('externalssf', 0);
37  # the cyrus sasl library allows only one bit to be set in the
38  # layer selection mask in the client reply, we default to
39  # compatibility with that bug
40  $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
41  $self;
42}
43
44sub client_start {
45  my $self = shift;
46  my $status;
47  my $principal = $self->service.'@'.$self->host;
48
49  # GSSAPI::Name->import is the *constructor*,
50  # storing the new GSSAPI::Name into $target.
51  # GSSAPI::Name->import is not the standard
52  # import() method as used in Perl normally
53  my $target;
54  $status = GSSAPI::Name->import($target, $principal, gss_nt_service_name)
55    or return $self->set_error("GSSAPI Error : ".$status);
56  $self->{gss_name}  = $target;
57  $self->{gss_ctx}   = new GSSAPI::Context;
58  $self->{gss_state} = 0;
59  $self->{gss_layer} = undef;
60  my $cred = $self->_call('pass');
61  $self->{gss_cred}  = (ref($cred) && $cred->isa('GSSAPI::Cred')) ? $cred : GSS_C_NO_CREDENTIAL;
62  $self->{gss_mech}  = $self->_call('gssmech') || gss_mech_krb5;
63
64  # reset properties for new session
65  $self->property(maxout => undef);
66  $self->property(ssf    => undef);
67
68  return $self->client_step('');
69}
70
71sub client_step {
72  my ($self, $challenge) = @_;
73  my $debug = $self->{debug};
74
75  my $status;
76
77  if ($self->{gss_state} == 0) {
78    my $outtok;
79    my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props
80    my $outflags;
81    $status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name},
82			     $self->{gss_mech},
83			     $inflags,
84			     0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef,
85			     $outtok, $outflags, undef);
86
87    print STDERR "state(0): ".
88		$status->generic_message.';'.$status->specific_message.
89		"; output token sz: ".length($outtok)."\n"
90      if ($debug & 1);
91
92    if (GSSAPI::Status::GSS_ERROR($status->major)) {
93      return $self->set_error("GSSAPI Error (init): ".$status);
94    }
95    if ($status->major == GSS_S_COMPLETE) {
96      $self->{gss_state} = 1;
97    }
98    return $outtok;
99  }
100  elsif ($self->{gss_state} == 1) {
101    # If the server has an empty output token when it COMPLETEs, Cyrus SASL
102    # kindly sends us that empty token. We need to ignore it, which introduces
103    # another round into the process.
104    print STDERR "  state(1): challenge is EMPTY\n"
105      if ($debug and $challenge eq '');
106    return '' if ($challenge eq '');
107
108    my $unwrapped;
109    $status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef)
110      or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status);
111
112    return $self->set_error("GSSAPI Error : invalid security layer token")
113      if (length($unwrapped) != 4);
114
115    # the security layers the server supports: bitmask of
116    #   1 = no security layer,
117    #   2 = integrity protection,
118    #   4 = confidelity protection
119    # which is encoded in the first octet of the response;
120    # the remote maximum buffer size is encoded in the next three octets
121    #
122    my $layer = ord(substr($unwrapped, 0, 1, chr(0)));
123    my ($rsz) = unpack('N',$unwrapped);
124
125    # get local receive buffer size
126    my $lsz = $self->property('maxbuf');
127
128    # choose security layer
129    my $choice = $self->_layer($layer,$rsz,$lsz);
130    return $self->set_error("GSSAPI Error: security too weak") unless $choice;
131
132    $self->{gss_layer} = $choice;
133
134    if ($choice > 1) {
135	# determine maximum plain text message size for peer's cipher buffer
136	my $psz;
137	$status = $self->{gss_ctx}->wrap_size_limit($choice & 4, 0, $rsz, $psz)
138	    or return $self->set_error("GSSAPI Error (wrap size): ".$status);
139	return $self->set_error("GSSAPI wrap size = 0") unless ($psz);
140	$self->property(maxout => $psz);
141	# set SSF property; if we have just integrity protection SSF is set
142	# to 1. If we have confidentiality, SSF would be an estimate of the
143	# strength of the actual encryption ciphers in use which is not
144	# available through the GSSAPI interface; for now just set it to
145	# the lowest value that signifies confidentiality.
146	$self->property(ssf => (($choice & 4) ? 2 : 1));
147    } else {
148	# our advertised buffer size should be 0 if no layer selected
149	$lsz = 0;
150	$self->property(ssf => 0);
151    }
152
153    print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n"
154	if ($debug & 1);
155
156    my $message = pack('CCCC', $choice,
157			($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff);
158
159    # append authorization identity if we have one
160    my $authz = $self->_call('authname');
161    $message .= $authz if ($authz);
162
163    my $outtok;
164    $status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok)
165      or return $self->set_error("GSSAPI Error (wrap token): ".$status);
166
167    $self->{gss_state} = 0;
168    return $outtok;
169  }
170}
171
172# default layer selection
173sub _layer {
174  my ($self, $theirmask, $rsz, $lsz) = @_;
175  my $maxssf = $self->property('maxssf') - $self->property('externalssf');
176  $maxssf = 0 if ($maxssf < 0);
177
178  my $minssf = $self->property('minssf') - $self->property('externalssf');
179  $minssf = 0 if ($minssf < 0);
180
181  return undef if ($maxssf < $minssf);    # sanity check
182
183  # ssf values > 1 mean integrity and confidentiality
184  # ssf == 1 means integrity but no confidentiality
185  # ssf < 1 means neither integrity nor confidentiality
186  # no security layer can be had if buffer size is 0
187  my $ourmask = 0;
188  $ourmask |= 1 if ($minssf < 1);
189  $ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
190  $ourmask |= 4 if ($maxssf > 1);
191  $ourmask &= 1 unless ($rsz and $lsz);
192
193  # mask the bits they dont have
194  $ourmask &= $theirmask;
195
196  return $ourmask unless $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG');
197
198  # in cyrus sasl bug compat mode, select the highest bit set
199  return 4 if ($ourmask & 4);
200  return 2 if ($ourmask & 2);
201  return 1 if ($ourmask & 1);
202  return undef;
203}
204
205sub encode {  # input: self, plaintext buffer,length (length not used here)
206  my $self = shift;
207  my $wrapped;
208  my $status = $self->{gss_ctx}->wrap($self->{gss_layer} & 4, 0, $_[0], undef, $wrapped);
209  $self->set_error("GSSAPI Error (encode): " . $status), return
210    unless ($status);
211  return $wrapped;
212}
213
214sub decode {  # input: self, cipher buffer,length (length not used here)
215  my $self = shift;
216  my $unwrapped;
217  my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef);
218  $self->set_error("GSSAPI Error (decode): " . $status), return
219    unless ($status);
220  return $unwrapped;
221}
222
223__END__
224
225=head1 NAME
226
227Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class
228
229=head1 SYNOPSIS
230
231  use Authen::SASL qw(Perl);
232
233  $sasl = Authen::SASL->new( mechanism => 'GSSAPI' );
234
235  $sasl = Authen::SASL->new( mechanism => 'GSSAPI',
236 			     callback => { pass => $mycred });
237
238  $sasl->client_start( $service, $host );
239
240=head1 DESCRIPTION
241
242This method implements the client part of the GSSAPI SASL algorithm,
243as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt.
244
245With a valid Kerberos 5 credentials cache (aka TGT) it allows
246to connect to I<service>@I<host> given as the first two parameters
247to Authen::SASL's client_start() method.  Alternatively, a GSSAPI::Cred
248object can be passed in via the Authen::SASL callback hash using
249the `pass' key.
250
251Please note that this module does not currently implement a SASL
252security layer following authentication. Unless the connection is
253protected by other means, such as TLS, it will be vulnerable to
254man-in-the-middle attacks. If security layers are required, then the
255L<Authen::SASL::XS> GSSAPI module should be used instead.
256
257=head2 CALLBACK
258
259The callbacks used are:
260
261=over 4
262
263=item authname
264
265The authorization identity to be used in SASL exchange
266
267=item gssmech
268
269The GSS mechanism to be used in the connection
270
271=item pass
272
273The GSS credentials to be used in the connection (optional)
274
275=back
276
277
278=head1 EXAMPLE
279
280 #! /usr/bin/perl -w
281
282 use strict;
283
284 use Net::LDAP 0.33;
285 use Authen::SASL 2.10;
286
287 # -------- Adjust to your environment --------
288 my $adhost      = 'theserver.bla.net';
289 my $ldap_base   = 'dc=bla,dc=net';
290 my $ldap_filter = '(&(sAMAccountName=BLAAGROL))';
291
292 my $sasl = Authen::SASL->new(mechanism => 'GSSAPI');
293 my $ldap;
294
295 eval {
296     $ldap = Net::LDAP->new($adhost,
297                            onerror => 'die')
298       or  die "Cannot connect to LDAP host '$adhost': '$@'";
299     $ldap->bind(sasl => $sasl);
300 };
301
302 if ($@) {
303     chomp $@;
304     die   "\nBind error         : $@",
305           "\nDetailed SASL error: ", $sasl->error,
306           "\nTerminated";
307 }
308
309 print "\nLDAP bind() succeeded, working in authenticated state";
310
311 my $mesg = $ldap->search(base   => $ldap_base,
312                          filter => $ldap_filter);
313
314 # -------- evaluate $mesg
315
316=head2 PROPERTIES
317
318The properties used are:
319
320=over 4
321
322=item maxbuf
323
324The maximum buffer size for receiving cipher text
325
326=item minssf
327
328The minimum SSF value that should be provided by the SASL security layer.
329The default is 0
330
331=item maxssf
332
333The maximum SSF value that should be provided by the SASL security layer.
334The default is 2**31
335
336=item externalssf
337
338The SSF value provided by an underlying external security layer.
339The default is 0
340
341=item ssf
342
343The actual SSF value provided by the SASL security layer after the SASL
344authentication phase has been completed. This value is read-only and set
345by the implementation after the SASL authentication phase has been completed.
346
347=item maxout
348
349The maximum plaintext buffer size for sending data to the peer.
350This value is set by the implementation after the SASL authentication
351phase has been completed and a SASL security layer is in effect.
352
353=back
354
355
356=head1 SEE ALSO
357
358L<Authen::SASL>,
359L<Authen::SASL::Perl>
360
361=head1 AUTHORS
362
363Written by Simon Wilkinson, with patches and extensions by Achim Grolms
364and Peter Marschall.
365
366Please report any bugs, or post any suggestions, to the perl-ldap mailing list
367<perl-ldap@perl.org>
368
369=head1 COPYRIGHT
370
371Copyright (c) 2006 Simon Wilkinson, Achim Grolms and Peter Marschall.
372All rights reserved. This program is free software; you can redistribute
373it and/or modify it under the same terms as Perl itself.
374
375=cut
376