mORMot Open Source

TSQLRestServerAuthenticationHttpToken.ClientSetUser(aClient, 'login', 'password');

function ADCheckPassword(const sUserName, sDomainName, sPassword: string): Boolean;
const
  SEC_WINNT_AUTH_IDENTITY_ANSI       = $01;
  SEC_WINNT_AUTH_IDENTITY_UNICODE    = $02;
  SEC_WINNT_AUTH_IDENTITY_MARSHALLED = $04;     // all data is in one buffer
  SEC_WINNT_AUTH_IDENTITY_ONLY       = $08;     // these credentials are for identity only - no PAC needed
  SECPKG_CRED_INBOUND          = $00000001;
  SECPKG_CRED_OUTBOUND         = $00000002;
  SECPKG_CRED_BOTH             = $00000003;
  SECPKG_CRED_DEFAULT          = $00000004;
  SECPKG_CRED_RESERVED         = $F0000000;

  SECBUFFER_VERSION            = 0;

  SECBUFFER_EMPTY              = 0;  // Undefined, replaced by provider
  SECBUFFER_DATA               = 1;  // Packet data
  SECBUFFER_TOKEN              = 2;  // Security token
  SECBUFFER_PKG_PARAMS         = 3;  // Package specific parameters
  SECBUFFER_MISSING            = 4;  // Missing Data indicator
  SECBUFFER_EXTRA              = 5;  // Extra data
  SECBUFFER_STREAM_TRAILER     = 6;  // Security Trailer
  SECBUFFER_STREAM_HEADER      = 7;  // Security Header
  SECBUFFER_NEGOTIATION_INFO   = 8;  // Hints from the negotiation pkg
  SECBUFFER_PADDING            = 9;  // non-data padding
  SECBUFFER_STREAM             = 10; // whole encrypted message

  SECBUFFER_ATTRMASK           = $F0000000;
  SECBUFFER_READONLY           = $80000000;  // Buffer is read-only
  SECBUFFER_RESERVED           = $40000000;

  SECURITY_NATIVE_DREP         = $00000010;
  SECURITY_NETWORK_DREP        = $00000000;

  SEC_I_CONTINUE_NEEDED        = $00090312;
  SEC_I_COMPLETE_NEEDED        = $00090313;
  SEC_I_COMPLETE_AND_CONTINUE  = $00090314;

type
  TSecWinntAuthIdentity = packed record
    User : PChar;
    UserLength : DWORD;
    Domain : PChar;
    DomainLength : DWORD;
    Password : PChar;
    PasswordLength : DWORD;
    Flags : DWORD
  end;
  PSecWinntAuthIdentity = ^TSecWinntAuthIdentity;

  TSecHandle = packed record
    dwLower : DWORD;
    dwUpper : DWORD
  end;
  PSecHandle = ^TSecHandle;

  TSecBuffer = packed record
    cbBuffer : DWORD;
    BufferType : DWORD;          // Type of the buffer (below)
    pvBuffer : pointer;
  end;
  PSecBuffer = ^TSecBuffer;

  TSecBufferDesc = packed record
    ulVersion,
    cBuffers : DWORD;            // Number of buffers
    pBuffers : PSecBuffer
  end;
  PSecBufferDesc = ^TSecBufferDesc;

  TCredHandle = TSecHandle;
  PCredHandle = PSecHandle;

  TCtxtHandle = TSecHandle;
  PCtxtHandle = PSecHandle;

  TAuthSeq = packed record
    _fNewConversation : BOOL;
    _hcred : TCredHandle;
    _fHaveCredHandle : BOOL;
    _fHaveCtxtHandle : BOOL;
    _hctxt : TSecHandle;
  end;
  PAuthSeq = ^TAuthSeq;

  PNode = ^TNode;
  TNode = record
    dwKey : DWORD;
    pData : pointer;
    pNext : PNode
  end;

  TSecPkgInfo = record
    fCapabilities : DWORD;        // Capability bitmask
    wVersion : WORD;              // Version of driver
    wRPCID : WORD;                // ID for RPC Runtime
    cbMaxToken : DWORD;           // Size of authentication token (max)   Name : PChar;
    Comment : PChar;              // Comment
  end;
  PSecPkgInfo = ^TSecPkgInfo;

  TSecurityStatus = LongInt;

  ENUMERATE_SECURITY_PACKAGES_FN  = function(var cPackages: DWORD; var PackageInfo: PSecPkgInfo): TSecurityStatus; stdcall;
  QUERY_SECURITY_PACKAGE_INFO_FN  = function(packageName: PChar; var info: PSecPkgInfo): TSecurityStatus; stdcall;
  QUERY_CREDENTIALS_ATTRIBUTES_FN = function(phCredential: pCredHandle; ulAttribute: DWORD; buffer: pointer): TSecurityStatus; stdcall;
  EXPORT_SECURITY_CONTEXT_FN      = function(hContext: pCtxtHandle; flags: DWORD; pPackedContext: PSecBuffer; var token : pointer): TSecurityStatus; stdcall;
  SEC_GET_KEY_FN                  = procedure(Arg, Principal: pointer; KeyVer: DWORD; var Key: pointer; var status: TSecurityStatus); stdcall;
  ACQUIRE_CREDENTIALS_HANDLE_FN   = function(pszPrincipal: PChar; pszPackage: PChar; fCredentialUse: DWORD; pvLogonID: pointer; pAuthData: pointer; pGetKeyFn: SEC_GET_KEY_FN;
                                      pvGetKeyArgument: pointer; var phCredential: TCredHandle; var ptsExpiry: TTimeStamp): TSecurityStatus; stdcall;
  FREE_CREDENTIALS_HANDLE_FN      = function(credHandle: PCredHandle): TSecurityStatus; stdcall;
  INITIALIZE_SECURITY_CONTEXT_FN  = function(phCredential: PCredHandle; phContent: PCtxtHandle; pszTargetName: PChar; fContextReq, Reserved1, TargetDataRep: DWORD; pInput: PSecBufferDesc;
                                      Reserved2: DWORD; phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; var pfContextAttr: DWORD; var ptsExpiry: TTimeStamp): TSecurityStatus; stdcall;
  ACCEPT_SECURITY_CONTEXT_FN      = function (phCredential: PCredHandle; phContext: PCtxtHandle; pInput: PSecBufferDesc; fContextReq, TargetDataRep: DWORD;
                                      phNewContext: PCtxtHandle; pOutput: PSecBufferDesc; var pfContextAttr: DWORD; var ptsExpiry: TTimeStamp): TSecurityStatus; stdcall;
  COMPLETE_AUTH_TOKEN_FN          = function (phContext: PCtxtHandle; pToken: PSecBufferDesc): TSecurityStatus; stdcall;
  DELETE_SECURITY_CONTEXT_FN      = function (phContext: PCtxtHandle): TSecurityStatus; stdcall;
  APPLY_CONTROL_TOKEN_FN          = function (phContext: PCtxtHandle; pInput: PSecBufferDesc): TSecurityStatus; stdcall;
  QUERY_CONTEXT_ATTRIBUTES_FN     = function (phContext: PCtxtHandle; alAttribute: DWORD; pBuffer: pointer): TSecurityStatus; stdcall;
  IMPERSONATE_SECURITY_CONTEXT_FN = function (phContext: PCtxtHandle): TSecurityStatus; stdcall;
  REVERT_SECURITY_CONTEXT_FN      = function (phContext: PCtxtHandle): TSecurityStatus; stdcall;
  MAKE_SIGNATURE_FN               = function (phContext: PCtxtHandle; fQOP: DWORD; pMessage: PSecBufferDesc; MessageSeqNo: DWORD): TSecurityStatus; stdcall;
  VERIFY_SIGNATURE_FN             = function (phContext: PCtxtHandle; pMessage: PSecBufferDesc; MessageSeqNo: DWORD; var fQOP: DWORD): TSecurityStatus; stdcall;
  FREE_CONTEXT_BUFFER_FN          = function (contextBuffer: pointer): TSecurityStatus; stdcall;
  IMPORT_SECURITY_CONTEXT_FN      = function (pszPackage: PChar; pPackedContext: PSecBuffer; Token: pointer; phContext: PCtxtHandle): TSecurityStatus; stdcall;
  ADD_CREDENTIALS_FN              = function (hCredentials: PCredHandle; pszPrincipal, pszPackage: PChar; fCredentialUse: DWORD; pAuthData: pointer;
                                      pGetKeyFn: SEC_GET_KEY_FN; pvGetKeyArgument: pointer; var ptsExpiry: TTimeStamp): TSecurityStatus; stdcall;
  QUERY_SECURITY_CONTEXT_TOKEN_FN = function (phContext: PCtxtHandle; var token: pointer): TSecurityStatus; stdcall;
  ENCRYPT_MESSAGE_FN              = function (phContext: PCtxtHandle; fQOP: DWORD; pMessage: PSecBufferDesc; MessageSeqNo: DWORD): TSecurityStatus; stdcall;
  DECRYPT_MESSAGE_FN              = function (phContext: PCtxtHandle; pMessage: PSecBufferDesc; MessageSeqNo: DWORD; fQOP: DWORD): TSecurityStatus; stdcall;

  TSecurityFunctionTable = record
    dwVersion : LongInt;
    EnumerateSecurityPackages  : ENUMERATE_SECURITY_PACKAGES_FN;
    QueryCredentialsAttributes : QUERY_CREDENTIALS_ATTRIBUTES_FN;
    AcquireCredentialsHandle   : ACQUIRE_CREDENTIALS_HANDLE_FN;
    FreeCredentialHandle       : FREE_CREDENTIALS_HANDLE_FN;
    Reserved2                  : FARPROC;
    InitializeSecurityContext  : INITIALIZE_SECURITY_CONTEXT_FN;
    AcceptSecurityContext      : ACCEPT_SECURITY_CONTEXT_FN;
    CompleteAuthToken          : COMPLETE_AUTH_TOKEN_FN;
    DeleteSecurityContext      : DELETE_SECURITY_CONTEXT_FN;
    ApplyControlToken          : APPLY_CONTROL_TOKEN_FN;
    QueryContextAttributes     : QUERY_CONTEXT_ATTRIBUTES_FN;
    ImpersonateSecurityContext : IMPERSONATE_SECURITY_CONTEXT_FN;
    RevertSecurityContext      : REVERT_SECURITY_CONTEXT_FN;
    MakeSignature              : MAKE_SIGNATURE_FN;
    VerifySignature            : VERIFY_SIGNATURE_FN;
    FreeContextBuffer          : FREE_CONTEXT_BUFFER_FN;
    QuerySecurityPackageInfo   : QUERY_SECURITY_PACKAGE_INFO_FN;
    Reserved3                  : FARPROC;
    Reserved4                  : FARPROC;
    ExportSecurityContext      : EXPORT_SECURITY_CONTEXT_FN;
    ImportSecurityContext      : IMPORT_SECURITY_CONTEXT_FN;
    AddCredentials             : ADD_CREDENTIALS_FN;
    Reserved8                  : FARPROC;
    QuerySecurityContextToken  : QUERY_SECURITY_CONTEXT_TOKEN_FN;
    EncryptMessage             : ENCRYPT_MESSAGE_FN;
    DecryptMessage             : DECRYPT_MESSAGE_FN;
  end;
  PSecurityFunctionTable = ^TSecurityFunctionTable;

  var
    Head: TNode;

  function GetEntry(dwKey: DWORD; var pData: pointer): boolean;
  var
    pCurrent: PNode;
  begin
    result := False;
    pCurrent := Head.pNext;
    while Assigned (pCurrent) do
    begin
      if pCurrent^.dwKey = dwKey then
      begin
        pData := pCurrent^.pData;
        result := True;
        break
      end;
      pCurrent := pCurrent^.pNext
    end
  end;

  function AddEntry(dwKey: DWORD; pData: pointer): boolean;
  var
    pTemp: PNode;
  begin
    GetMem(pTemp, sizeof(TNode));
    if Assigned(pTemp) then
    begin
      pTemp^.dwKey := dwKey;
      pTemp^.pData := pData;
      pTemp^.pNext := Head.pNext;
      Head.pNext := pTemp;
      result := True
    end
    else
      result := False
  end;

  function DeleteEntry(dwKey: DWORD; var ppData: pointer): boolean;
  var
    pCurrent, pTemp: PNode;
  begin
    result := False;
    pTemp := @head;
    pCurrent := Head.pNext;
    while pCurrent <> Nil do begin
      if dwKey = pCurrent^.dwKey then begin
        pTemp^.pNext := pCurrent^.pNext;
        ppData := pCurrent^.pData;
        FreeMem (pCurrent);
        result := True;
        break
      end
      else begin
        pTemp := pCurrent;
        pCurrent := pCurrent^.pNext
      end
    end
  end;

  function InitSession(dwKey: DWORD): boolean;
  var
    pAS: PAuthSeq;
  begin
    result := False;
    GetMem(pAS, sizeof(TAuthSeq));
    if Assigned(pAS) then
    try
      pAS^._fNewConversation := TRUE;
      pAS^._fHaveCredHandle := FALSE;
      pAS^._fHaveCtxtHandle := FALSE;
      if not AddEntry (dwKey, pAS) then
        FreeMem (pAS)
      else
        result := True
    except
      FreeMem (pAS);
      raise
    end
  end;

  function InitPackage(var cbMaxMessage: DWORD; var funcs:PSecurityFunctionTable): THandle;
  type
    INIT_SECURITY_ENTRYPOINT_FN = function: PSecurityFunctionTable;
  var
    pInit: INIT_SECURITY_ENTRYPOINT_FN;
    ss: TSecurityStatus;
    pkgInfo: PSecPkgInfo;
  begin
    result := LoadLibrary('security.dll');  // *** Secur32.dll for Windows 95
    if result <> 0 then
    try
      pInit := GetProcAddress(result, 'InitSecurityInterfaceW');
      if not Assigned(pInit) then
        raise Exception.CreateFmt('Couldn''t get sec init routine: %d', [GetLastError]);
      funcs := pInit;
      if not Assigned(funcs) then
        raise Exception.Create('Couldn''t init package');
      ss := funcs^.QuerySecurityPackageInfo('NTLM', pkgInfo);
      if ss < 0 then
        raise Exception.CreateFmt('Couldn''t query package info for NTLM, error %d\n', [ss]);
      cbMaxMessage := pkgInfo^.cbMaxToken;
      funcs^.FreeContextBuffer(pkgInfo)
    except
      if result <> 0 then
        FreeLibrary(result);
      raise
    end
  end;

  function GenClientContext(funcs: PSecurityFunctionTable; dwKey: DWORD; Auth: PSecWINNTAuthIdentity;
    pIn: PBYTE; cbIn: DWORD; pOut: PBYTE; var cbOut: DWORD; var fDone: boolean): boolean;
  var
    ss: TSecurityStatus;
    lifeTime: TTimeStamp;
    OutBuffDesc: TSecBufferDesc;
    OutSecBuff: TSecBuffer;
    InBuffDesc: TSecBufferDesc;
    InSecBuff: TSecBuffer;
    ContextAttributes: DWORD;
    pAS: PAuthSeq;
    phctxt: PCtxtHandle;
    pBuffDesc: PSecBufferDesc;
  begin
    result := False;
    if GetEntry(dwKey, pointer (pAS)) then
    try
      if pAS^._fNewConversation then begin
        ss := funcs^.AcquireCredentialsHandle(nil{principal}, 'NTLM', SECPKG_CRED_OUTBOUND, nil{LOGON id},
                Auth{auth data}, nil{get key fn}, nil{get key arg}, pAS^._hcred, Lifetime);
        if ss < 0 then
          raise Exception.CreateFmt ('AquireCredentials failed %d', [ss]);
        pAS^._fHaveCredHandle := TRUE
      end;

      OutBuffDesc.ulVersion := 0;
      OutBuffDesc.cBuffers := 1;
      OutBuffDesc.pBuffers := @OutSecBuff;

      OutSecBuff.cbBuffer := cbOut;
      OutSecBuff.BufferType := SECBUFFER_TOKEN;
      OutSecBuff.pvBuffer := pOut;

      // prepare input buffer
      if not pAS^._fNewConversation then begin
        InBuffDesc.ulVersion := 0;
        InBuffDesc.cBuffers := 1;
        InBuffDesc.pBuffers := @InSecBuff;

        InSecBuff.cbBuffer := cbIn;
        InSecBuff.BufferType := SECBUFFER_TOKEN;
        InSecBuff.pvBuffer := pIn
      end;

      if pAS^._fNewConversation then begin
        pBuffDesc := nil;
        phctxt := nil
      end
      else begin
        phctxt := @pAS^._hctxt;
        pBuffDesc := @InBuffDesc
      end;

      ss := funcs^.InitializeSecurityContext(@pAS^._hcred, phctxt, 'AuthSamp', 0{context requirements},
              0{reserved1}, SECURITY_NATIVE_DREP, pBuffDesc, 0{reserved2}, @pAS^._hctxt, @OutBuffDesc,
              ContextAttributes, Lifetime);
      if ss < 0 then
        raise Exception.CreateFmt ('Init context failed: %d', [ss]);

      pAS^._fHaveCtxtHandle := TRUE;

      if (ss = SEC_I_COMPLETE_NEEDED) or (ss = SEC_I_COMPLETE_AND_CONTINUE) then begin
        if Assigned (funcs^.CompleteAuthToken) then begin
          ss := funcs^.CompleteAuthToken (@pAS^._hctxt, @OutBuffDesc);
          if ss < 0 then
            raise Exception.CreateFmt ('Complete failed: %d', [ss])
        end;
      end;

      cbOut := OutSecBuff.cbBuffer;

      if pAS^._fNewConversation then
        pAS^._fNewConversation := FALSE;

      fDone := (ss <> SEC_I_CONTINUE_NEEDED) and (ss <> SEC_I_COMPLETE_AND_CONTINUE);

      result := True
    except
    end
  end;

  function GenServerContext(funcs: PSecurityFunctionTable; dwKey: DWORD; pIn: PByte; cbIn: DWORD; pOut: PByte;
    var cbOut: DWORD; var fDone: boolean) : boolean;
  var
    ss: TSecurityStatus;
    Lifetime:  TTimeStamp;
    OutBuffDesc, InBuffDesc: TSecBufferDesc;
    InSecBuff, OutSecBuff: TSecBuffer;
    ContextAttributes: DWORD;
    pAS: PAuthSeq;
    phctxt: PCtxtHandle;
  begin
    result := False;
    if GetEntry(dwKey, pointer (pAS)) then
    try
      if pAS^._fNewConversation then begin
        ss := funcs^.AcquireCredentialsHandle(nil{principal}, 'NTLM', SECPKG_CRED_INBOUND, nil{LOGON id},
                nil{auth data}, nil{get key fn}, nil{get key arg}, pAS^._hcred, Lifetime);
        if ss < 0 then
          raise Exception.CreateFmt ('AcquireCreds failed %d', [ss]);
        pAS^._fHaveCredHandle := TRUE
      end;

      // prepare output buffer
      OutBuffDesc.ulVersion := 0;
      OutBuffDesc.cBuffers := 1;
      OutBuffDesc.pBuffers := @OutSecBuff;

      OutSecBuff.cbBuffer := cbOut;
      OutSecBuff.BufferType := SECBUFFER_TOKEN;
      OutSecBuff.pvBuffer := pOut;

      // prepare input buffer
      InBuffDesc.ulVersion := 0;
      InBuffDesc.cBuffers := 1;
      InBuffDesc.pBuffers := @InSecBuff;

      InSecBuff.cbBuffer := cbIn;
      InSecBuff.BufferType := SECBUFFER_TOKEN;
      InSecBuff.pvBuffer := pIn;

      if pAS^._fNewConversation then
        phctxt := Nil
      else
        phctxt := @pAS^._hctxt;

      ss := funcs^.AcceptSecurityContext(@pAS^._hcred, phctxt, @InBuffDesc, 0{context requirements},
              SECURITY_NATIVE_DREP, @pAS^._hctxt, @OutBuffDesc, ContextAttributes, Lifetime);
      if ss < 0 then begin
        Result := false;
        Exit;
      end
      else
        pAS^._fHaveCtxtHandle := TRUE;

      // Complete token -- if applicable
      if (ss = SEC_I_COMPLETE_NEEDED) or (ss =SEC_I_COMPLETE_AND_CONTINUE) then
        if Assigned (funcs^.CompleteAuthToken) then begin
          ss := funcs^.CompleteAuthToken (@pAS^._hctxt, @OutBuffDesc);
          if ss < 0 then
            raise Exception.CreateFmt ('complete failed: %d', [ss]);
        end
        else
          raise Exception.Create ('Complete not supported.');

      cbOut := OutSecBuff.cbBuffer;

      if pAS^._fNewConversation then
        pAS^._fNewConversation := FALSE;

      fDone := (ss <> SEC_I_CONTINUE_NEEDED) and (ss <> SEC_I_COMPLETE_AND_CONTINUE);

      result := True
    except
    end;
  end;

  function TermSession(funcs: PSecurityFunctionTable; dwKey: DWORD): boolean;
  var
    pAS: PAuthSeq;
  begin
    result := False;
    if DeleteEntry(dwKey, pointer (pAS)) then begin
      if pAS^._fHaveCtxtHandle then
        funcs^.DeleteSecurityContext (@pAS^._hctxt);
      if pAS^._fHaveCredHandle then
        funcs^.FreeCredentialHandle (@pAS^._hcred);
      freemem(pAS);
      result := True
    end
  end;

var
  done : boolean;
  cbOut, cbIn : DWORD;
  AuthIdentity : TSecWINNTAuthIdentity;
  session0OK, session1OK : boolean;
  packageHandle : THandle;

  pClientBuf : PByte;
  pServerBuf : PByte;
  cbMaxMessage : DWORD;
  funcs : PSecurityFunctionTable;
begin
  Result := False;
  try
    done := False;

    session1OK := False;
    packageHandle := 0;
    pClientBuf := Nil;
    pServerBuf := Nil;
    cbMaxMessage := 0;

    ZeroMemory(@Head, SizeOf(TNode));

    session0OK := InitSession(0);
    try
      session1OK := InitSession(1);
      packageHandle := InitPackage (cbMaxMessage, funcs);

      if session0OK and session1OK and (packageHandle <> 0) then begin
        GetMem(pClientBuf, cbMaxMessage);
        GetMem(pServerBuf, cbMaxMessage);
        FillChar(AuthIdentity, SizeOf(AuthIdentity), 0);

        if sUserName <> '' then begin
          AuthIdentity.User := PChar(sUserName);
          AuthIdentity.UserLength := Length(sUserName);
        end;

        if sDomainName <> '' then begin
          AuthIdentity.Domain := PChar(sDomainName);
          AuthIdentity.DomainLength := Length(sDomainName)
        end;

        if sPassword <> '' then begin
          AuthIdentity.Password := PChar(sPassword);
          AuthIdentity.PasswordLength := Length(sPassword)
        end
        else begin
          AuthIdentity.Password := PChar ('');
          AuthIdentity.PasswordLength := 0;
        end;
        // original C code contains check for UNICODE strings.
        AuthIdentity.Flags := SEC_WINNT_AUTH_IDENTITY_UNICODE;

        // Prepare client message (negotiate).
        cbOut := cbMaxMessage;

        if not GenClientContext(funcs, 0, @AuthIdentity, pServerBuf, 0, pClientBuf, cbOut, done) then
          raise Exception.Create('GenClientContext Failed');

        cbIn := cbOut;
        cbOut := cbMaxMessage;
        if not GenServerContext(funcs, 1, pClientBuf, cbIn, pServerBuf, cbOut, done) then
          raise Exception.Create('GenServerContext Failed');
        cbIn := cbOut;

        // Prepare client message (authenticate).
        cbOut := cbMaxMessage;
        if not GenClientContext(funcs, 0, @AuthIdentity, pServerBuf, cbIn, pClientBuf, cbOut, done) then
          raise Exception.Create('GenClientContext failed');
        cbIn := cbOut;

        // Prepare server message (authentication).
        cbOut := cbMaxMessage;
        Result := GenServerContext(funcs, 1, pClientBuf, cbIn, pServerBuf, cbOut, done)
      end;
    except
    end;
    // close session
    if Session0OK then
      TermSession(funcs, 0);
    if Session1OK then
      TermSession(funcs, 1);
    if packageHandle <> 0 then
      FreeLibrary (PackageHandle);
    if pClientBuf <> nil then
      FreeMem (pClientBuf);
    if pServerBuf <> nil then
      FreeMem (pServerBuf);
  except
  end;
end;

unit Project14ClientMain;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls,
  SynCommons, mORMot, mORMotHttpClient,
  Project14Interface;

type
  TForm1 = class(TForm)
    edtA: TEdit;
    edtB: TEdit;
    lblA: TLabel;
    lblB: TLabel;
    btnCall: TButton;
    btnCancel: TButton;
    lblResult: TLabel;
    ComboProtocol: TComboBox;
    procedure btnCancelClick(Sender: TObject);
    procedure btnCallClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ComboProtocolChange(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    Model: TSQLModel;
    Client: TSQLRestClientURI;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{$R Vista.res}

procedure TForm1.btnCancelClick(Sender: TObject);
begin
  Close;
end;

procedure TForm1.btnCallClick(Sender: TObject);
var a,b: integer;
    err: integer;
    I: ICalculator;
begin
  val(edtA.Text,a,err);
  if err<>0 then begin
    edtA.SetFocus;
    exit;
  end;
  val(edtB.Text,b,err);
  if err<>0 then begin
    edtB.SetFocus;
    exit;
  end;
  if Client=nil then begin
    if Model=nil then
      Model := TSQLModel.Create([],ROOT_NAME);
    case ComboProtocol.ItemIndex of
    0,2,3: Client := TSQLHttpClient.Create('localhost','888',Model);
    1: Client := TSQLRestClientURINamedPipe.Create(Model,APPLICATION_NAME);
    else exit;
    end;
    if not Client.ServerTimeStampSynchronize then begin
      ShowMessage(UTF8ToString(Client.LastErrorMessage));
      exit;
    end;
    case ComboProtocol.ItemIndex of
    2:   TSQLRestServerAuthenticationNone.ClientSetUser(Client,'User','');
	     // Here possible to use 'ComputerName\User' or 'DomainName\User'
    3:   TSQLRestServerAuthenticationActiveDirectory.ClientSetUser(Client,'Computer\User','Password');
    else Client.SetUser('User','synopse');
    end;
    Client.ServiceDefine([ICalculator],sicShared);
  end;
  if Client.Services['Calculator'].Get(I) then
    lblResult.Caption := IntToStr(I.Add(a,b));
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Client.Free;
  Model.Free;
end;

procedure TForm1.ComboProtocolChange(Sender: TObject);
begin
  FreeAndNil(Client);
end;

end.

object Form1: TForm1
  Left = 334
  Top = 330
  Caption = 'Form1'
  ClientHeight = 242
  ClientWidth = 306
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -13
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 16
  object lblA: TLabel
    Left = 56
    Top = 50
    Width = 17
    Height = 16
    Caption = 'A='
  end
  object lblB: TLabel
    Left = 56
    Top = 98
    Width = 16
    Height = 16
    Caption = 'B='
  end
  object lblResult: TLabel
    Left = 76
    Top = 200
    Width = 184
    Height = 16
    Caption = 'Enter numbers, then Call Server'
  end
  object edtA: TEdit
    Left = 80
    Top = 48
    Width = 153
    Height = 24
    TabOrder = 0
  end
  object edtB: TEdit
    Left = 80
    Top = 96
    Width = 153
    Height = 24
    TabOrder = 1
  end
  object btnCall: TButton
    Left = 56
    Top = 152
    Width = 97
    Height = 25
    Caption = 'Call Server'
    TabOrder = 2
    OnClick = btnCallClick
  end
  object btnCancel: TButton
    Left = 168
    Top = 152
    Width = 97
    Height = 25
    Caption = 'Quit'
    TabOrder = 3
    OnClick = btnCancelClick
  end
  object ComboProtocol: TComboBox
    Left = 80
    Top = 16
    Width = 153
    Height = 24
    Style = csDropDownList
    TabOrder = 4
    OnChange = ComboProtocolChange
    Items.Strings = (
      'HTTP / TCP-IP'
      'Named Pipe'
      'Weak HTTP / TCP-IP'
      'Active Directory HTTP / TCP-IP')
  end
end

/// this server will use Active Directory authentication with TSQLRestServerFullMemory over HTTP
// demonstrated how to change default passwords for default users
program Project14ServerHttpWeak;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes,
  SynCommons,
  SynLog,
  mORMot,
  mORMotSQLite3,
  mORMotHttpServer,
  Project14Interface;

type
  TServiceCalculator = class(TInterfacedObject, ICalculator)
  public
    function Add(n1,n2: integer): integer;
  end;

function TServiceCalculator.Add(n1, n2: integer): integer;
begin
  result := n1+n2;
end;

procedure RegisterAuthenticationActiveDirectory(Server: TSQLRestServer; EnableDefaultUser: Boolean);

  procedure ChangeDefaultPassword(LogonName, Password: RawUTF8);
  var
    U: TSQLAuthUser;
  begin
    U := Server.SQLAuthUserClass.Create(Server, 'LogonName=?', [LogonName]);
    try
      if U.ID > 0 then begin
        U.PasswordPlain := Password;
        Server.Update(U);
      end;
    finally
      U.Free;
    end;
  end;

var
  Auth: TSQLRestServerAuthentication;
  G: TSQLAuthGroup;
  U: TSQLAuthUser;
  UserID: PtrInt;
begin
  Auth := Server.AuthenticationRegister(TSQLRestServerAuthenticationActiveDirectory);
  Server.CreateMissingTables;
  // Change default passwords
  ChangeDefaultPassword('Admin', 'AdminPass');
  ChangeDefaultPassword('Supervisor', 'SupervisorPass');
  ChangeDefaultPassword('User', 'UserPass');
  if EnableDefaultUser then
    // Enable work with user '*'
    Auth.Options := Auth.Options + [saoHandleUnknownLogonAsStar];
    // Get ID of group with User access rights
    G := Server.SQLAuthGroupClass.Create(Server, 'Ident=?', ['User']);
    try
      UserId := G.ID;
    finally
      G.Free;
    end;
    if UserId > 0 then begin
      // Create default Active Directory user '*' - settings for all authenticated users
      U := Server.SQLAuthUserClass.Create(Server, 'LogonName=?', ['*']);
      try
        if U.ID = 0 then begin
          U.LogonName        := '*';
          U.DisplayName      := U.LogonName;
          U.PasswordHashHexa := '';
          U.GroupRights      := TSQLAuthGroup(UserID);
          Server.Add(U,true);
        end;
      finally
        U.Free;
      end;
    end;
end;

var
  aModel: TSQLModel;
  aServer: TSQLRestServer;
  aHTTPServer: TSQLHttpServer;
begin
  // define the log level
  with TSQLLog.Family do begin
    Level := LOG_VERBOSE;
    EchoToConsole := LOG_VERBOSE; // log all events to the console
  end;
  // create a Data Model (including TSQLAuthGroup,TSQLAuthUser here)
  aModel := TSQLModel.Create([TSQLAuthGroup,TSQLAuthUser],ROOT_NAME);
  try
    // initialize a TObjectList-based database engine
    aServer := TSQLRestServerFullMemory.Create(aModel,'test.json',false,false);
    try
	  // register TSQLRestServerAuthenticationActiveDirectory
	  // enable default user '*' for authenticated users
      RegisterAuthenticationActiveDirectory(aServer,true);
      // register our ICalculator service on the server side
      aServer.ServiceDefine(TServiceCalculator,[ICalculator],sicShared);
      // launch the HTTP server
      aHTTPServer := TSQLHttpServer.Create(PORT_NAME,[aServer],'+',useHttpApiRegisteringURI);
      try
        aHTTPServer.AccessControlAllowOrigin := '*'; // for AJAX requests to work
        writeln(#10'Background server is running.'#10);
        writeln('Press [Enter] to close the server.'#10);
        readln;
      finally
        aHTTPServer.Free;
      end;
    finally
      aServer.Free;
    end;
  finally
    aModel.Free;
  end;
end.