xmlworksrpc.pas

delphi的XMPRPC通讯例子

unit XMLWorksRPC;

interface
uses
    XMLWorks2 // Base XMLObject
  , SysUtils // Exceptions, etc.
  , IdTCPServer // PeerThread
  , IdHTTPServer // HTTP Server
  , IdCustomHTTPServer // Required for OnGet handler
  , IdHTTP // HTTP Client
;

type
  EXMLRPCException = class (Exception)
  end;
  
  TRPCType = (rpcString, rpcInt, rpcBoolean, rpcDouble, rpcDateTime, rpcBase64, rpcStruct, rpcArray);
const
  gstr_RPCStringType = 'string';
  gstr_RPCIntegerType = 'int';
  gstr_RPCIntegerType2 = 'i4';
  gstr_RPCBooleanType = 'boolean';
  gstr_RPCDoubleType = 'double';
  gstr_RPCDateTimeType = 'dateTime.iso8601';
  gstr_RPCBase64Type = 'base64';

  gstr_RPCStructType = 'struct';
  gstr_RPCStructMember = 'member';
  gstr_RPCArrayType = 'array';

  RPCTypes : array[TRPCType] of string = (gstr_RPCStringType, gstr_RPCIntegerType, gstr_RPCBooleanType, gstr_RPCDoubleType, gstr_RPCDateTimeType, gstr_RPCBase64Type, gstr_RPCStructType, gstr_RPCArrayType);

type
  TXMLRPCStructMember = class (TXMLCollectionItem)
  private
    fName: XMLString;
    fValue: XMLString;
  protected
    function GetAsBase64: string;
    function GetAsBoolean: Boolean;
    function GetAsDateTime: TDateTime;
    function GetAsDouble: Double;
    function GetAsInteger: Integer;
    function GetAsString: string;
    function getType: TRPCType;
    procedure SetAsBase64(const Value: string);
    procedure SetAsBoolean(Value: Boolean);
    procedure SetAsDateTime(Value: TDateTime);
    procedure SetAsDouble(Value: Double);
    procedure SetAsInteger(Value: Integer);
    procedure SetAsString(const Value: string);
  public
    class function getTagName: string; override;
    property AsBase64: string read GetAsBase64 write SetAsBase64;
    property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
    property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
    property AsDouble: Double read GetAsDouble write SetAsDouble;
    property AsInteger: Integer read GetAsInteger write SetAsInteger;
    property AsString: string read GetAsString write SetAsString;
  published
    property name: XMLString read fName write fName;
    property value: XMLString read fValue write fValue;
  end;
  
  TXMLRPCStruct = class (TXMLCollection)
  public
    constructor Create(const value: string = ''); reintroduce;
    function AddBase64(const value: string): TXMLRPCStructMember;
    function AddBoolean(const value: boolean): TXMLRPCStructMember;
    function AddDateTime(const value: TDateTime): TXMLRPCStructMember;
    function AddDouble(const value: double): TXMLRPCStructMember;
    function AddInteger(const value: integer): TXMLRPCStructMember;
    function AddString(const value: string): TXMLRPCStructMember;
    class function getTagName: string; override;
  end;
  
  TXMLRPCParam = class (TXMLList)
  public
    function AddBase64(const value: string): Integer;
    function AddBoolean(const value: boolean): Integer;
    function AddDateTime(const value: TDateTime): Integer;
    function AddDouble(const value: double): Integer;
    function AddInteger(const value: integer): Integer;
    function AddString(const value: string): Integer;
    function getBase64(const Index: integer): string;
    function getBoolean(const Index: integer): Boolean;
    function getDateTime(const Index: integer): TDateTime;
    function getDouble(const Index: integer): Double;
    function getInteger(const Index: integer): Integer;
    function getString(const Index: integer): string;
    function getType(Index: integer): TRPCType;
  end;
  
  TXMLRPCParams = class (TXMLObject)
  private
    fParam: TXMLRPCParam;
  public
    constructor Create(p_sXML: String = ''); override;
  published
    property param: TXMLRPCParam read fParam write fParam;
  end;
  
  TXMLRPCArray = class (TXMLObject)
  private
    fData: TXMLRPCParam;
  public
    constructor Create(p_sXML: String = ''); override;
    class function getTagName: string; override;
  published
    property data: TXMLRPCParam read fData write fData;
  end;
  

  TXMLRPCMethodCall = class (TXMLObject)
  private
    fMethodName: string;
    fParams: TXMLRPCParams;
    fURL: string;
    fUser_Agent: string;
  public
    constructor Create(p_sXML: String = ''); override;
    class function getTagName: string; override;
    property URL: string read fURL write fURL;
    property User_Agent: string read fUser_Agent write fUser_Agent;
  published
    property methodName: string read fMethodName write fMethodName;
    property params: TXMLRPCParams read fParams write fParams;
  end;
  
  TXMLRPCMethodResponseBase = class (TXMLObject)
  private
    fFault: TXMLRPCStruct;
    fParams: TXMLRPCParams;
  public
    ResponseXML: string;
    constructor Create(p_sXML: string = ''); override;
    class function getTagName: string; override;
    function IsFault: Boolean;
    procedure ProcessRequest(p_Request: TXMLRPCMethodCall);
    property fault: TXMLRPCStruct read fFault write fFault;
    property params: TXMLRPCParams read fParams write fParams;
  end;
  
  TXMLRPCMethodResponseParams = class (TXMLRPCMethodResponseBase)
  published
    property params;
  end;
  
  TXMLRPCMethodResponseFault = class (TXMLRPCMethodResponseBase)
  published
    property fault;
  end;
  
  TXMLRPCMethodResponse = class (TXMLRPCMethodResponseBase)
  published
    property fault;
    property params;
  end;
  
  TXMLRequest = class (TXMLRPCMethodCall)
  private
    fClient: string;
    FPassword: string;
    fPort: Integer;
    fRequestTime: TDateTime;
    fServer: string;
    FUserName: string;
  published
    property Client: string read fClient write fClient;
    property Password: string read FPassword write FPassword;
    property Port: Integer read fPort write fPort;
    property RequestTime: TDateTime read fRequestTime write fRequestTime;
    property Server: string read fServer write fServer;
    property UserName: string read FUserName write FUserName;
  end;
  
  TXMLRPCRequestEvent = procedure (AThread: TIdPeerThread; const RemoteIP: 
          String; const RequestInfo: String; var ResponseInfo: String) of 
          object;


  TXMLRPCServer = class (TObject)
  private
    fOnRequest: TXMLRPCRequestEvent;
    f_OnConnect: TIdServerThreadEvent;
    f_OnDisconnect: TIdServerThreadEvent;
    f_OnException: TIdServerThreadExceptionEvent;
    Server: TIdHTTPServer;
  protected
    function GetActive: Boolean;
    function GetActiveConnections: Integer;
    procedure ServerCommandGet(AThread: TIdPeerThread; RequestInfo: 
            TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
    procedure SetActive(const Value: Boolean);
    procedure UpdateBindings(p_iPort: Integer);
  public
    constructor Create(const p_iPort: Integer);
    destructor Destroy; override;
    procedure DoConnect(AThread: TIdPeerThread);
    procedure DoDisconnect(AThread: TIdPeerThread);
    procedure DoException(AThread: TIdPeerThread; AException: Exception);
    property Active: Boolean read GetActive write SetActive;
    property ActiveConnections: Integer read GetActiveConnections;
  published
    property OnConnect: TIdServerThreadEvent read f_OnConnect write f_OnConnect;
    property OnDisconnect: TIdServerThreadEvent read f_OnDisconnect write 
            f_OnDisconnect;
    property OnException: TIdServerThreadExceptionEvent read f_OnException 
            write f_OnException;
    property OnRequest: TXMLRPCRequestEvent read fOnRequest write fOnRequest;
  end;
  


implementation
uses
    IdCoder3To4 // Base64
  , Classes // Streams
  , IdSocketHandle  // This is where the IdSocketHandle class is defined.
  , FastStrings // for HighSpeed String Parsing
;


{ TODO : Indy changed this in 8.1 -> change to use new versions }
function Base64Encode(const s: string): string;
begin
  Result:=s;
end;


function Base64Decode(const s: string): string;
begin
  Result:=s;
end;


function ISODateTimeToStr(const value: TDateTime): string;
begin
  result := FormatDateTime('yyyymmdd''T''hh:mm:ss', value);
end;

function ISOStrToDateTime(const value: string): TDateTime;
const
//  12345678901234567
//  yyyymmddThh:mm:ss
  YearStart = 1;
  YearCt = 4;
  MonthStart = 5;
  MonthCt = 2;
  DayStart = 7;
  DayCt = 2;
  HourStart = 10;
  HourCt = 2;
  MinuteStart = 13;
  MinuteCt = 2;
  SecondStart = 16;
  SecondCt = 2;
begin
  if Length(Value) <> (SecondStart+SecondCt-1) then
    raise Exception.Create('Invalid DateTime.iso8601 string format (' + value + ')');

  result := EncodeDate(StrToInt(Copy(value, YearStart, YearCt)),
                       StrToInt(Copy(value, MonthStart, MonthCt)),
                       StrToInt(Copy(value, DayStart, DayCt))) +
            EncodeTime(StrToInt(Copy(value, HourStart, HourCt)),
                       StrToInt(Copy(value, MinuteStart, MinuteCt)),
                       StrToInt(Copy(value, SecondStart, SecondCt)), 0);
end;

function StrToRPCType(const value: string): TRPCType;
begin
  if value = '' then
  begin
    result := rpcString;
    exit;
  end;

  for result := low(TRPCType) to high(TRPCType) do    // Iterate
    if AnsiSameText(value, RPCTypes[result]) then
      exit;

  if AnsiSameText(value, gstr_RPCIntegerType2) then
  begin
    result := rpcInt;
    exit;
  end;

  raise EXMLRPCException.Create('Invalid RPC Type (' + value + ')');
end;

function getRPCType(const value: string): TRPCType;
var
  CurrentTag: string;
  CurrentIndex: integer;
begin
  CurrentIndex := 1;
  CurrentTag := FastParseTag(value, '<' , '>', CurrentIndex);
  result := StrToRPCType(CurrentTag);
end;


function getRPCValue(const value: string; const RPCType: TRPCType): string;
var
  CurrentTag: string;
  CurrentIndex: integer;
begin
  CurrentIndex := 1;

  CurrentTag := FastParseTag(value, '<' , '>', CurrentIndex);
  CurrentIndex := 1;
  if StrToRPCType(CurrentTag) <> RPCType then
    raise EXMLRPCException.Create('RPC Type Mismatch (RPCType:"' + RPCTypes[RPCType] +'"; Actual:"' + CurrentTag + '")');

  if CurrentTag = '' then
    // CurrentTag can be empty if it is a string type, return the whole string as the "value"
    result := value
  else
    result := FastParseTagXML(value, CurrentTag, CurrentIndex);
end;

function StrToRPCBoolean(const value: boolean): string;
begin
  if value then
    result := '<' + gstr_RPCBooleanType + '>1</' + gstr_RPCBooleanType + '>'
  else
    result := '<' + gstr_RPCBooleanType + '>0</' + gstr_RPCBooleanType + '>';
end;

function StrToRPCBase64(const value: string): string;
begin
  result := '<' + gstr_RPCBase64Type + '>' + Base64Encode(value) + '</' + gstr_RPCBase64Type + '>';
end;

function StrToRPCDateTime(const value: TDateTime): string;
begin
  result := '<' + gstr_RPCDateTimeType + '>' + ISODateTimeToStr(value) + '</' + gstr_RPCDateTimeType + '>';
end;

function StrToRPCDouble(const value: double): string;
begin
  result := '<' + gstr_RPCDoubleType + '>' + FloatToStr(value) + '</' + gstr_RPCDoubleType + '>';
end;

function StrToRPCInteger(const value: integer): string;
begin
  result := '<' + gstr_RPCIntegerType + '>' + IntToStr(value) + '</' + gstr_RPCIntegerType + '>';
end;

function StrToRPCString(const value: string): string;
begin
  result := '<' + gstr_RPCStringType + '>' + value + '</' + gstr_RPCStringType + '>';
end;

function RPCValueToString(const value: string): string;
begin
  result := getRPCValue(value, rpcString);
end;

function RPCValueToBase64(const value: string): string;
begin
  result := Base64Decode(getRPCValue(value, rpcBase64));
end;

function RPCValueToBoolean(const value: string): boolean;
begin
  result := getRPCValue(value, rpcBoolean) = '1';
end;

function RPCValueToDateTime(const value: string): TDateTime;
begin
  result := ISOStrToDateTime(getRPCValue(value, rpcDateTime));
end;

function RPCValueToDouble(const value: string): double;
begin
  result := StrToFloat(getRPCValue(value, rpcDouble));
end;