2007-06-28 23:33:38 +00:00
{$DEFINE WST_DBG}
2007-05-05 19:05:01 +00:00
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,
user_service_intf, user_service_intf_binder, user_service_intf_imp,
metadata_service, metadata_service_binder, metadata_service_imp;
type
TRequestInfo = record
Root : string ;
URI : string ;
ContentType : string ;
Buffer : string ;
2007-06-28 23:33:38 +00:00
Argument : string ;
2007-05-05 19:05:01 +00:00
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;
2007-06-28 23:33:38 +00:00
rqst : = TRequestBuffer. Create( trgt, ctntyp, inStream, outStream, '' ) ;
2007-05-05 19:05:01 +00:00
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}
2007-06-28 23:33:38 +00:00
SaveStringToFile( 'RequestInfo.ContentType=' + ARequestInfo. Argument + LineEnding, 'c:\log.log' , False ) ;
{ SaveStringToFile( 'RequestInfo.Buffer=' + ARequestInfo. Buffer + LineEnding, 'E:\Inoussa\Sources\lazarus\wst\v0.3\tests\apache_module\log.log' , True ) ;
2007-05-05 19:05:01 +00:00
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;
2007-06-28 23:33:38 +00:00
ARequestInfo. Argument : = r^ . args;
2007-05-05 19:05:01 +00:00
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( ) ;
RegisterUserServiceImplementationFactory( ) ;
Server_service_RegisterUserServiceService( ) ;
RegisterWSTMetadataServiceImplementationFactory( ) ;
2007-06-28 23:33:38 +00:00
Server_service_RegisterWSTMetadataServiceService( ) ;
2007-05-05 19:05:01 +00:00
end .
