/// 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) 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)
  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.