You've already forked lazarus-ccr
4381e28da6
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4 8e941d3f-bd1b-0410-a28a-d453659cc2b4
319 lines
9.4 KiB
ObjectPascal
319 lines
9.4 KiB
ObjectPascal
//{$DEFINE WST_DBG}
|
|
|
|
unit wst_apache_binding;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, SysUtils,
|
|
httpd, apr, apriconv, aprutil;
|
|
|
|
const
|
|
sWST_ROOT = 'wst';
|
|
sSEPARATOR = '/';
|
|
sSERVICES_PREFIXE = 'services';
|
|
sWSDL = 'WSDL';
|
|
sHTTP_BINARY_CONTENT_TYPE = 'application/octet-stream';
|
|
sCONTENT_TYPE = 'Content-Type';
|
|
|
|
function wst_RequestHandler(r: Prequest_rec): Integer;
|
|
|
|
implementation
|
|
uses base_service_intf,
|
|
server_service_intf, server_service_imputils,
|
|
server_service_soap, server_binary_formatter,
|
|
metadata_repository, metadata_wsdl, DOM, XMLWrite,
|
|
|
|
calculator, calculator_binder, calculator_imp,
|
|
metadata_service, metadata_service_binder, metadata_service_imp;
|
|
|
|
type
|
|
TRequestInfo = record
|
|
Root : string;
|
|
URI : string;
|
|
ContentType : string;
|
|
Buffer : string;
|
|
end;
|
|
|
|
TResponseInfo = record
|
|
ContentText : string;
|
|
ContentType : string;
|
|
end;
|
|
|
|
|
|
procedure SaveStringToFile(const AStr,AFile:string;const AKeepExisting : Boolean);
|
|
begin
|
|
with TMemoryStream.Create() do try
|
|
if AKeepExisting and FileExists(AFile) then begin
|
|
LoadFromFile(AFile);
|
|
Position := Size;
|
|
end;
|
|
if ( Length(AStr) > 0 ) then
|
|
Write(AStr[1],Length(AStr));
|
|
SaveToFile(AFile);
|
|
finally
|
|
Free();
|
|
end;
|
|
end;
|
|
|
|
function ReadBuffer(r : Prequest_rec; out rbuf : string ) : Integer;
|
|
var
|
|
argsbuffer : string;
|
|
rsize, len_read, rpos : Integer;
|
|
loc_length : Integer;
|
|
begin
|
|
rbuf := '';
|
|
Result := ap_setup_client_block(r, REQUEST_CHUNKED_ERROR);
|
|
if ( Result <> OK ) then
|
|
Exit;
|
|
|
|
if ( ap_should_client_block(r) <> 0 ) then begin
|
|
SetLength(argsbuffer,HUGE_STRING_LEN);
|
|
FillChar(argsbuffer[1],Length(argsbuffer),0);
|
|
rsize := 0; len_read := 0; rpos := 0;
|
|
loc_length := r^.remaining;
|
|
SetLength(rbuf, loc_length );
|
|
|
|
while True do begin
|
|
len_read := ap_get_client_block(r, @(argsbuffer[1]), Length(argsbuffer));
|
|
if ( len_read <= 0 ) then
|
|
Exit;
|
|
if ( ( rpos + len_read ) > loc_length ) then
|
|
rsize := loc_length - rpos
|
|
else
|
|
rsize := len_read;
|
|
Move(argsbuffer[1],rbuf[ ( 1 + rpos ) ], rsize);
|
|
Inc(rpos,rsize);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ExtractNextPathElement(var AFullPath : string):string;
|
|
var
|
|
i : SizeInt;
|
|
begin
|
|
Result := '';
|
|
if ( Length(AFullPath) > 0 ) then begin
|
|
while ( Length(AFullPath) > 0 ) and ( AFullPath[1] = sSEPARATOR ) do begin
|
|
Delete(AFullPath,1,1);
|
|
end;
|
|
i := Pos(sSEPARATOR,AFullPath);
|
|
if ( i < 1 ) then begin
|
|
Result := AFullPath;
|
|
AFullPath := '';
|
|
end else begin
|
|
Result := Copy(AFullPath,1,Pred(i));
|
|
Delete(AFullPath,1,i);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function GetWSDL(const ARepName, ARootAddress: shortstring):string;
|
|
var
|
|
strm : TMemoryStream;
|
|
rep : PServiceRepository;
|
|
doc :TXMLDocument;
|
|
i : SizeInt;
|
|
s : string;
|
|
begin
|
|
Result := '';
|
|
rep := nil;
|
|
doc := Nil;
|
|
i := GetModuleMetadataMngr().IndexOfName(ARepName);
|
|
if ( i < 0 ) then
|
|
Exit;
|
|
strm := TMemoryStream.Create();
|
|
try
|
|
s := GetModuleMetadataMngr().GetRepositoryName(i);
|
|
GetModuleMetadataMngr().LoadRepositoryName(s,ARootAddress,rep);
|
|
strm.Clear();
|
|
doc := TXMLDocument.Create();
|
|
GenerateWSDL(rep,doc);
|
|
WriteXMLFile(doc,strm);
|
|
i := strm.Size;
|
|
if ( i > 0 ) then begin
|
|
SetLength(Result,i);
|
|
Move(strm.memory^,Result[1],i);
|
|
end;
|
|
finally
|
|
doc.Free();
|
|
strm.Free();
|
|
GetModuleMetadataMngr().ClearRepository(rep);
|
|
end;
|
|
end;
|
|
|
|
function GenerateWSDLTable(): string;
|
|
var
|
|
r : IModuleMetadataMngr;
|
|
i : Integer;
|
|
begin
|
|
r := GetModuleMetadataMngr();
|
|
Result := '<html>' +
|
|
'<head>'+
|
|
'<title>'+
|
|
'The Web Service Toolkit generated Metadata table'+
|
|
'</title>'+
|
|
'<body>' +
|
|
'<p BGCOLOR="#DDEEFF"><FONT FACE="Arial" COLOR="#0000A0" SIZE="+2">The following repositories has available. Click on the link to view the corresponding WSDL.</FONT></p>'+
|
|
'<table width="100%">';
|
|
|
|
for i := 0 to Pred(r.GetCount()) do
|
|
Result := Result + '<tr>' +
|
|
'<td>' +
|
|
Format('<a href="%s">',[sSEPARATOR+sWST_ROOT+sSEPARATOR+sSERVICES_PREFIXE+sSEPARATOR+sWSDL+sSEPARATOR+r.GetRepositoryName(i)])+
|
|
r.GetRepositoryName(i) +
|
|
'</a>'+
|
|
'</td>' +
|
|
'</tr>';
|
|
|
|
Result := Result +
|
|
'</tr>'+
|
|
'</table>'+
|
|
'</body>'+
|
|
'</head>'+
|
|
'</html>';
|
|
end;
|
|
|
|
procedure ProcessWSDLRequest(
|
|
const ARequestInfo : TRequestInfo;
|
|
out AResponseInfo : TResponseInfo
|
|
);
|
|
var
|
|
locRepName, strBuff, locPath : string;
|
|
i : Integer;
|
|
begin
|
|
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
|
|
locPath := ARequestInfo.URI;
|
|
locRepName := ExtractNextPathElement(locPath);
|
|
if AnsiSameText(sWSDL,locRepName) then
|
|
locRepName := ExtractNextPathElement(locPath);
|
|
strBuff := GetWSDL(locRepName,ARequestInfo.Root);
|
|
i := Length(strBuff);
|
|
if ( i > 0 ) then begin
|
|
AResponseInfo.ContentType := 'text/xml';
|
|
AResponseInfo.ContentText := strBuff;
|
|
Exit;
|
|
end;
|
|
AResponseInfo.ContentText := GenerateWSDLTable();
|
|
AResponseInfo.ContentType := 'text/html';
|
|
end;
|
|
|
|
function ProcessServiceRequest(
|
|
const ARequestInfo : TRequestInfo;
|
|
out AResponseInfo : TResponseInfo
|
|
):Boolean;
|
|
var
|
|
trgt,ctntyp, loc_path : string;
|
|
rqst : IRequestBuffer;
|
|
inStream, outStream: TMemoryStream;
|
|
i : Integer;
|
|
begin
|
|
FillChar(AResponseInfo,SizeOf(TResponseInfo),#0);
|
|
loc_path := ARequestInfo.URI;
|
|
trgt := ExtractNextPathElement(loc_path);
|
|
Result := False;
|
|
if AnsiSameText(sWSDL,trgt) then
|
|
Exit;
|
|
Result := True;
|
|
inStream := nil;
|
|
outStream := nil;
|
|
try
|
|
inStream := TMemoryStream.Create();
|
|
outStream := TMemoryStream.Create();
|
|
|
|
ctntyp := ARequestInfo.ContentType;
|
|
i := Length(ARequestInfo.Buffer);
|
|
if ( i > 0 ) then
|
|
inStream.Write(ARequestInfo.Buffer[1],i);
|
|
inStream.Position := 0;
|
|
if AnsiSameText(sBINARY_CONTENT_TYPE,ctntyp) then
|
|
AResponseInfo.ContentType := sHTTP_BINARY_CONTENT_TYPE
|
|
else
|
|
AResponseInfo.ContentType := ctntyp;
|
|
rqst := TRequestBuffer.Create(trgt,ctntyp,inStream,outStream);
|
|
HandleServiceRequest(rqst);
|
|
i := outStream.Size;
|
|
if ( i > 0 ) then begin
|
|
SetLength(AResponseInfo.ContentText,i);
|
|
Move(outStream.Memory^,AResponseInfo.ContentText[1],i);
|
|
end;
|
|
finally
|
|
outStream.Free();
|
|
inStream.Free();
|
|
{$IFDEF WST_DBG}
|
|
{SaveStringToFile('RequestInfo.ContentType=' + ARequestInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',False);
|
|
SaveStringToFile('RequestInfo.Buffer=' + ARequestInfo.Buffer + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
|
|
SaveStringToFile('RequestInfo.URI=' + ARequestInfo.URI + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
|
|
SaveStringToFile('ResponseInfo.ContentType=' + AResponseInfo.ContentType + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
|
|
SaveStringToFile('ResponseInfo.ContentText=' + AResponseInfo.ContentText + LineEnding,'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log',True);
|
|
}
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
function wst_RequestHandler(r: Prequest_rec): Integer;
|
|
|
|
function FillRequestInfo(var ARequestInfo : TRequestInfo):Integer;
|
|
begin
|
|
ARequestInfo.ContentType := apr_table_get(r^.headers_in,sCONTENT_TYPE);
|
|
ARequestInfo.Root := ap_get_server_name(r) + sSEPARATOR + sWST_ROOT + sSEPARATOR;
|
|
ARequestInfo.URI := r^.uri;
|
|
Result := ReadBuffer(r,ARequestInfo.Buffer);
|
|
end;
|
|
|
|
var
|
|
sInputBuffer : string;
|
|
iRet, iLen : Integer;
|
|
loc_RequestInfo : TRequestInfo;
|
|
loc_ResponseInfo : TResponseInfo;
|
|
begin
|
|
Result := FillRequestInfo(loc_RequestInfo);
|
|
if not AnsiSameText(sWST_ROOT,ExtractNextPathElement(loc_RequestInfo.URI)) then
|
|
Result := DECLINED;
|
|
if ( Result <> OK ) then
|
|
Exit;
|
|
|
|
try
|
|
if AnsiSameText(sSERVICES_PREFIXE,ExtractNextPathElement(loc_RequestInfo.URI)) then begin
|
|
if not ProcessServiceRequest(loc_RequestInfo,loc_ResponseInfo) then
|
|
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
|
|
end else begin
|
|
ProcessWSDLRequest(loc_RequestInfo,loc_ResponseInfo);
|
|
end;
|
|
|
|
ap_set_content_type(r, PCHAR(loc_ResponseInfo.ContentType));
|
|
if AnsiSameText(sHTTP_BINARY_CONTENT_TYPE,loc_ResponseInfo.ContentType) then begin
|
|
ap_set_content_length(r,Length(loc_ResponseInfo.ContentText));
|
|
ap_rwrite(@(loc_ResponseInfo.ContentText[1]),Length(loc_ResponseInfo.ContentText),r);
|
|
ap_rflush(r);
|
|
end else begin
|
|
ap_rputs(PCHAR(loc_ResponseInfo.ContentText), r);
|
|
end;
|
|
Result := OK;
|
|
Exit;
|
|
except
|
|
on e : Exception do begin
|
|
ap_set_content_type(r, 'text/html');
|
|
ap_rputs('<HTML><HEAD> <TITLE>Error</TITLE></HEAD>' + LineEnding, r);
|
|
ap_rputs('<BODY></BODY></HTML>',r);
|
|
ap_rprintf(r, '<BODY><H1>"%s"</H1></BODY></HTML>' + LineEnding, [PCHAR(e.Message)]);
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
initialization
|
|
RegisterStdTypes();
|
|
Server_service_RegisterBinaryFormat();
|
|
Server_service_RegisterSoapFormat();
|
|
|
|
RegisterCalculatorImplementationFactory();
|
|
Server_service_RegisterCalculatorService();
|
|
|
|
Server_service_RegisterWSTMetadataServiceService();
|
|
RegisterWSTMetadataServiceImplementationFactory();
|
|
|
|
end.
|