/// Low-level access to GSSAPI for Linux 32/64-bit platform.

// Both MIT and Heimdal implementation libraries are supported

// - this unit is a part of the freeware Synopse mORMot framework,

// licensed under a MPL/GPL/LGPL tri-license; version 1.18

unit SynGSSAPI;

{

This file is part of Synopse mORMot framework.

Synopse mORMot framework. Copyright (C) 2020 Arnaud Bouchez

Synopse Informatique - https://synopse.info

*** BEGIN LICENSE BLOCK *****

Version: MPL 1.1/GPL 2.0/LGPL 2.1

The contents of this file are subject to the Mozilla Public License Version

1.1 (the "License"); you may not use this file except in compliance with

the License. You may obtain a copy of the License at

http://www.mozilla.org/MPL

Software distributed under the License is distributed on an "AS IS" basis,

WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License

for the specific language governing rights and limitations under the License.

The Original Code is Synopse mORMot framework.

The Initial Developer of the Original Code is pavelmash/ssoftpro.

Portions created by the Initial Developer are Copyright (C) 2020

the Initial Developer. All Rights Reserved.

Contributor(s):

Arnaud Bouchez

ssoftpro

Chaa

Alternatively, the contents of this file may be used under the terms of

either the GNU General Public License Version 2 or later (the "GPL"), or

the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),

in which case the provisions of the GPL or the LGPL are applicable instead

of those above. If you wish to allow use of your version of this file only

under the terms of either the GPL or the LGPL, and not to allow others to

use your version of this file under the terms of the MPL, indicate your

decision by deleting the provisions above and replace them with the notice

and other provisions required by the GPL or the LGPL. If you do not delete

the provisions above, a recipient may use your version of this file under

the terms of any one of the MPL, the GPL or the LGPL.

***** END LICENSE BLOCK *****

}

{$I Synopse.inc} // define HASINLINE and other compatibility switches

interface

uses

SysUtils,

Classes;

type

gss_name_t = Pointer;

gss_name_t_ptr = ^gss_name_t;

gss_cred_id_t = Pointer;

gss_ctx_id_t = Pointer;

gss_OID_desc = record

length: PtrUInt;

elements: Pointer;

end;

gss_OID = ^gss_OID_desc;

gss_OID_ptr = ^gss_OID;

gss_OID_array = array [0..0] of gss_OID_desc;

gss_OID_descs = ^gss_OID_array;

gss_OID_set_desc = record

count: PtrUInt;

elements: gss_OID_descs;

end;

gss_OID_set = ^gss_OID_set_desc;

gss_OID_set_ptr = ^gss_OID_set;

gss_buffer_desc = record

length: PtrUInt;

value: Pointer;

end;

gss_buffer_t = ^gss_buffer_desc;

const

GSS_C_NO_NAME = nil;

GSS_C_GSS_CODE = 1;

GSS_C_MECH_CODE = 2;

GSS_C_INDEFINITE = $FFFFFFFF;

GSS_C_BOTH = 0;

GSS_C_INITIATE = 1;

GSS_C_ACCEPT = 2;

GSS_C_MUTUAL_FLAG = 2;

GSS_C_CONF_FLAG = 16;

GSS_C_INTEG_FLAG = 32;

GSS_C_CALLING_ERROR_OFFSET = 24;

GSS_C_ROUTINE_ERROR_OFFSET = 16;

GSS_C_SUPPLEMENTARY_OFFSET = 0;

GSS_C_CALLING_ERROR_MASK = $ff;

GSS_C_ROUTINE_ERROR_MASK = $ff;

GSS_C_SUPPLEMENTARY_MASK = $ffff;

GSS_S_CONTINUE_NEEDED = 1 shl (GSS_C_SUPPLEMENTARY_OFFSET + 0);

GSS_S_DUPLICATE_TOKEN = 1 shl (GSS_C_SUPPLEMENTARY_OFFSET + 1);

GSS_S_OLD_TOKEN = 1 shl (GSS_C_SUPPLEMENTARY_OFFSET + 2);

GSS_S_UNSEQ_TOKEN = 1 shl (GSS_C_SUPPLEMENTARY_OFFSET + 3);

GSS_S_GAP_TOKEN = 1 shl (GSS_C_SUPPLEMENTARY_OFFSET + 4);

gss_mech_spnego: array [0..5] of Byte = (43, 6, 1, 5, 5, 2);

gss_mech_spnego_desc: gss_OID_desc = (length: Length(gss_mech_spnego); elements: @gss_mech_spnego);

GSS_C_MECH_SPNEGO: gss_OID = @gss_mech_spnego_desc;

gss_nt_krb5_name: array [0..9] of Byte = (42, 134, 72, 134, 247, 18, 1, 2, 2, 1);

gss_nt_krb5_name_desc: gss_OID_desc = (length: Length(gss_nt_krb5_name); elements: @gss_nt_krb5_name);

GSS_KRB5_NT_PRINCIPAL_NAME: gss_OID = @gss_nt_krb5_name_desc;

gss_nt_user_name: array [0..9] of Byte = (42, 134, 72, 134, 247, 18, 1, 2, 1, 1);

gss_nt_user_name_desc: gss_OID_desc = (length: Length(gss_nt_user_name); elements: @gss_nt_user_name);

GSS_C_NT_USER_NAME: gss_OID = @gss_nt_user_name_desc;

var

gss_import_name: function (

out minor_status: Cardinal;

input_name_buffer: gss_buffer_t;

input_name_type: gss_OID;

out output_name: gss_name_t): Cardinal; cdecl;

gss_display_name: function (

out minor_status: Cardinal;

input_name: gss_name_t;

output_name_buffer: gss_buffer_t;

output_name_type: gss_OID_ptr): Cardinal; cdecl;

gss_release_name: function (

out minor_status: Cardinal;

var name: gss_name_t): Cardinal; cdecl;

gss_acquire_cred: function (

out minor_status: Cardinal;

desired_name: gss_name_t;

time_req: Cardinal;

desired_mechs: gss_OID_set;

cred_usage: Integer;

out output_cred_handle: gss_cred_id_t;

actual_mechs: gss_OID_set_ptr;

time_rec: PCardinal): Cardinal; cdecl;

gss_acquire_cred_with_password: function (

out minor_status: Cardinal;

desired_name: gss_name_t;

password: gss_buffer_t;

time_req: Cardinal;

desired_mechs: gss_OID_set;

cred_usage: Integer;

out output_cred_handle: gss_cred_id_t;

actual_mechs: gss_OID_set_ptr;

time_rec: PCardinal): Cardinal; cdecl;

gss_release_cred: function (

out minor_status: Cardinal;

var cred_handle: gss_cred_id_t): Cardinal; cdecl;

gss_init_sec_context: function (

out minor_status: Cardinal;

initiator_cred_handle: gss_cred_id_t;

var context_handle: gss_ctx_id_t;

target_name: gss_name_t;

mech_type: gss_OID;

req_flags: Cardinal;

time_req: Cardinal;

input_chan_bindings: Pointer;

input_token: gss_buffer_t;

actual_mech_type: gss_OID_ptr;

output_token: gss_buffer_t;

ret_flags: PCardinal;

time_rec: PCardinal): Cardinal; cdecl;

gss_accept_sec_context: function (

out minor_status: Cardinal;

var context_handle: Pointer;

acceptor_cred_handle: Pointer;

input_token_buffer: gss_buffer_t;

input_chan_bindings: Pointer;

src_name: gss_name_t;

mech_type: gss_OID_ptr;

output_token: gss_buffer_t;

ret_flags: PCardinal;

time_rec: PCardinal;

delegated_cred_handle: PPointer): Cardinal; cdecl;

gss_inquire_context: function (

out minor_status: Cardinal;

context_handle: gss_ctx_id_t;

src_name: gss_name_t_ptr;

targ_name: gss_name_t_ptr;

lifetime_rec: PCardinal;

mech_type: gss_OID_ptr;

ctx_flags: PCardinal;

locally_initiated: PInteger;

open: PInteger): Cardinal; cdecl;

gss_delete_sec_context: function (

out minor_status: Cardinal;

var gss_context: gss_ctx_id_t;

buffer: gss_buffer_t): Cardinal; cdecl;

gss_inquire_saslname_for_mech: function (

out minor_status: Cardinal;

desired_mech: gss_OID;

sasl_mech_name: gss_buffer_t;

mech_name: gss_buffer_t;

mech_description: gss_buffer_t): Cardinal; cdecl;

gss_release_buffer: function (

out minor_status: Cardinal;

var buffer: gss_buffer_desc): Cardinal; cdecl;

gss_wrap: function (

out minor_status: Cardinal;

context_handle: gss_ctx_id_t;

conf_req_flag: Integer;

qop_req: Cardinal;

input_message_buffer: gss_buffer_t;

conf_state: PInteger;

output_message_buffer: gss_buffer_t): Cardinal; cdecl;

gss_unwrap: function (

out minor_status: Cardinal;

context_handle: gss_ctx_id_t;

input_message_buffer: gss_buffer_t;

output_message_buffer: gss_buffer_t;

conf_state: PInteger;

qop_state: PCardinal): Cardinal; cdecl;

gss_indicate_mechs: function (

out minor_status: Cardinal;

out mech_set: gss_OID_set): Cardinal; cdecl;

gss_release_oid_set: function (

out minor_status: Cardinal;

out mech_set: gss_OID_set): Cardinal; cdecl;

gss_display_status: function (

out minor_status: Cardinal;

status: Cardinal;

status_type: Integer;

mech_type: gss_OID;

out message_context: Cardinal;

out status_string: gss_buffer_desc): Cardinal; cdecl;

krb5_gss_register_acceptor_identity: function (

path: PAnsiChar): Cardinal; cdecl;

function gss_compare_oid(oid1, oid2: gss_OID): Boolean;

var

/// library name of the MIT implementation of GSSAPI

GSSLib_MIT: string = 'libgssapi_krb5.so.2';

/// library name of the Heimdal implementation of GSSAPI

GSSLib_Heimdal: string = 'libgssapi.so.3';

// High-level wrappers

type

/// Exception raised during gssapi library process

ESynGSSAPI = class(Exception)

private

FMajorStatus: Cardinal;

FMinorStatus: Cardinal;

public

/// initialize an gssapi library exception

constructor Create(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String);

/// associated GSS_C_GSS_CODE state value

property MajorStatus: Cardinal read FMajorStatus;

/// associated GSS_C_MECH_CODE state value

property MinorStatus: Cardinal read FMinorStatus;

end;

{$ifdef HASCODEPAGE}

TGSSAPIBuffer = RawByteString;

{$else}

TGSSAPIBuffer = AnsiString;

{$endif}

/// Auth context

TSecContext = record

ID: Int64;

CredHandle: Pointer;

CtxHandle: Pointer;

CreatedTick64: Int64;

end;

PSecContext = ^TSecContext;

/// dynamic array of Auth contexts

// - used to hold information between calls to ServerSSPIAuth

TSecContextDynArray = array of TSecContext;

/// Sets aSecHandle fields to empty state for a given connection ID

procedure InvalidateSecContext(var aSecContext: TSecContext; aConnectionID: Int64);

/// Free aSecContext on client or server side

procedure FreeSecContext(var aSecContext: TSecContext);

/// Encrypts a message

// - aSecContext must be set e.g. from previous success call to ServerSSPIAuth

// or ClientSSPIAuth

// - aPlain contains data that must be encrypted

// - returns encrypted message

function SecEncrypt(var aSecContext: TSecContext; const aPlain: TGSSAPIBuffer): TGSSAPIBuffer;

/// Decrypts a message

// - aSecContext must be set e.g. from previous success call to ServerSSPIAuth

// or ClientSSPIAuth

// - aEncrypted contains data that must be decrypted

// - returns decrypted message

function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TGSSAPIBuffer): TGSSAPIBuffer;

/// Checks the return value of GSSAPI call and raises ESynGSSAPI exception

// when it indicates failure

procedure GSSCheck(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String = '');

/// Lists supported security mechanisms in form

// sasl:name:description

// - not all mechanisms provide human readable name and description

procedure GSSEnlistMechsSupported(MechList: TStringList);

/// Dynamically load GSSAPI library

// - in multithreaded server application you must call LoadGSSAPI

// at startup to avoid race condition (if you do not use mORMot.pas)

procedure LoadGSSAPI;

/// Call this function to check whether GSSAPI library loaded or not

function GSSAPILoaded: Boolean;

/// Call this function to check whether GSSAPI library loaded

// and raise exception if not.

procedure RequireGSSAPI;

implementation

var

GSSAPILibrary: {$ifdef FPC}TLibHandle{$else}HMODULE{$endif};

/// The macros that test status codes for error conditions. Note that the

// GSS_ERROR() macro has changed slightly from the V1 GSSAPI so that it now

// evaluates its argument only once.

function GSS_CALLING_ERROR(x: Cardinal): Cardinal; inline;

begin

Result := x and (GSS_C_CALLING_ERROR_MASK shl GSS_C_CALLING_ERROR_OFFSET);

end;

function GSS_ROUTINE_ERROR(x: Cardinal): Cardinal; inline;

begin

Result := x and (GSS_C_ROUTINE_ERROR_MASK shl GSS_C_ROUTINE_ERROR_OFFSET);

end;

function GSS_SUPPLEMENTARY_INFO(x: Cardinal): Cardinal; inline;

begin

Result := x and (GSS_C_SUPPLEMENTARY_MASK shl GSS_C_SUPPLEMENTARY_OFFSET);

end;

function GSS_ERROR(x: Cardinal): Cardinal; inline;

begin

Result := x and

((GSS_C_CALLING_ERROR_MASK shl GSS_C_CALLING_ERROR_OFFSET) or

(GSS_C_ROUTINE_ERROR_MASK shl GSS_C_ROUTINE_ERROR_OFFSET));

end;

procedure GSSCheck(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String = '');

begin

if GSS_ERROR(AMajorStatus) <> 0 then

raise ESynGSSAPI.Create(AMajorStatus, AMinorStatus, APrefix);

end;

procedure LoadGSSAPI;

var

LibHandle: {$ifdef FPC}TLibHandle{$else}HMODULE{$endif};

UseHeimdal: Boolean;

begin

if GSSAPILibrary=0 then begin

LibHandle := SafeLoadLibrary(GSSLib_MIT);

UseHeimdal := LibHandle=0;

if UseHeimdal then

LibHandle := SafeLoadLibrary(GSSLib_Heimdal);

if LibHandle<>0 then begin

gss_import_name := GetProcAddress(LibHandle, 'gss_import_name');

gss_display_name := GetProcAddress(LibHandle, 'gss_display_name');

gss_release_name := GetProcAddress(LibHandle, 'gss_release_name');

gss_acquire_cred := GetProcAddress(LibHandle, 'gss_acquire_cred');

gss_acquire_cred_with_password := GetProcAddress(LibHandle, 'gss_acquire_cred_with_password');

gss_release_cred := GetProcAddress(LibHandle, 'gss_release_cred');

gss_init_sec_context := GetProcAddress(LibHandle, 'gss_init_sec_context');

gss_accept_sec_context := GetProcAddress(LibHandle, 'gss_accept_sec_context');

gss_inquire_context := GetProcAddress(LibHandle, 'gss_inquire_context');

gss_delete_sec_context := GetProcAddress(LibHandle, 'gss_delete_sec_context');

gss_inquire_saslname_for_mech := GetProcAddress(LibHandle, 'gss_inquire_saslname_for_mech');

gss_release_buffer := GetProcAddress(LibHandle, 'gss_release_buffer');

gss_wrap := GetProcAddress(LibHandle, 'gss_wrap');

gss_unwrap := GetProcAddress(LibHandle, 'gss_unwrap');

gss_indicate_mechs := GetProcAddress(LibHandle, 'gss_indicate_mechs');

gss_release_oid_set := GetProcAddress(LibHandle, 'gss_release_oid_set');

gss_display_status := GetProcAddress(LibHandle, 'gss_display_status');

krb5_gss_register_acceptor_identity := GetProcAddress(LibHandle, 'krb5_gss_register_acceptor_identity');

if not Assigned(krb5_gss_register_acceptor_identity) then

krb5_gss_register_acceptor_identity := GetProcAddress(LibHandle, 'gsskrb5_register_acceptor_identity');

// At least it should work in server

if Assigned(gss_acquire_cred) and Assigned(gss_accept_sec_context)

and Assigned(gss_release_buffer) and Assigned(gss_inquire_context)

and Assigned(gss_display_name) and Assigned(gss_release_name) then

begin

GSSAPILibrary := LibHandle

end else

FreeLibrary(LibHandle);

end;

end;

end;

function GSSAPILoaded: Boolean;

begin

Result := GSSAPILibrary<>0;

end;

procedure RequireGSSAPI;

begin

if GSSAPILibrary=0 then

raise ENotSupportedException.Create(

'No GSSAPI library found - please install ' +

'either MIT or Heimdal GSSAPI implementation');

end;

function gss_compare_oid(oid1, oid2: gss_OID): Boolean;

begin

if (oid1<>nil) and (oid2<>nil) then begin

Result := (oid1^.length = oid2^.length) and

CompareMem(oid1^.elements, oid2^.elements, oid1^.length);

end

else

Result := False;

end;

procedure GSSEnlistMechsSupported(MechList: TStringList);

var

i, MajSt, MinSt: Cardinal;

Mechs: gss_OID_set;

Buf_sasl, Buf_name, Buf_desc: gss_buffer_desc;

Sasl, Name, Desc: String;

begin

RequireGSSAPI;

if MechList <> nil then begin

MajSt := gss_indicate_mechs(MinSt, Mechs);

for i := 0 to Pred(Mechs^.count) do begin

MajSt := gss_inquire_saslname_for_mech(MinSt, @Mechs^.elements[i], @Buf_sasl, @Buf_name, @Buf_desc);

SetString(Sasl, Buf_sasl.value, Buf_sasl.length);

SetString(Name, Buf_name.value, Buf_name.length);

SetString(Desc, Buf_desc.value, Buf_desc.length);

MechList.Add(Format('%s:%s:%s', [Sasl, Name, Desc]));

gss_release_buffer(MinSt, Buf_sasl);

gss_release_buffer(MinSt, Buf_name);

gss_release_buffer(MinSt, Buf_desc);

end;

MajSt := gss_release_oid_set(MinSt, Mechs);

end;

end;

{ ESynGSSAPI }

constructor ESynGSSAPI.Create(AMajorStatus, AMinorStatus: Cardinal; const APrefix: String);

procedure GetDisplayStatus(var Msg: String; AErrorStatus: Cardinal; StatusType: Integer);

var

Str: String;

MsgCtx: Cardinal;

MsgBuf: gss_buffer_desc;

MajSt, MinSt: Cardinal;

begin

MsgCtx := 0;

repeat

MajSt := gss_display_status(

MinSt, AErrorStatus, StatusType, nil, MsgCtx, MsgBuf);

SetString(Str, MsgBuf.value, MsgBuf.length);

gss_release_buffer(MinSt, MsgBuf);

if Msg <> '' then

Msg := Msg + ': ' + Str

else

Msg := Str;

until (GSS_ERROR(MajSt) <> 0) or (MsgCtx = 0);

end;

var

Msg: String;

begin

Msg := APrefix;

GetDisplayStatus(Msg, AMajorStatus, GSS_C_GSS_CODE);

if AMinorStatus <> 0 then

GetDisplayStatus(Msg, AMinorStatus, GSS_C_MECH_CODE);

inherited Create(Msg);

FMajorStatus := AMajorStatus;

FMinorStatus := AMinorStatus;

end;

procedure InvalidateSecContext(var aSecContext: TSecContext; aConnectionID: Int64);

begin

aSecContext.ID := aConnectionID;

aSecContext.CredHandle := nil;

aSecContext.CtxHandle := nil;

aSecContext.CreatedTick64 := 0;

end;

procedure FreeSecContext(var aSecContext: TSecContext);

var MinStatus: Cardinal;

begin

if aSecContext.CtxHandle <> nil then

gss_delete_sec_context(MinStatus, aSecContext.CtxHandle, nil);

if aSecContext.CredHandle <> nil then

gss_release_cred(MinStatus, aSecContext.CredHandle);

end;

function SecEncrypt(var aSecContext: TSecContext; const aPlain: TGSSAPIBuffer): TGSSAPIBuffer;

var MajStatus, MinStatus: Cardinal;

InBuf: gss_buffer_desc;

OutBuf: gss_buffer_desc;

begin

InBuf.length := Length(aPlain);

InBuf.value := Pointer(aPlain);

MajStatus := gss_wrap(MinStatus, aSecContext.CtxHandle, 1, 0, @InBuf, nil, @OutBuf);

GSSCheck(MajStatus, MinStatus, 'Failed to encrypt message');

SetString(Result, PAnsiChar(OutBuf.value), OutBuf.length);

gss_release_buffer(MinStatus, OutBuf);

end;

function SecDecrypt(var aSecContext: TSecContext; const aEncrypted: TGSSAPIBuffer): TGSSAPIBuffer;

var MajStatus, MinStatus: Cardinal;

InBuf: gss_buffer_desc;

OutBuf: gss_buffer_desc;

begin

InBuf.length := Length(aEncrypted);

InBuf.value := Pointer(aEncrypted);

MajStatus := gss_unwrap(MinStatus, aSecContext.CtxHandle, @InBuf, @OutBuf, nil, nil);

GSSCheck(MajStatus, MinStatus, 'Failed to decrypt message');

SetString(Result, PAnsiChar(OutBuf.value), OutBuf.length);

gss_release_buffer(MinStatus, OutBuf);

end;

finalization

if GSSAPILibrary<>0 then begin

FreeLibrary(GSSAPILibrary);

GSSAPILibrary := 0;

end;

end.