{###############################################################################

This sample Delphi code has been contributed by one of our longest standing customers
and a Delphi developer, Charlotte. We thank her for the time and effort she had put in this
It is purely a demonstration of managing secured connections in COM and no warranty
or responsibility will be provided by our contributor. This is a learning material and 
you are free to modify and learn from it. This project was developed in Embarcadero IDE

--------------------------------------------------------------------------------

Copyright  Radius, LLC 2016-2021 - All Rights Reserved.
--------------------------------------------------------------------------------
Program Name:           DOWrappers.pas
Project Name:           Utilities
Author:                 Charlotte F. Manly, Ph.D.
Date Created:           12/21/2016

Purpose: Augment DicomObjects so that we can control TLS and certificate
   management ourselves, not rely on CAPICOM, and thus compile 64-bit applications.

General design:
   As far as the main application is concerned, there is one DO wrapper
   object for each of several DO objects and interfaces, which "wrap" the original DicomObject.  (Modified facade pattern.)

   In the case of TDicomServer, that object must still be created in the application, along with
   assigning its event handlers, and then a wrapper should be created for the TDicomServer.
   The TDicomServer event handlers should look up the corresponding wrapper for the IDicomConnection
   object that is passed to them and use that instead of the parameter that was passed.

   In the case of IDicomConnection, a wrapper is created in lieu of the interface;
   the wrapper will create the corresponding interfaced object.  Because of this, there are
   some differences in lifetime management of the object.  (The issue is that TDicomConnectionWrappers
   should be freed once no longer in use by DicomObjects, but not while the main application
   still may access them, e.g., in a method or event handler, nor while there is data to be sent to the socket.)

   Most of the properties and methods are implemented as pass-through,
   meaning they go straight to the DicomObject that they wrap.  If DicomObjects adds
   new properties and methods, they should be added to the wrapper interface in the same
   way as existing ones.  If DicomObjects removes properties or methods, they should
   be removed from the wrapper interface as well.  If DicomObjects adds new event handlers,
   the pattern for existing event handlers should be matched to avoid problems with
   lifetime management of TDicomConnectionWrappers.

   Properties that are not pass-through retain the same name if they are of the same type
   and meaning.  When they are not (e.g., for the certificates, the certificate itself
   versus merely the name by which it can be found in the certificate store), then the
   property name has been changed to more accurately reflect what they mean.

   A separate implementation guide provides more details.

Special notes:
   The wrappers in general implement a COM interface.  Specifically,
   TNetworkStream implements the COM interface, but it is created by TDicomConnectionWrapper,
   which passes it several TDicomConnectionWrapper methods which may be called.

   As a result, certain TDicomConnectionWrapper methods are also executed within
   the COM interface calls.

   There are restrictions on what we can do within a COM interface.  The basic issue is that
   adding a COM interface requires that the application be multi-threaded, even if
   TDicomConnectWrapper objects are created in the main thread.  All the usual
   rules for multithreading apply -- VCL components created in the main thread cannot be
   accessed in another thread (e.g., the COM thread) unless they are thread-safe and/or
   locks are used.

   The solutions to these problems are not shown in this example.
   Note that a different architecture choice might result in a different solution.
   This example may not illustrate the best choice of architecture.


--------------------------------------------------------------------------------
###############################################################################}
unit DOWrappers;

//##############################################################################
                          INTERFACE
//##############################################################################

{$WARN SYMBOL_PLATFORM OFF}
{$WARN UNIT_PLATFORM OFF}

uses
  System.Types, System.SysUtils, System.Variants, System.Classes, Winapi.Windows,
  Winapi.ActiveX, Vcl.OleServer, System.Math, System.DateUtils, DicomObjects8_TLB,
  System.SyncObjs, Vcl.ExtCtrls,
  System.Generics.Collections;

{ WrapperLog procedure }

const
  WrapperError = $10000;
  WrapperWarning = $20000;
  WrapperInfo = $40000;
  WrapperDebug = $80000;

procedure LogDO(const Level, Association, ConnectionID: integer; const Msg: string; DcmServer: TDicomServer = nil);

{ TNetworkStream }

type
  TReadFunction = function (var Buffer; Count: longint; var LostConnection: boolean): longint of object;
  TWriteFunction = function (const Buffer; Count: longint; var LostConnection: boolean): longint of object;
  TFreeProc = procedure of object;

  TNetworkStream = class(TInterfacedObject, IStream)
  // A class like TStreamAdapter (and based on it) but in which the IStream interface
  // reads from one stream and writes to a different stream
  // It is used to provide an IStream interface to DicomObjects, but our own software
  // should operate directly on the stream objects because what DO writes we need to read and
  // vice versa.
  private
    FRead: TReadFunction;
    FWrite: TWriteFunction;
    FFreeWrapper: TFreeProc;
  public
    constructor Create(myRead: TReadFunction; myWrite: TWriteFunction; myFreeWrapper: TFreeProc);
    procedure Free;
    // need to manage object lifetime -- is complicated by the need to keep the object alive until all three conditions are met:
    // 1. DicomObjects has released all its references
    // 2. All data has been sent or the connection has been closed by the other side
    // 3. Application code has released all its references
    function _AddRef: integer; stdcall;
    function _Release: integer; stdcall;
    // per Dave, only implementing Read and Write interface methods
    function Read(pv: Pointer; cb: FixedUInt; pcbRead: PFixedUInt): HResult; virtual; stdcall;
    function Write(pv: Pointer; cb: FixedUInt; pcbWritten: PFixedUInt): HResult; virtual; stdcall;
    // The remainder of interface calls for IStream interface are not implemented
    function Seek(dlibMove: Largeint; dwOrigin: DWORD; out libNewPosition: LargeUInt): HResult; virtual; stdcall;
    function SetSize(libNewSize: LargeUInt): HResult; virtual; stdcall;
    function CopyTo(stm: IStream; cb: LargeUInt; out cbRead: LargeUInt; out cbWritten: LargeUInt): HResult; virtual; stdcall;
    function Commit(grfCommitFlags: DWORD): HResult; virtual; stdcall;
    function Revert: HResult; virtual; stdcall;
    function LockRegion(libOffset: LargeUInt; cb: LargeUInt; dwLockType: DWORD): HResult; virtual; stdcall;
    function UnlockRegion(libOffset: LargeUInt; cb: LargeUInt; dwLockType: DWORD): HResult; virtual; stdcall;
    function Stat(out statstg: TStatStg; grfStatFlag: DWORD): HResult; virtual; stdcall;
    function Clone(out stm: IStream): HResult; virtual; stdcall;
  end;

{ TDicomConnectionWrapper }

type
  TDicomConnectionWrapper = class(TObject)
    procedure ipDataIn(Sender: TObject; Text: string; EOL: Boolean);
    procedure ipDisconnected(Sender: TObject; StatusCode: Integer; const Description: string); // only for incoming connections
    procedure ipError(Sender: TObject; ErrorCode: Integer; const Description: string); // only for outbound connections
    procedure SelfDestructOnTimer(Sender: TObject);
    procedure TimerInbound(Sender: TObject);
    procedure TimerSendOutboundToSocket(Sender: TObject);
  private
    FRefCount: integer; // for pure DO connection wrappers, i.e., non-TLS where DO handles TCP
    // assign during create (or soon after) in all connections
    FDcmConnection: IDicomConnection;
    FDcmServer: TDicomServer; // used for async, at least outbound
    FIsOutbound: boolean;
    FOriginalAssociation: integer;
    // assign during create (or soon after) for inbound connections
    FConnectionID: integer;
    FListeningPort: integer;
    // create for all connections except pure DO connection wrappers
    FNetworkStream: TNetworkStream;
    FLostConnection: boolean;
    // timers are needed for actions that are initiated within the COM interface but which need to be executed in the thread in which the TDicomConnectionWrapper was created
    FTimerDestruct: TTimer;
    FTimerInbound: TTimer;
    FTimerSendOutboundToSocket: TTimer;
    FSendInProgress: boolean;
    // create for outbound connections
    procedure SetupTCPClient;
    procedure SetupStreamsAndTimeout;
    procedure Free; // rarely called directly; wrapper is self-freeing and is freed after DO releases the associated IStream, unless there is no IStream because it's a pure wraparound wrapper
    procedure CheckForDisconnect(const CallingName: string; const LogLevel: integer);
    // getters and setters for DO properties
    // Mode and UseTLS changed to read-only and must be set at object creation
     // Some of these are pass-through properties.  Other properties that don't involve the TCP connection can usually be implemented similarly.
    function Get_Association: Integer;
    function Get_Tag: OleVariant;
    function Get_Mode: doConnectionMode;
    function Get_CallingAET: WideString;
    // These are not pass-through properties and must be implemented using a TCP/TLS library.
    function Get_RemoteIP: WideString;
    function Get_LocalIP: WideString;
    function Get_LocalPort: Integer;

    procedure Set_Tag(Value: OleVariant);
  public
    constructor Create(); overload; // for outbound sync, explicitly created in code
    constructor Create(DcmServer: TDicomServer); overload; // for outbound async, explicitly created in code
    constructor Create(DcmServer: TDicomServer; ipServer: TObject; ConnectionID: integer); overload; // for inbound created by server wrapper, not to be called outside wrapper classes
    procedure AssociateConnection(DcmConnection: IDicomConnection); // for inbound created by server wrapper
    procedure UpdateAssociation; // for outbound async
    function Read(var Buffer; Count: longint; var LostConnection: boolean): longint;
    function Write(const Buffer; Count: longint; var LostConnection: boolean): longint;
    procedure DelayedFree;
    procedure AddRef; // used to prevent wrapper from being freed via COM interface on IStream while still in scope
    procedure ReleaseRef;
    // methods matching DO
    // SetDestinationIStream not implemented because it is intended for use by the wrapper
    procedure SetDestination(const Node: WideString; Port: SYSINT; const CallingAE: WideString;
                             const CalledAE: WideString);
    procedure Close;
    procedure SendImages(Images: OleVariant);
    procedure SendStatus(Status: Integer);
    procedure SendVerify;
    procedure SaveImage(const Image: DicomImage; Destination: OleVariant; isPart10: WordBool;
                        TransferSyntax: OleVariant; Quality: OleVariant);

    property ConnectionID: integer read FConnectionID;
    property ListeningPort: integer read FListeningPort;
    property IsOutbound: boolean read FIsOutbound;
    // properties matching DO
    property Association: Integer read Get_Association;
    property Tag: OleVariant read Get_Tag write Set_Tag;
    property Mode: doConnectionMode read Get_Mode;
    property CallingAET: WideString read Get_CallingAET;
    property RemoteIP: WideString read Get_RemoteIP;
    property LocalIP: WideString read Get_LocalIP;
    property LocalPort: Integer read Get_LocalPort;
  end;

{ DicomConnectionWrappers procedures }

procedure AddWrapper(Wrapper: TDicomConnectionWrapper);
procedure RemoveWrapper(Wrapper: TDicomConnectionWrapper);
function LookupWrapper(DcmConnection: IDicomConnection): TDicomConnectionWrapper; overload;
function LookupWrapper(ListeningPort, ConnectionID: integer): TDicomConnectionWrapper; overload;

{ TDicomServerWrapper}

type
  TDicomServerWrapper = class(TObject)
    // event handlers matching DO
    // Most act as pass-through event handlers, simply calling the original TDicomServer's event handlers,
    // but also ensuring that the lifetime of the connection object doesn't expire prematurely because of a lost TCP connection
    // ActionComplete also has to update an outgoing TCP connection, which is created first, with a DicomConnection, which is created only after SetDestinationIStream
    procedure WrapperActionComplete(ASender: TObject; const Connection: DicomConnection;
      const Action: WideString; Tag: OleVariant; Success: WordBool; const ErrorMessage: WideString);
    procedure WrapperAssociationRequest(ASender: TObject;
      const Connection: IDicomConnection; var isOK: WordBool);
    procedure WrapperInstanceReceived(ASender: TObject; const Connection: DicomConnection;
      const dataset: DicomDataSet);
    procedure WrapperAssociationClosed(ASender: TObject; const Connection: DicomConnection);

    procedure ipServerConnected(Sender: TObject; ConnectionId,
      StatusCode: Integer; const Description: string);
    procedure ipServerConnectionRequest(Sender: TObject; const Address: string;
      Port: Integer; var Accept: Boolean);
    procedure ipServerDataIn(Sender: TObject; ConnectionId: Integer;
      Text: string; EOL: Boolean);
    procedure ipServerDisconnected(Sender: TObject; ConnectionId,
      StatusCode: Integer; const Description: string);
  private
    FDcmServer: TDicomServer;
    // original DO event handlers that need to be substituted
    FServerActionComplete: TDicomServerActionComplete;
    FServerAssociationRequest: TDicomServerAssociationRequest;
    FServerInstanceReceived: TDicomServerInstanceReceived;
    FServerAssociationClosed: TDicomServerAssociationClosed;
    // getters and setters for DO properties
    function Get_Tag: OleVariant;
    procedure Set_Tag(Value: OleVariant);
  public
    constructor Create(DicomServer: TDicomServer);
    procedure Free;
    procedure UpdateEventHandlers;
    // methods matching DO
    // don't re-implement IncomingIStream, which is intended for connection wrapper
    function New(const Type_: WideString): IDispatch;
    function Listen(Port: Integer): WordBool;
    procedure Unlisten(Port: Integer);
    // properties matching DO
    property Tag: OleVariant read Get_Tag write Set_Tag;  // This is a passthrough property.  Other properties that don't involve the TCP connection can usually be implemented similarly.
  end;

//##############################################################################
                                IMPLEMENTATION
//##############################################################################

{ shared }

const
  InBufferSize = 65536;
  OutBufferSize = 65536;

{ WrapperLog }

const
  EventTimestamp : string = 'ss.zzz';

var
  DOGlobal: IDicomGlobal;
  LogLevel, DoLog: integer;

procedure LogDO(const Level, Association, ConnectionID: integer; const Msg: string; DcmServer: TDicomServer = nil);
begin
  // Implementation is left as an exercise to the reader
end;



{ TNetworkStream }

// NOTE: All methods are called via a COM interface rather than in the main thread.
// Any method that they call is also called via the COM interface.  See top for
// programming notes for a COM interface.

function TNetworkStream.Clone(out stm: IStream): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.Clone not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.Commit(grfCommitFlags: DWORD): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.Commit not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.CopyTo(stm: IStream; cb: LargeUInt; out cbRead,
  cbWritten: LargeUInt): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.CopyTo not supported');
  Result := E_NOTIMPL;
end;

constructor TNetworkStream.Create(myRead: TReadFunction; myWrite: TWriteFunction; myFreeWrapper: TFreeProc);
begin
  inherited Create;
  // All four of these methods (part of TDicomConnectionWrapper) will be executed within the COM interface.
  FRead := myRead;
  FWrite := myWrite;
  FFreeWrapper := myFreeWrapper;
end;

procedure TNetworkStream.Free;
begin
  //LogDO(WrapperDebug, 0, 0, 'Freeing NetworkStream');
  inherited;
end;

function TNetworkStream.LockRegion(libOffset, cb: LargeUInt;
  dwLockType: DWORD): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.LockRegion not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.Read(pv: Pointer; cb: FixedUInt;
  pcbRead: PFixedUInt): HResult;
// DO will try again if only partial data is read, as long as S_OK is returned.
// S_FALSE is used to indicate an unrecoverable failure such as a lost TCP connection or timeout.
var
  NumRead: LongInt;
  LostConnection: boolean;
begin
  NumRead := 0;
  try
    if pv = nil then
    begin
      LogDO(WrapperError, 0, 0, Self.ClassName + ': ' + 'Error during IStream.Read: pointer is nil');
      exit(STG_E_INVALIDPOINTER);
    end;
    if not assigned(FRead) then
    begin
      LogDO(WrapperError, 0, 0, 'IStream.Read not assigned');
      exit(S_FALSE);
    end;
    try
      NumRead := FRead(pv^, cb, LostConnection);
      // *** KEY EXPECTATION: DO continues to attempt to read even if 0 bytes are returned, unless the TCP connection is reported as lost
      if LostConnection then
        exit(S_FALSE);
    except
      on E: Exception do
      begin
        LogDO(WrapperError, 0, 0, Self.ClassName + ': ' + 'Error during IStream.Read: ' + E.Message);
        exit(S_FALSE);
      end;
    end;
  finally
    if pcbRead <> nil then
      pcbRead^ := NumRead;
  end;
  Result := S_OK;
end;

function TNetworkStream.Revert: HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.Revert not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.Seek(dlibMove: Largeint; dwOrigin: DWORD;
  out libNewPosition: LargeUInt): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.Seek not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.SetSize(libNewSize: LargeUInt): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.SetSize not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.Stat(out statstg: TStatStg;
  grfStatFlag: DWORD): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.Stat not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.UnlockRegion(libOffset, cb: LargeUInt;
  dwLockType: DWORD): HResult;
begin
  LogDO(WrapperWarning, 0, 0, 'IStream.UnlockRegion not supported');
  Result := E_NOTIMPL;
end;

function TNetworkStream.Write(pv: Pointer; cb: FixedUInt;
  pcbWritten: PFixedUInt): HResult;
var
  NumWritten: LongInt;
  LostConnection: boolean;
begin
  NumWritten := 0;
  try
    if pv = nil then
    begin
      LogDO(WrapperError, 0, 0, Self.ClassName + ': ' + 'Error during IStream.Write: pointer is nil');
      exit(STG_E_INVALIDPOINTER);
    end;
    if not assigned(FWrite) then
    begin
      LogDO(WrapperError, 0, 0, 'IStream.Write not assigned');
      exit(STG_E_CANTSAVE);
    end;
    try
      NumWritten := FWrite(pv^, cb, LostConnection);
      // *** KEY EXPECTATION: DicomObjects continues to write regardless of number of bytes written unless told that writing cannot be done
      if LostConnection then
      begin
        exit(STG_E_CANTSAVE);
      end;
    except
      on E: Exception do
      begin
        LogDO(WrapperError, 0, 0, Self.ClassName + ': ' + 'Error during IStream.Write: ' + E.Message);
        exit(STG_E_CANTSAVE);
      end;
    end;
  finally
    if pcbWritten <> nil then
      pcbWritten^ := NumWritten;
  end;
  Result := S_OK;
end;

function TNetworkStream._AddRef: integer;
begin
  Result := inherited;
  LogDO(WrapperDebug, 0, 0, Format('#ref after AddRef: %d', [RefCount]));
end;

function TNetworkStream._Release: integer;
begin
  try
    // need to do these before inherited, otherwise we get unpleasant errors
    if (RefCount = 1) then
    begin
      if assigned(FFreeWrapper) then
        FFreeWrapper
      else
        LogDO(WrapperError, 0, 0, 'IStream.FreeWrapper not assigned');
    end;
  except
    on E: Exception do
      LogDO(WrapperError, 0, 0, 'Unexpected error in NetworkStream._Release: ' + E.Message);
  end;
  Result := inherited;
  LogDO(WrapperDebug, 0, 0, Format('#ref after Release: %d', [RefCount]));
end;



{ TDicomConnectionWrapper }

procedure TDicomConnectionWrapper.AddRef;
begin
  FNetworkStream._AddRef;
end;

procedure TDicomConnectionWrapper.AssociateConnection(
  DcmConnection: IDicomConnection);
begin
  // *** KEY CODE: For an incoming TCP connection, associate the newly created DicomConnection object with the TCP connection
  // associate a DicomConnection (association) with an inbound TCP connection
  FDcmConnection := DcmConnection;
  FDcmConnection.Tag := Null;
  FOriginalAssociation := FDcmConnection.Association;
end;

procedure TDicomConnectionWrapper.CheckForDisconnect(const CallingName: string; const LogLevel: integer);
begin
  if not true {server/client TCP connection is active} then
  begin
    FLostConnection := true;
    LogDO(LogLevel, Association, FConnectionID, CallingName + ': TCP connection lost', FDcmServer);
  end;
end;

procedure TDicomConnectionWrapper.Close;
begin
  FDcmConnection.Close;
end;

constructor TDicomConnectionWrapper.Create(DcmServer: TDicomServer;
    ipServer: TObject {TipwIPDaemon}; ConnectionID: integer);
// inbound async constructor (for secure connections or at least IPWorks connections)
var
  MyStream: IStream;
  ConnectionTag: string;
begin
  inherited Create;
  FOriginalAssociation := 0;
  FDcmServer := DcmServer;
  FRefCount := 0;
  FIsOutbound := false;

  // set properties that identify the TCP connection
  {
  FConnectionID := ConnectionID;
  FipServer := ipServer;
  FListeningPort := FipServer.LocalPort;
  }

  SetupStreamsAndTimeout;
  MyStream := FNetworkStream;
  // *** KEY CODE: incoming connection is a TCP connection but the DicomConnection isn't created until AssociationRequest on FDcmServer
  // *** KEY EXPECTATION: DicomObjects will apply the provided tag to the new DicomConnection so we can associate it with the TCP connection
  ConnectionTag := Format('lookup|%d|%d', [FListeningPort, ConnectionID]);
  FDcmServer.IncomingIStream(MyStream, ConnectionTag);
  // don't call AddRef because wrapper won't be used until an association is established
  AddWrapper(Self);
end;

constructor TDicomConnectionWrapper.Create(DcmServer: TDicomServer);
// outbound async constructor
begin
  inherited Create;
  FDcmServer := DcmServer;
  FDcmConnection := FDcmServer.New('DicomConnection') as IDicomConnection;
  FOriginalAssociation := 0; // set after SetDestination
  FDcmConnection.Mode := doAsync;
  FRefCount := 0;
  FIsOutbound := true;
  {
  FConnectionID := 0;
  FListeningPort := 0;
  }
  SetupStreamsAndTimeout;
  SetupTCPClient;
  AddRef; // matches application code's ReleaseRef so that if there's a problem with establishing a TCP or DICOM connection, the wrapper doesn't go out of scope prematurely
  AddWrapper(Self);
end;

constructor TDicomConnectionWrapper.Create();
// outbound sync constructor
begin
  inherited Create;
  FDcmConnection := CoDicomConnection.Create;
  FOriginalAssociation := 0; // set after SetDestination
  FDcmServer := nil;
  FRefCount := 0;
  FIsOutbound := true;
  {
  FConnectionID := 0;
  FListeningPort := 0;
  }
  SetupStreamsAndTimeout;
  SetupTCPClient;
  AddRef;
  AddWrapper(Self);
end;

procedure TDicomConnectionWrapper.DelayedFree;
// NOTE: This is executed within the COM interface.  It should not access IPWorks components
// and should lock any wrapper resources that it needs to be atomic (and those resources should be locked elsewhere, too)
begin
  // don't free the wrapper in the call that the IStream makes or the SCP will report an error later (e.g. when app is closed)
  try
    RemoveWrapper(Self);
    FDcmConnection := nil;
    FDcmServer := nil;
    LogDO(WrapperDebug, Association, FConnectionID, 'DelayedFree', FDcmServer);
    FTimerDestruct.Interval := 10; // this isn't exact; actual timer firing may vary, at least if set to smaller values (such as 10 ms)
    FTimerDestruct.Enabled := true;
  except
    on E: Exception do
      LogDO(WrapperError, Association, FConnectionID, 'Unexpected error in DelayedFree: ' + E.Message, FDcmServer);
  end;
end;

procedure TDicomConnectionWrapper.Free;
begin
  RemoveWrapper(Self);
  LogDO(WrapperDebug, Association, FConnectionID, 'Freeing wrapper', FDcmServer);
  // don't free FNetworkStream because it's reference-counted and will be freed automatically; also it frees the wrapper when released
  // (FNetworkStream creation does not increment the reference count)

  // terminate TLS session, disconnect, and free TCP component(s), streams, etc.
  FTimerDestruct.Free;
  FTimerInbound.Enabled := false;
  FTimerInbound.Free;
  FTimerSendOutboundToSocket.Enabled := false;
  FTimerSendOutboundToSocket.Free;
  inherited;
end;

function TDicomConnectionWrapper.Get_Association: Integer;
var
  tmpAssociation: integer;
begin
  Result := FOriginalAssociation; // used to retain the original association number after DO releases the DicomConnection, for logging
  if FDcmConnection <> nil then
  begin
    tmpAssociation := FDcmConnection.Association;
    if tmpAssociation <> 0 then
      Result := tmpAssociation;
  end;
end;

function TDicomConnectionWrapper.Get_CallingAET: WideString;
begin
  Result := FDcmConnection.CallingAET;
end;

function TDicomConnectionWrapper.Get_LocalIP: WideString;
begin
  Result := '';
  // return appropriate value from TCP component
end;

function TDicomConnectionWrapper.Get_LocalPort: Integer;
begin
  Result := 0;
  // return appropriate value from TCP component
end;

function TDicomConnectionWrapper.Get_Mode: doConnectionMode;
begin
  Result := FDcmConnection.Mode;
end;

function TDicomConnectionWrapper.Get_RemoteIP: WideString;
begin
  Result := '';
  // return appropriate value from TCP component
end;

function TDicomConnectionWrapper.Get_Tag: OleVariant;
begin
  Result := FDcmConnection.Tag;
end;

// TCP-component specific event handler for incoming data
procedure TDicomConnectionWrapper.ipDataIn(Sender: TObject; Text: string;
  EOL: Boolean);
var
  NumBytes: integer;
begin
  NumBytes := 0;
  // write incoming data into stream for inbound data
  LogDO(WrapperDebug, Association, FConnectionID, Format('ipDataIn: Wrote incoming data into stream: %d bytes', [NumBytes]), FDcmServer);
end;

procedure TDicomConnectionWrapper.ipDisconnected(Sender: TObject;
  StatusCode: Integer; const Description: string);
begin
  // clean up properties that are not valid after disconnection
end;

procedure TDicomConnectionWrapper.ipError(Sender: TObject; ErrorCode: Integer;
  const Description: string);
begin
  // log error information
end;

function TDicomConnectionWrapper.Read(var Buffer; Count: Integer; var LostConnection: boolean): longint;
// NOTE: This is executed within the COM interface.
begin
  Result := 0;
  LostConnection := false; // DO doesn't initialize LostConnection

  // read up to the maximum of Count or available data from the inbound stream into the provided Buffer parameter and return the number of bytes actually read
  // *** KEY CODE (not shown): report a lost connection only if there is no more data left to read, otherwise DO will abort the association

  // *** KEY CODE (not shown): DO does not check timeout unless it manages the TCP connection.  The equivalent behavior is to check timeout in Read.  Report timeout as a lost connection.
  // *** KEY BEHAVIOR: DO writes data to an outbound stream and immediately turns around and waits for inbound data, which is not yet available.  May be best to return immediately with no data but connection intact, depending on need for non-blocking code.

end;

procedure TDicomConnectionWrapper.ReleaseRef;
begin
  FNetworkStream._Release
end;

procedure TDicomConnectionWrapper.SaveImage(const Image: DicomImage;
  Destination: OleVariant; isPart10: WordBool; TransferSyntax,
  Quality: OleVariant);
begin
  FDcmConnection.SaveImage(Image, Destination, isPart10, TransferSyntax, Quality);
end;

procedure TDicomConnectionWrapper.SelfDestructOnTimer(Sender: TObject);
begin
  FTimerDestruct.Enabled := false;

  // if there is still unsent data and the connection is open, wait until the data is sent (or the connection is dropped by the other side)
  // by setting the timer to true and exiting

  LogDO(WrapperDebug, Association, FConnectionID, 'About to self-destruct', FDcmServer);
  Free;
end;

procedure TDicomConnectionWrapper.SendImages(Images: OleVariant);
begin
  FDcmConnection.SendImages(Images);
end;

procedure TDicomConnectionWrapper.SendStatus(Status: Integer);
begin
  FDcmConnection.SendStatus(Status);
end;

procedure TDicomConnectionWrapper.SendVerify;
begin
  FDcmConnection.SendVerify;
end;

procedure TDicomConnectionWrapper.SetDestination(const Node: WideString;
  Port: SYSINT; const CallingAE, CalledAE: WideString);
var
  MyStream: IStream;
begin
  if FIsOutbound then
  begin
    MyStream := FNetworkStream; // get an interface from a TInterfacedObject
    try
      // establish the TCP connection

      // *** KEY CODE: Call SetDestinationIStream after establishing the TCP connection and preparing an IStream interface
      FDcmConnection.SetDestinationIStream(MyStream, CallingAE, CalledAE);
    except
      on E: Exception do
      begin
        LogDO(WrapperError, Self.Association, FConnectionID, Format('Failed to connect to %s on %d: %s', [Node, Port, E.Message]), FDcmServer);
        // this code is here to permit this particular solution to work with an existing codebase while making limited changes (primarily looking up the TDicomConnectionWrapper in each DicomServer event handler and using the wrapper in lieu of the DicomConnection)
        if (FDcmConnection.Mode = doAsync) and assigned(FDcmServer.OnActionComplete) then
          FDcmServer.OnActionComplete(FDcmServer, FDcmConnection, 'SetDestination', FDcmConnection.Tag, false, E.Message)
        else
          raise; // application needs to handle it
        exit;
      end;
    end;
  end;
  // C-MOVE code has been removed
  if FIsOutbound then // don't reset if doing a C-MOVE for incoming; it's already been set
    FOriginalAssociation := FDcmConnection.Association;
end;

procedure TDicomConnectionWrapper.SetupStreamsAndTimeout;
begin
  // set up timeout handling
  try
    // set up streams and locks and initialize variables

    // Note: Create doesn't increment the reference count for the IStream,
    // so FNetworkStream will self-destruct when DO releases it;
    // consequently only reference FNetworkStream with exception trapping or
    // when DO would not have freed it (which typically happens after Close or Abort)
    FNetWorkStream := TNetworkStream.Create(Self.Read, Self.Write, Self.DelayedFree);
    FTimerDestruct := TTimer.Create(nil);
    FTimerDestruct.Enabled := false;
    FTimerDestruct.OnTimer := SelfDestructOnTimer;
    FTimerInbound := TTimer.Create(nil);
    FTimerInbound.Enabled := false;
    FTimerInbound.Interval := 5;
    FTimerInbound.OnTimer := TimerInbound;
    FTimerSendOutboundToSocket := TTimer.Create(nil);
    FTimerSendOutboundToSocket.Enabled := false;
    FTimerSendOutboundToSocket.Interval := 5;
    FTimerSendOutboundToSocket.OnTimer := TimerSendOutboundToSocket;
    FLostConnection := false;
    FSendInProgress := false;
  except
    on E: Exception do
    begin
      LogDO(WrapperError, Association, FConnectionID, 'Could not set up network streams and destruct timer: ' + E.Message, FDcmServer);
    end;
  end;
end;

procedure TDicomConnectionWrapper.SetupTCPClient;
begin
  // set up TCP client component
end;

procedure TDicomConnectionWrapper.Set_Tag(Value: OleVariant);
begin
  FDcmConnection.Tag := Value;
end;

procedure TDicomConnectionWrapper.TimerInbound(
  Sender: TObject);
begin
  try
    CheckForDisconnect('TimerInbound', WrapperDebug);
  finally
    FTimerInbound.Enabled := false;
  end;
end;

procedure TDicomConnectionWrapper.TimerSendOutboundToSocket(Sender: TObject);
begin
  FSendInProgress := true;
  FTimerSendOutboundToSocket.Enabled := false; // so it doesn't fire again until we're done sending

  // send data on outbound stream to socket (also check for TCP disconnection)
end;

procedure TDicomConnectionWrapper.UpdateAssociation;
begin
  FOriginalAssociation := FDcmConnection.Association;
end;

function TDicomConnectionWrapper.Write(const Buffer; Count: Integer; var LostConnection: boolean): longint;
// NOTE: This is executed within the COM interface.  It should not access IPWorks components
// and should lock any wrapper resources that it needs to be atomic (and those resources should be locked elsewhere, too)
var
  BytesToStream: longint;
begin
  LostConnection := FLostConnection;
  if FLostConnection then
  begin
    exit(0);
  end;

  // write up to Count bytes from Buffer to outbound stream and return number of bytes written
  Result := BytesToStream;
end;



{ DicomConnectionWrappers }

// *** KEY CODE: Provides lookup capability based on either TCP connection info (inbound only) or DicomConnection, either to ensure these are linked or to access functionality associated with the information that a section of code does not possess

var
  WrapperList: TObjectList<TDicomConnectionWrapper>;
  myWrapper: TDicomConnectionWrapper;

procedure AddWrapper(Wrapper: TDicomConnectionWrapper);
begin
  WrapperList.Add(Wrapper);
end;

procedure RemoveWrapper(Wrapper: TDicomConnectionWrapper);
begin
  WrapperList.Remove(Wrapper);
end;

function LookupWrapper(DcmConnection: IDicomConnection): TDicomConnectionWrapper;
var
  i: integer;
  Wrapper: TDicomConnectionWrapper;
  Port, TCPConnectionID: integer;
  myTag: string;
  TagArray: TArray<string>;
begin
  Result := nil;
  for i := 0 to WrapperList.Count - 1 do
  begin
    if WrapperList[i].Association = DcmConnection.Association then
    begin
      Result := WrapperList[i];
      exit;
    end;
  end;
  // look it up by incoming port and connection ID in case it is an incoming association
  // that hasn't yet been mapped to an inbound connection wrapper
  // This could be because AssociationRequest being processed or because code accessed
  // DicomGlobal.CurrentConnections
  if Vartype(DcmConnection.Tag) = varOleStr then
  begin
    // inbound wrapper created earlier by server wrapper
    myTag := DcmConnection.Tag;
    if Copy(myTag, 1, 7) = 'lookup|' then
    begin
      TagArray := myTag.Split(['|']);
      try
        Port := StrToInt(TagArray[1]);
        TCPConnectionID := StrToInt(TagArray[2]);
        Wrapper := LookupWrapper(Port, TCPConnectionID);
        Wrapper.AssociateConnection(DcmConnection);
        Result := Wrapper;
      except
        // it's not there
      end;
    end;
  end;
end;

function LookupWrapper(ListeningPort, ConnectionID: integer): TDicomConnectionWrapper;
var
  i: integer;
begin
  Result := nil;
  for i := 0 to WrapperList.Count - 1 do
  begin
    if (WrapperList[i].ConnectionID = ConnectionID)
        and (WrapperList[i].ListeningPort = ListeningPort) then
    begin
      Result := WrapperList[i];
      exit;
    end;
  end;
end;



{ TDicomServerWrapper }

constructor TDicomServerWrapper.Create(DicomServer: TDicomServer);
begin
  inherited Create;
  FDcmServer := DicomServer;

  // create TCP server object or list of TCP server objects

  UpdateEventHandlers;
end;

procedure TDicomServerWrapper.Free;
begin
  FDcmServer.OnActionComplete := FServerActionComplete;
  FDcmServer.OnAssociationRequest := FServerAssociationRequest;
  FDcmServer.OnInstanceReceived := FServerInstanceReceived;
  FDcmServer.OnAssociationClosed := FServerAssociationClosed;
  FServerActionComplete := nil;
  FServerAssociationRequest := nil;
  FServerInstanceReceived := nil;
  FServerAssociationClosed := nil;

  // free TCP server(s)

  FDcmServer := nil;
  inherited;
end;

function TDicomServerWrapper.Get_Tag: OleVariant;
begin
  Result := FDcmServer.Tag;
end;

procedure TDicomServerWrapper.ipServerConnected(Sender: TObject; ConnectionId,
  StatusCode: Integer; const Description: string);
begin
  // *** KEY CODE: create inbound connection wrapper identified by TCP connection info; the wrapper will spawn creation of a DICOM association by DO
  TDicomConnectionWrapper.Create(FDcmServer, Sender, ConnectionId);
end;

procedure TDicomServerWrapper.ipServerConnectionRequest(Sender: TObject;
  const Address: string; Port: Integer; var Accept: Boolean);
begin
  Accept := true;
end;

procedure TDicomServerWrapper.ipServerDataIn(Sender: TObject;
  ConnectionId: Integer; Text: string; EOL: Boolean);
var
  ConnectionWrapper: TDicomConnectionWrapper;
begin
  // pass data to connection
  //ConnectionWrapper := LookupWrapper(ipServer.LocalPort, ConnectionId);
  if ConnectionWrapper <> nil then
    ConnectionWrapper.ipDataIn(Sender, Text, EOL)
  else
    LogDO(WrapperWarning, 0, ConnectionID, 'Could not find wrapper for incoming data', FDcmServer);
end;

procedure TDicomServerWrapper.ipServerDisconnected(Sender: TObject;
  ConnectionId, StatusCode: Integer; const Description: string);
var
  ConnectionWrapper: TDicomConnectionWrapper;
begin
  //ConnectionWrapper := LookupWrapper(ipServer.LocalPort, ConnectionId);
  // will be nil if association was closed normally and the wrapper has finished being released
  if ConnectionWrapper <> nil then
    // will result in timeout if DO thought the association was still open; eventually the wrapper will be freed when IStream is released
    ConnectionWrapper.ipDisconnected(Sender, StatusCode, Description)
  else
    LogDO(WrapperInfo, 0, ConnectionID, 'TCP disconnected', FDcmServer);
end;

function TDicomServerWrapper.Listen(Port: Integer): WordBool;
begin
  // create TCP server, configure, and listen
end;

function TDicomServerWrapper.New(const Type_: WideString): IDispatch;
begin
  // This is a pass-through method.  Most methods that do no involve the TCP connection can be implemented similarly.
  Result := FDcmServer.New(Type_);
end;

procedure TDicomServerWrapper.Set_Tag(Value: OleVariant);
begin
  FDcmServer.Tag := Value;
end;

procedure TDicomServerWrapper.Unlisten(Port: Integer);
begin
  // find TCP server listening on that port and stop listening
end;

procedure TDicomServerWrapper.UpdateEventHandlers;
begin
  FServerActionComplete := FDcmServer.OnActionComplete;
  FServerAssociationRequest := FDcmServer.OnAssociationRequest;
  FServerInstanceReceived := FDcmServer.OnInstanceReceived;
  FServerAssociationClosed := FDcmServer.OnAssociationClosed;
  FDcmServer.OnActionComplete := WrapperActionComplete;
  FDcmServer.OnAssociationRequest := WrapperAssociationRequest;
  FDcmServer.OnInstanceReceived := WrapperInstanceReceived;
  FDcmServer.OnAssociationClosed := WrapperAssociationClosed;
end;

procedure TDicomServerWrapper.WrapperActionComplete(ASender: TObject;
  const Connection: DicomConnection; const Action: WideString; Tag: OleVariant;
  Success: WordBool; const ErrorMessage: WideString);
var
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(Connection);
  if Wrapper <> nil then
  begin
    if (Action = 'SetDestination') then
      Wrapper.UpdateAssociation; // so the association number can still be logged when the wrapper is being freed
  end;

  if not assigned(FServerActionComplete) then
    exit;
  // make sure we have a wrapper at least for the duration of the event handler
  if Wrapper = nil then
    exit;
  // make sure the wrapper doesn't go out of scope during the event handler
  Wrapper.AddRef;
  try
    FServerActionComplete(ASender, Connection, Action, Tag, Success, ErrorMessage);
  finally
    Wrapper.ReleaseRef;
  end;
end;

procedure TDicomServerWrapper.WrapperAssociationClosed(ASender: TObject;
  const Connection: DicomConnection);
var
  Wrapper: TDicomConnectionWrapper;
begin
  if not assigned(FServerAssociationClosed) then
    exit;

  Wrapper := LookupWrapper(Connection);
  if Wrapper = nil then
    exit;
  // make sure the wrapper doesn't go out of scope during the event handler
  Wrapper.AddRef;
  try
    FServerAssociationClosed(ASender, Connection);
  finally
    Wrapper.ReleaseRef;
  end;
end;

procedure TDicomServerWrapper.WrapperAssociationRequest(ASender: TObject;
  const Connection: IDicomConnection; var isOK: WordBool);
var
  Wrapper: TDicomConnectionWrapper;
begin
  Wrapper := LookupWrapper(Connection); // will associate just-created IDicomConnection to inbound wrapper if created for IPWorks, must be done for all new connections

  if not assigned(FServerAssociationRequest) then
    exit;

  if Wrapper = nil then
    exit;
  // make sure the wrapper doesn't go out of scope during the event handler
  Wrapper.AddRef;
  try
    FServerAssociationRequest(ASender, Connection, isOK);
  finally
    Wrapper.ReleaseRef;
  end;
end;

procedure TDicomServerWrapper.WrapperInstanceReceived(ASender: TObject;
  const Connection: DicomConnection; const dataset: DicomDataSet);
var
  Wrapper: TDicomConnectionWrapper;
begin
  if not assigned(FServerInstanceReceived) then
    exit;

  Wrapper := LookupWrapper(Connection);
  if Wrapper = nil then
    exit;
  // make sure the wrapper doesn't go out of scope during the event handler
  Wrapper.AddRef;
  try
    FServerInstanceReceived(ASender, Connection, dataset);
  finally
    Wrapper.ReleaseRef;
  end;
end;


initialization

{ WrapperLog }

  DOGlobal := CoDicomGlobal.Create;
  LogLevel := DOGlobal.RegWord['LogLevel'];
  DoLog := DOGlobal.RegWord['Log'];

{ DicomConnectionWrappers }

  WrapperList := TObjectList<TDicomConnectionWrapper>.Create(false); // objects not freed when removed

  // required because we implement a COM interface, and COM calls don't happen on the main thread;
  // this is also set automatically when we create a tlb via the wizard, and is likely also by service applications
  System.IsMultiThread := true;

finalization

{ DicomConnectionWrappers }

  while WrapperList.Count > 0 do
  begin
    myWrapper := WrapperList[0];
    WrapperList.Remove(myWrapper);
    myWrapper.Free;
  end;
  WrapperList.Free;

end.
