unit URPCCache;
////////////////////////////////////////////////////////////////////////////////
///  This unit defines the TRPCCache object.
///
///  The RPCCache automatically gets created and destroyed when using this unit,
///  but it needs to be initialized. It expects a JSONParameters object, or a
///  string, holding a valid JSON structure that looks like somewhat like
///  this:
///
///  {
///    "RPCCache": {
///      "Enabled": true,
///      "Caches" : [
///        {
///          "RPC": "ORWU NPHASKEY",
///          "Context": "OR CPRS GUI CHART",
///          "MaxSize": 50,
///          "MaxAge": 8640000,
///          "IgnoreCase": true,
///          "Enabled": true
///        },{
///          "RPC": "ORWU HASKEY",
///          "Context": "OR CPRS GUI CHART",
///          "MaxSize": 50,
///          "MaxAge": 8640000
///        },{
///          "RPC": "ORWDPS32 DRUGMSG",
///          "Context": "OR CPRS GUI CHART"
///        },{
///          "RPC": "ORWDPS2 ADMIN",
///          "Context": "OR CPRS GUI CHART"
///        },{
///          "RPC": "ORNEWPERS NEWPERSON",
///          "Context": "OR CPRS GUI CHART",
///          "MaxSize": 250,
///          "Enabled": true
///        }
///      ]
///    }
///  }
///
///  Alternately, implement the TRPCCache.OnNewContext event, to get an event
///  whenever the RPCCache encounters a new context. Or do both.
////////////////////////////////////////////////////////////////////////////////

interface

uses
  UCache,
  System.JSON,
  System.Generics.Collections,
  System.SyncObjs,
  System.Classes;

type
  TRPCCacheItem = class(TCacheItem<string>)
  strict protected
    class function CopyVarRec(const AItem: TVarRec): TVarRec; override;
    function IsSameVarRec(const ALeft, ARight: TVarRec; AIgnoreCase: Boolean)
      : Boolean; override;
  end;

  TRPCCacheList = class;

  TCallVistaFunction = function(const aRPCName: string;
    const aParam: array of const; aReturn: TStrings;
    RequireResults: Boolean): Boolean;

  TRPCCache = class(TCache<string>)
  strict private
    FRPC: string;
    FContext: string;
    FRPCCacheList: TRPCCacheList;
  strict protected
    type
      TVarRecArray = array of TVarrec;
  strict protected
    class function ConcatArrays(const [Ref] Array1, Array2: array of const)
      : TVarRecArray;
    class function VarRecToStr(const V: TVarRec): string;
    function CreateCacheItem(const AData: array of const)
      : TCacheItem<string>; override;
  protected
    constructor Create(ARPCCacheList: TRPCCacheList;
      const ARPC, AContext: string); overload;
    procedure LogFound(const AData, AExtraData: array of const;
      AFoundCacheItem: TCacheItem<string>; AStartTime, ASTopTime: TDateTime);
  public
    constructor Create; overload;
    property RPC: string read FRPC;
    property Context: string read FContext;
    function CallVistA(const AData: array of const; AReply: TStrings;
      ARequireResults: Boolean; ACallVistaFunction: TCallVistAFunction)
      : Boolean; overload;
    function CallVistA(const AData, AExtraData: array of const;
      AReply: TStrings; ARequireResults: Boolean;
      ACallVistaFunction: TCallVistAFunction): Boolean; overload;
  end;

  TLogEvent = procedure(const ALog: string; AName: string = '';
    ARanAt: TDateTime = -1; ADuration: TDateTime = -1) of object;

  TNewContextEvent = procedure(Sender: TRPCCacheList;
    const AContext: string) of object;

  TRPCCacheList = class(TObjectList<TRPCCache>)
  strict private
    FInitializedContexts: TStringList;
    FEnabled: Boolean;
    FCriticalSection: TCriticalSection;
    FOnLog: TLogEvent;
    FOnNewContext: TNewContextEvent;
    procedure SetOnNewContext(const Value: TNewContextEvent);
  strict protected
    property CriticalSection: TCriticalSection read FCriticalSection;
  public
    constructor Create;
    destructor Destroy; override;
    property Enabled: Boolean read FEnabled write FEnabled;
    /// <summary>
    ///    This event fires when a succesful cache lookup has occured.
    /// </summary>
    /// <param name="ALog">
    ///    A "Last Broker Call style" formatted string/log entry.
    /// </param>
    property OnLog: TLogEvent read FOnLog write FOnLog;
    /// <summary>
    ///    A list of all contexts that have been initialized
    /// </summary>
    property InitializedContexts: TStringList read FInitializedContexts;
    /// <summary>
    ///    This event fires when an unknown context is detected in a call to
    ///    TRPCCacheList.CallVista. You will want to call
    ///    TRPCCacheList.Initialize in response to this event.
    /// </summary>
    /// <param name="Sender">
    ///    The TRPCCacheList firing the event. (Call Initialize on it.)
    /// </param>
    /// <param name="AContext">
    ///    The new context.
    /// </param>
    property OnNewContext: TNewContextEvent read FOnNewContext
      write SetOnNewContext;
    function Add(ARPCCache: TRPCCache): Integer;
    function Find(const ARPC, AContext: string): TRPCCache;
    /// <summary>
    ///    This procedure clears the entire cache. It needs to be reinitialized
    ///    for continued use. All settings will be lost.
    /// </summary>
    procedure Clear;
    /// <summary>
    ///    This procedure cleans out the cached data. After calling this, it
    ///    will be like the cache was just freshly initialized.
    /// </summary>
    procedure ClearItems;
    /// <summary>
    ///    This procedure cleans out the cached data for one type of RPC call.
    ///    After calling this, it will be like the cache for that type of RPC
    ///    call was just freshly initialized.
    /// </summary>
    procedure ClearItem(const ARPC, AContext: string);
    /// <summary>
    ///    This procedure cleans out the cached data for one single RPC call.
    /// </summary>
    procedure ClearRPC(const ARPC, AContext: string;
      const AData: array of const);
    /// <summary>
    ///    This procedure initializes the cache. Subsequent calls to this
    ///    procedure may be used to add additional RPCs to the cache, or to
    ///    reconfigure RPCs.
    /// </summary>
    /// <param name="AData">
    ///    Refer to the JSON data structure at the top of unit URPCCache.
    /// </param>
    procedure Initialize(const AData: string); overload;
    /// <summary>
    ///    This procedure initializes the cache. Subsequent calls to this
    ///    procedure may be used to add additional RPCs to the cache, or to
    ///    reconfigure RPCs.
    /// </summary>
    /// <param name="AData">
    ///    Refer to the JSON data structure at the top of unit URPCCache.
    /// </param>
    procedure Initialize(AData: TJSONObject); overload;
    /// <summary>
    ///    This procedure either retrieves a result from the cache, or makes a
    ///    call to Vista. It also stores the results in the cache.
    /// </summary>
    /// <param name="AReply">
    ///    The result of the RPC call. Any passed in data will be cleared.
    /// </param>
    /// <param name="ACallVistaFunction">
    ///    The function to use when the code decides to make an actual RPC call.
    ///    For an example, please look in unit ORNet.
    /// </param>
    /// <returns>
    ///    Was the RPC call or cache lookup successfull
    /// </returns>
    function CallVistA(const ARPC, AContext: string;
      const AData: array of const; AReply: TStrings; ARequireResults: Boolean;
      ACallVistaFunction: TCallVistAFunction): Boolean; overload;
    /// <summary>
    ///    This procedure either retrieves a result from the cache, or makes a
    ///    call to Vista. It also stores the results in the cache.
    /// </summary>
    /// <param name="AExtraData">
    ///    Data used in the cache lookup, but not in the RPC call.
    /// </param>
    /// <param name="AReply">
    ///    The result of the RPC call. Any passed in data will be cleared.
    /// </param>
    /// <param name="ACallVistaFunction">
    ///    The function to use when the code decides to make an actual RPC call.
    ///    For an example, please look in unit ORNet.
    /// </param>
    /// <returns>
    ///    Was the RPC call or cache lookup successfull
    /// </returns>
    function CallVistA(const ARPC, AContext: string;
      const AData, AExtraData: array of const; AReply: TStrings;
      ARequireResults: Boolean; ACallVistaFunction: TCallVistAFunction)
      : Boolean; overload;
  end;

var
  RPCCache: TRPCCacheList;

implementation

uses
  ORNetIntf,
  System.Variants,
  System.Rtti,
  System.SysUtils;

class function TRPCCacheItem.CopyVarRec(const AItem: TVarRec): TVarRec;
var
  AIsNetMult: Boolean;
  AORNetMult: IORNetMult;
begin
  case AItem.VType of
    vtInterface:
      begin
        AIsNetMult := IInterface(AItem.VInterface).QueryInterface(IORNetMult,
          AORNetMult) = S_OK;
        if AIsNetMult then
        begin
          // If we are copying a NetMult we need a snapshot in time. Processes
          // like similar names just modify an existing netmult to make the S/N
          // RPC call, but that means if we don't copy the values, we end up
          // finding false matches in the cache.
          Result := AItem;
          Result.VInterface := nil;
          AORNetMult := CopyORNetMult(AORNetMult);
          IInterface(Result.VInterface) := IInterface(AORNetMult);
        end else begin
          Result := inherited CopyVarRec(AItem);
        end;
      end;
  else Result := inherited CopyVarRec(AItem);
  end;
end;

function TRPCCacheItem.IsSameVarRec(const ALeft, ARight: TVarRec;
  AIgnoreCase: Boolean): Boolean;
var
  ALeftI, ARightI: IORNetMult;
  B: Boolean;
begin
  Result := inherited IsSameVarRec(ALeft, ARight, AIgnoreCase);
  if not Result then
  begin
    if ALeft.VType <> ARight.VType then Exit(False);
    case ALeft.VType of
      vtInterface:
        begin
          B := IInterface(ALeft.VInterface).QueryInterface(IORNetMult,
            ALeftI) = S_OK;
          if not B then Exit(False);
          B := IInterface(ARight.VInterface).QueryInterface(IORNetMult,
            ARightI) = S_OK;
          if not B then Exit(False);
          Result := ALeftI.IsSame(ARightI, AIgnoreCase);
        end;
    end;
  end;
end;

constructor TRPCCacheList.Create;
begin
  inherited Create(True);
  FCriticalSection := TCriticalSection.Create;
  FEnabled := True;
  FInitializedContexts := TStringList.Create(dupIgnore, True, False);
end;

destructor TRPCCacheList.Destroy;
begin
  FreeAndNil(FInitializedContexts);
  FreeAndNil(FCriticalSection);
  inherited Destroy;
end;

function TRPCCacheList.Add(ARPCCache: TRPCCache): Integer;
begin
  if not Assigned(ARPCCache) then
      raise Exception.Create('ARPCCache not assigned');
  CriticalSection.Enter;
  try
    Result := inherited Add(ARPCCache);
  finally
    CriticalSection.Leave;
  end;
end;

function TRPCCacheList.Find(const ARPC, AContext: string): TRPCCache;
begin
  if not Enabled then Exit(nil);
  for Result in Self do
    if SameText(Result.RPC, ARPC) and SameText(Result.Context, AContext) then
        Exit;
  Exit(nil);
end;

procedure TRPCCacheList.Clear;
begin
  inherited Clear;
  FInitializedContexts.Clear;
end;

procedure TRPCCacheList.ClearItems;
var
  ARPCCache: TRPCCache;
begin
  CriticalSection.Enter;
  try
    for ARPCCache in Self do ARPCCache.Clear;
  finally
    CriticalSection.Leave;
  end;
end;

procedure TRPCCacheList.ClearItem(const ARPC, AContext: string);
var
  ARPCCache: TRPCCache;
begin
  ARPCCache := Find(ARPC, AContext);
  if Assigned(ARPCCache) then
  begin
    CriticalSection.Enter;
    try
      ARPCCache.Clear;
    finally
      CriticalSection.Leave;
    end;
  end;
end;

procedure TRPCCacheList.ClearRPC(const ARPC, AContext: string;
  const AData: array of const);
var
  ARPCCache: TRPCCache;
begin
  ARPCCache := Find(ARPC, AContext);
  if Assigned(ARPCCache) then
  begin
    CriticalSection.Enter;
    try
      ARPCCache.Remove(AData);
    finally
      CriticalSection.Leave;
    end;
  end;
end;

procedure TRPCCacheList.Initialize(const AData: string);
var
  AJSONObject: TJSONObject;
begin
  AJSONObject := TJSONObject.ParseJSONValue(StringReplace(AData, #13#10, '',
    [rfReplaceAll, rfIgnoreCase])) as TJSONObject;
  try
    if not Assigned(AJSONObject) then
        raise Exception.CreateFmt('AData not valid:'#13#10'%s', [AData]);
    Initialize(AJSONObject);
  finally
    FreeAndNil(AJSONObject);
  end;
end;

procedure TRPCCacheList.Initialize(AData: TJSONObject);
var
  ARPCCache: TRPCCache;
  AJSONValue: TJSONValue;
  AJSONArray: TJSONArray;
  AJSONObject: TJSONObject;
  ARPC, AContext: string;
  AMaxSize: Integer;
  AMaxAge: Int64;
  AIgnoreCase, AEnabled: Boolean;
begin
  CriticalSection.Enter;
  try
    if AData.TryGetValue<TJSONArray>('RPCCache.Caches', AJSONArray) then
    begin
      for AJSONValue in AJSONArray do
      begin
        if AJSONValue is TJSONObject then
        begin
          AJSONObject := TJSONObject(AJSONValue);
          if (AJSONObject.TryGetValue<string>('RPC', ARPC)) and
            (Trim(ARPC) <> '') and
            (AJSONObject.TryGetValue<string>('Context', AContext)) and
            (Trim(AContext) <> '') then
          begin
            ARPCCache := Find(ARPC, AContext);
            if not Assigned(ARPCCache) then
            begin
              ARPCCache := TRPCCache.Create(Self, ARPC, AContext);
              Add(ARPCCache);
              InitializedContexts.Add(AContext);
            end;
            if AJSONObject.TryGetValue<Integer>('MaxSize', AMaxSize) and
              (AMaxSize >= 0) then ARPCCache.MaxSize := AMaxSize;
            if AJSONObject.TryGetValue<Int64>('MaxAge', AMaxAge) and
              (AMaxAge >= 0) then ARPCCache.MaxAge := AMaxAge;
            if AJSONObject.TryGetValue<Boolean>('IgnoreCase', AIgnoreCase) then
                ARPCCache.IgnoreCase := AIgnoreCase;
            if AJSONObject.TryGetValue<Boolean>('Enabled', AEnabled) then
                ARPCCache.Enabled := AEnabled;
          end;
        end;
      end;
    end;
    if AData.TryGetValue<Boolean>('RPCCache.Enabled', AEnabled) then
        Enabled := AEnabled;
  finally
    CriticalSection.Leave;
  end;
end;

procedure TRPCCacheList.SetOnNewContext(const Value: TNewContextEvent);
var
  ARPCCache: TRPCCache;
begin
  FOnNewContext := Value;
  InitializedContexts.Clear;
  for ARPCCache in Self do InitializedContexts.Add(ARPCCache.Context);
end;

function TRPCCacheList.CallVistA(const ARPC, AContext: string;
  const AData: array of const; AReply: TStrings; ARequireResults: Boolean;
  ACallVistaFunction: TCallVistAFunction): Boolean;
begin
  Result := CallVista(ARPC, AContext, AData, [], AReply, ARequireResults,
    ACallVistaFunction);
end;

function TRPCCacheList.CallVistA(const ARPC, AContext: string; const AData,
  AExtraData: array of const; AReply: TStrings; ARequireResults: Boolean;
  ACallVistaFunction: TCallVistAFunction): Boolean;
var
  I: Integer;
  ARPCCache: TRPCCache;
begin
  if not InitializedContexts.Find(AContext, I) then
  begin
    // order is important in here, to avoid recursion!
    InitializedContexts.Add(AContext);
    if Assigned(FOnNewContext) then FOnNewContext(Self, AContext);
  end;
  ARPCCache := Find(ARPC, AContext);
  if not Assigned(ARPCCache) then
  begin
    Result := ACallVistAFunction(ARPC, AData, AReply, ARequireResults);
  end else begin
    Result := ARPCCache.CallVistA(AData, AExtraData, AReply, ARequireResults,
      ACallVistAFunction);
  end;
end;

constructor TRPCCache.Create;
begin
  raise Exception.Create('Do not create RPCCaches directly. They are ' +
    'configured on VistA, and created through ' + 'TRPCCacheList.Initialize');
end;

constructor TRPCCache.Create(ARPCCacheList: TRPCCacheList;
  const ARPC, AContext: string);
begin
  if not Assigned(ARPCCacheList) then
      raise Exception.Create('ARPCCacheList not assigned');
  if Trim(ARPC) = '' then raise Exception.Create('ARPC not assigned');
  if Trim(AContext) = '' then raise Exception.Create('AContext not assigned');
  inherited Create;
  IgnoreCase := False;
  FRPCCacheList := ARPCCacheList;
  FRPC := ARPC;
  FContext := AContext;
  MaxAge := 3600000; // One hour MaxAge default for RPC calls
  MaxSize := 20; // Cache up to 20 calls by default
end;

function TRPCCache.CreateCacheItem(const AData: array of const)
  : TCacheItem<string>;
begin
  Result := TRPCCacheItem.Create(Self, AData);
end;

function TRPCCache.CallVistA(const AData: array of const; AReply: TStrings;
  ARequireResults: Boolean; ACallVistaFunction: TCallVistAFunction): Boolean;
begin
  Result := CallVista(AData, [], AReply, ARequireResults, ACallVistaFunction);
end;

function TRPCCache.CallVistA(const AData, AExtraData: array of const;
  AReply: TStrings; ARequireResults: Boolean;
  ACallVistaFunction: TCallVistAFunction): Boolean;
// AReply (TStrings) is stored as commatext in the cache.
// AExtraData is data NOT used in the RPC, but only for cache lookup.
// Use it to add context data that VistA uses when the RPC is made, for example
// a patient IEN that's not passed in the RPC, because VistA already knows the
// selected patient.
// Cached RPCs do not have this context!
var
  ACacheItem: TCacheItem<string>;
  AVarRecArray: TVarRecArray;
  AFindStartTime, AFindStopTime: TDateTime;
begin
  if not Assigned(AReply) then raise Exception.Create('AReply not Assigned');
  AReply.Clear;
  if Length(AExtraData) > 0 then AVarRecArray := ConcatArrays(AData, AExtraData)
  else AVarRecArray := nil;
  AFindStartTime := Now;
  if Assigned(AVarRecArray) then ACacheItem := Find(AVarRecArray)
  else ACacheItem := Find(AData);
  AFindStopTime := Now;
  if Assigned(ACacheItem) then
  begin
    LogFound(AData, AExtraData, ACacheItem, AFindStartTime, AFindStopTime);
    AReply.CommaText := ACacheItem.Reply;
    Result := True;
  end else begin
    Result := ACallVistaFunction(RPC, AData, AReply, ARequireResults);
    if Result then
    begin
      if Assigned(AVarRecArray) then
          inherited Add(AVarRecArray, AReply.CommaText)
      else inherited Add(AData, AReply.CommaText);
    end;
  end;
end;

class function TRPCCache.ConcatArrays(const [Ref] Array1,
  Array2: array of const): TVarRecArray;
// Careful with this function! The result is ONLY valid as long as the array of
// const-s remain in scope. The const [Ref] declaration is important here! If
// either Array1 or Array2 ever get passed by value the Result becomes invalid
// the moment this function completes.
var
  I: integer;
  ALengthArray1: Integer;
begin
  ALengthArray1 := Length(Array1);
  SetLength(Result, ALengthArray1 + Length(Array2));
  for I := low(Array1) to high(Array1) do Result[I] := Array1[I];
  for I := low(Array2) to high(Array2) do
      Result[ALengthArray1 + I] := Array2[I];
end;

class function TRPCCache.VarRecToStr(const V: TVarRec): string;
const
  AErrorMessage = 'Unable to represent value as a string';
var
  AORNetMult: IORNetMult;
begin
  case V.VType of
    vtInteger: Result := V.VInteger.ToString;
    vtBoolean: Result := V.VBoolean.ToString;
    vtChar: Result := string(V.VChar);
    vtExtended: Result := V.VExtended^.ToString;
    vtString: Result := string(V.VString^);
    vtPointer: Result := '$' + Integer(V.VPointer).ToString;
    vtPChar: Result := string(V.VPChar);
    vtClass: Result := V.VClass.ClassName;
    vtWideChar: Result := V.VWideChar;
    vtPWideChar: Result := (WideString(V.VPWideChar));
    vtAnsiString: Result := (WideString(V.VAnsiString));
    vtCurrency: Result := CurrToStr(V.VCurrency^);
    vtVariant: VarToStrDef(V.VVariant^, AErrorMessage);
    vtInterface:
      begin
        if IInterface(V.VInterface).QueryInterface(IORNetMult, AORNetMult) <> S_OK
        then
        begin
          Result := Integer(V.VInterface).ToString;
        end else begin
          Result := AORNetMult.SubscriptsText;
        end;
      end;
    vtWideString: Result := WideString(V.VWideString);
    vtInt64: Result := V.VInt64^.toString;
    vtUnicodeString: Result := UnicodeString(V.VUnicodeString);
    vtObject: if (V.VObject is TStrings) then
      begin
        Result := TStrings(V.VObject).Text;
      end else begin
        Result := V.VObject.ClassName + ' $' + Integer(Pointer(V.VObject)
          ).ToString;
      end;
  else Result := AErrorMessage;
  end;
end;

procedure TRPCCache.LogFound(const AData, AExtraData: array of const;
  AFoundCacheItem: TCacheItem<string>; AStartTime, ASTopTime: TDateTime);
var
  ATitle, AParams, AReply: string;
  I, J: integer;
  AStringList: TStringList;
  AORNetMult: IORNetMult;
begin
  if Assigned(AFoundCacheItem) and Assigned(FRPCCacheList.OnLog) then
  begin
    ATitle := RPC + ' Cache';
    if ATitle = '' then ATitle := ClassName + ' Cache';
    for I := low(AData) to high(AData) do
    begin
      if not((AData[I].VType = vtInterface) and
        (IInterface(AData[I].VInterface).QueryInterface(IORNetMult, AORNetMult)
        = S_OK)) then
      begin
        // in ORNet.SetParams parameters are set to Literal!
        AParams := Trim(AParams + #13#10'literal'#9 + VarRecToStr(AData[I]));
      end else begin
        // but netmults are set to list
        AStringList := TStringList.Create;
        try
          AStringList.Text := VarRecToStr(AData[I]);
          AParams := 'list';
          for J := 0 to AStringList.Count - 1 do
          begin
            if AStringList.Names[J] <> '' then
            begin
              AParams := Trim(AParams + #13#10#9'(' + AStringList.Names[J] + ')'
                + '=' + AStringList.Values[AStringList.Names[J]]);
            end else begin
              AParams := Trim(AParams + #13#10#9 + AStringList[J]);
            end;
          end;
        finally
          FreeAndNil(AStringList);
        end;
      end;
    end;
    if AParams = '' then AParams := '[no Params]';

    AStringList := TStringList.Create;
    try
      AStringList.CommaText := AFoundCacheItem.Reply;
      AReply := AStringList.Text;
    finally
      FreeAndNil(AStringList);
    end;

    if Trim(AReply) = '' then AReply := '[no Results]';

    FRPCCacheList.OnLog(ATitle + #13#10 +
      'Ran at:' + FormatDateTime('hh:nn:ss.zzz a/p'#13#10, AStartTime) +
      'Run time:' + FormatDateTime('hh:nn:ss.zzz'#13#10, AStopTime - AStartTime)
      + #13#10 +
      'Params ------------------------------------------------------------------'#13#10
      + AParams + #13#10 + #13#10 +
      'Results -----------------------------------------------------------------'#13#10
      + AReply, ATitle, AStartTime, AStopTime - AStartTime);
  end;

end;


initialization

RPCCache := TRPCCacheList.Create;

finalization

FreeAndNil(RPCCache);

end.
