File: gss-server.pl

package info (click to toggle)
libgssapi-perl 0.28-4
  • links: PTS, VCS
  • area: main
  • in suites: bookworm, forky, sid, trixie
  • size: 412 kB
  • sloc: perl: 758; makefile: 6
file content (136 lines) | stat: -rwxr-xr-x 3,430 bytes parent folder | download | duplicates (5)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
#!/usr/bin/perl

use strict;
use warnings;

use Getopt::Long;
use Sys::Hostname;

use IO::Socket::INET;

use GSSAPI;
use MIME::Base64;


my %opt;

#
# Arguments:
#   kname syntax is prodid@hostname or prodid@servicename
#         e.g.: host@server1
#         e.g.: mqm@mqserver1
#

unless (GetOptions(\%opt, qw(keytabfile=s hostname=s port=s))) {
    exit(1);
}

if(! $opt{port}) {
    warn "$0: -port not specified, defaulting to 10000\n";
    $opt{port} = 10000;
}

if(! $opt{hostname}) {
    $opt{hostname} = hostname();
    warn "$0: -name not specified, using hostname result [" . $opt{hostname} . "]\n";
}
warn "$0: using [" . $opt{hostname} .':' .$opt{port} . "]\n";
#
# Servers need keytab files, the only standard so far is /etc/krb5.keytab.
# That's the file meant to contain keys for the local machine. It is readable
# only by root for security reasons. In this case the name is host@machinename.
#

$ENV{KRB5_KTNAME} = "FILE:" . $opt{keytabfile};
if (! -r $opt{keytabfile}) {
    die "Cannot read ". $opt{keytabfile} .": $!";
}

print "SERVER set environment variable KRB5_KTNAME to " . $ENV{KRB5_KTNAME} . "\n";

my $listen_socket = IO::Socket::INET->new (
			   Listen    => 16,
			   LocalHost => $opt{hostname},
			   LocalPort => $opt{port},
			   ReuseAddr => 1,
			   Proto     => 'tcp',
			);

die "Unable to create listen socket: $!" unless $listen_socket;

print "Listening on port $opt{port} ...\n";

my $error = 0;

while (! $error) {

    my $server_context;
    print "\nSERVER::waiting for request ...\n";
    my $client_socket = $listen_socket->accept();
    unless ($client_socket) {
	warn "SERVER::accept failed: $!";
	next;
    }

    print "SERVER::accepted connection from client ...\n";
    my $gss_input_token = <$client_socket>;

    $gss_input_token = decode_base64($gss_input_token);
    print "SERVER::received token (length is " . length($gss_input_token) . "):\n";

    if (length($gss_input_token) ) {
	my $status = GSSAPI::Context::accept(
			$server_context,
			GSS_C_NO_CREDENTIAL,
			$gss_input_token,
			GSS_C_NO_CHANNEL_BINDINGS,
			my $gss_client_name,
			my $out_mech,
			my $gss_output_token,
			my $out_flags,
			my $out_time,
			my $gss_delegated_cred);

	$status or  gss_exit("Unable to accept security context", $status);
        my $client_name;
	$status = $gss_client_name->display($client_name);
        $status or  gss_exit("Unable to display client name", $status);
	print "SERVER::authenticated client name is $client_name\n" if $client_name;

	if($gss_output_token) {
	    print "SERVER::Have mutual token to send ...\n";
	    print "SERVER::GSS token size: " . length($gss_output_token) . "\n";

	    #
	    # $gss_output_token is binary data
	    #

	    my $enc_token = encode_base64($gss_output_token, '');

	    print $client_socket "$enc_token\n";
	    print "SERVER::sent token (length is " . length($gss_output_token) . ")\n";
	}
   }
   # $server_context->DESTROY() if $server_context;
}

print "SERVER::exiting after error\n";

################################################################################

sub gss_exit {
  my $errmsg = shift;
  my $status = shift;

  my @major_errors = $status->generic_message();
  my @minor_errors = $status->specific_message();

  print STDERR "$errmsg:\n";
  foreach my $s (@major_errors) {
    print STDERR "  MAJOR::$s\n";
  }
  foreach my $s (@minor_errors) {
    print STDERR "  MINOR::$s\n";
  }
  return 1;
}