mysockhttpisapi.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

// *****************************************************************************
//                          ISAPI UNIT 0.1
// Created By Carlo Kok                   http://cajsoft.cjb.net/
//
// Bugreport: [e-mail]
// *****************************************************************************
// Unit for loading ISAPI DLL files, does not look nice, but it should work.
//
// Registering:
// Please register when you like mysock. You can register by sending an
// email with you name, companyname, country and what you think of mysock.
// To [e-mail]. Registered will cost you nothing.
//
// Copyright (C) 1999 by Carlo Kok ([e-mail])
//
// This software is provided 'as-is', without any express or implied
// warranty. In no event will the author be held liable for any damages
// arising from the use of this software.
//
// Permission is granted to anyone to use this software for any purpose,
// including commercial applications, and to alter it and redistribute
// it freely, subject to the following restrictions:
//
// 1. The origin of this software must not be misrepresented, you must
// not claim that you wrote the original software. If you use this
// software in a product, an acknowledgment in the product
// documentation would be appreciated but is not required.
//
// 2. Altered source versions must be plainly marked as such, and
// must not be misrepresented as being the original software.
//
// 3. This notice and the copyright string may not be removed
// or altered from any source distribution.
{
Version 0.1a
- Created unit
Version 0.1b
- Removed bugs
}
unit MySockHttpIsapi;

interface
Uses
  Windows, Isapi, MySock, MySockHttp, Classes, Sysutils;

Const
  Copyright : STring = 'TSock 2.0a Copyright (C) 1999 by Carlo Kok ([e-mail]) http://cajsoft.cjb.net';

Procedure DoIsapi(Fn, ScriptPath, ScriptParams : String;Head : THttpHead; Client : TClientSockServ);
{
Fn should be the real filename of the dll.
ScriptPath should be the path + filename of the url.
ScriptParams should be the parameters of the url.
Head should be the header.
Client should be the client.

Example:
  Client calls url: http://myserver/isapidir/isapi.dll/path1?params
  ScriptPath is "/isapidir/isapi.dll"
  ScriptParams is "/path1?params"
}
implementation



type
  PIsapiWork = ^TisapiWork;
  TIsapiWork = record
    id : Longint;
    Headers : THttpHead;
    Client : TClientSockServ;
    Trans : String;
    FileName : String;
    ScriptName : String;
    Path : String;
    Query : String;
    Rest : String;
  end;
const
  workid = $350F9C43;
  HSE_VERSION_DWORD = HSE_VERSION_MAJOR * $10000 + HSE_VERSION_MINOR;

Var
  WorkList : TStringList;
  FUpdating : Boolean = false;

Function GetServerVariable ( hConn: HCONN;
                             VariableName: PChar;
                             Buffer: Pointer;
                             var Size: DWORD ): BOOL stdcall;
var
  x : TIsapiWork;
  tmp, RequestVar : String;
begin
  x:=PIsapiWork(Pointer(HConn))^;
  if x.id<>workid then begin result:=false;exit;end;
  RequestVar := string(VariableName);
  Result := True;

  Size := 0;
  if RequestVar = 'CONTENT_LENGTH' then
  begin
    StrPCopy(Buffer, x.Headers.Content_Length);
    Size := Length(x.Headers.Content_Length);
  end
  else if RequestVar = 'CONTENT_TYPE' then
  begin
    StrPCopy(Buffer, x.Headers.Content_Type);
    Size := Length(x.Headers.Content_Type);
  end
  else if RequestVar = 'GATEWAY_INTERFACE' then
  begin
    StrPCopy(Buffer, PChar('ISAPI'));
    Size := Length('ISAPI');
  end
  else if RequestVar = 'PATH_INFO' then
  begin
    StrPCopy(Buffer, x.Path);
    Size := Length(x.Path);
  end
  else if RequestVar = 'PATH_TRANSLATED' then
  begin
    StrPCopy(Buffer, x.trans);
    Size := Length(x.trans);
  end
  else
  if RequestVar = 'QUERY_STRING' then
  begin
    StrPCopy(Buffer, x.query);
    Size := Length(x.query);
  end
  else
  if RequestVar = 'REMOTE_ADDR' then
  begin
    StrPCopy(Buffer, x.Client.RemoteHost);
    Size := Length(x.Client.RemoteHost);
  end
  else if RequestVar = 'REMOTE_HOST' then
  begin
    StrPCopy(Buffer, x.Client.RemoteHost);
    Size := Length(x.Client.RemoteHost);
  end
  else if RequestVar = 'REMOTE_IDENT' then
  begin
    StrPCopy(Buffer, '');
    Size := 0;
  end
  else if RequestVar = 'REQUEST_METHOD' then
  begin
    StrPCopy(Buffer, x.Headers.Method);
    Size := Length(x.Headers.Method);
  end
  else if RequestVar = 'SCRIPT_NAME' then
  begin
    StrPCopy(Buffer, x.scriptname);
    Size := Length(x.scriptname);
  end
  else if RequestVar = 'SERVER_NAME' then
  begin
    StrPCopy(Buffer, x.Client.HostName);
    Size := Length(x.Client.HostName);
  end
  else if RequestVar = 'SERVER_PORT' then
  begin
    StrPCopy(Buffer, x.Client.PortName);
    Size := Length(tmp);
  end
  else
  if RequestVar = 'SERVER_PROTOCOL' then
  begin
    StrPCopy(Buffer, 'HTTP/1.0');
    Size := Length('HTTP/1.0');
  end
  else
  if RequestVar = 'HTTP_USER_AGENT' then
  begin
    StrPCopy(Buffer, x.Headers.User_Agent);
    Size := Length(x.Headers.User_Agent);
  end
  else if RequestVar = 'HTTP_COOKIE' then
  begin
    StrPCopy(Buffer, x.Headers.GetOtherVal('COOKIE'));
    Size := Length(x.Headers.GetOtherVal('COOKIE'));
  end
  else if RequestVar = 'HTTP_REFERER' then
  begin
    StrPCopy(Buffer, x.headers.Referer);
    Size := Length(x.headers.Referer);
  end
  else if RequestVar = 'REMOTE_USER' then
  begin
    StrPCopy(Buffer, x.headers.Auth_Username);
    Size := Length(x.headers.Auth_Username);
  end
  else if RequestVar = 'AUTH_TYPE' then
  begin
    StrPCopy(Buffer, x.headers.Auth_Type);
    Size := Length(x.headers.Auth_Type);
  end
  else if RequestVar = 'AUTH_PASS' then
  begin
    StrPCopy(Buffer, x.headers.Auth_Password);
    Size := Length(x.headers.Auth_Password);
  end
  else
    Result := False;
end;

function WriteClient( ConnID: HCONN;
                      Buffer: Pointer;
                      var Bytes: DWORD;
                      dwReserved: DWORD ): BOOL stdcall;
var
  x : TIsapiWork;
  s : string;
begin
  x:=PIsapiWork(Pointer(ConnId))^;
  if x.id<>workid then begin result:=false;exit;end;
  try
    setstring(s, pchar(buffer), bytes);
    x.Client.Send(s);
    result:=true;
  except
    result:=false;
  end;
end;

function ReadClient( ConnID: HCONN;
                     Buffer : Pointer;
                     var Size: DWORD ): BOOL stdcall;
begin
  result:=false;
end;

function ServerSupportFunction ( hConn: HCONN;
                                 HSERRequest: DWORD;
                                 Buffer: Pointer;
                                 var Size: DWORD;
                                 var DataType: DWORD ): BOOL stdcall;
var
  x : TIsapiWork;
begin
  x:=PIsapiWork(Pointer(hConn))^;
  if x.id<>workid then begin result:=false;exit;end;
  Result := true;
  if HSERRequest = HSE_REQ_SEND_URL_REDIRECT_RESP then begin
    try
      SendRedirect(x.Client,string(buffer));
    except
      Result := False;
    end;
  end
  else
  if HSERRequest = HSE_REQ_SEND_URL then begin
    try
      SendRedirect(x.Client,string(buffer));
    except
      Result := False;
    end;
  end
  else
    result:=false;
end;


function LoadDll(s : string) : Integer;
begin
  while FUpdating do;
  if Worklist.IndexOf(uppercase(s))=-1 then begin
    FUpdating:=True;
    sleep(10);
    result:=loadlibrary(pchar(s));
    if result<>0 then
    Worklist.AddObject(s, Pointer(result));
    FUpdating:=false;
  end else
    result:=integer(Worklist.objects[Worklist.Indexof(Uppercase(s))]);
end;

procedure LoadIsapi(var work : TIsapiWork);
var
  ecb : TEXTENSION_CONTROL_BLOCK;
  s1, s2, s3, s4, s5 : string;
  Ver : THSE_VERSION_INFO;
  GetExtensionVersionProc : function ( var Ver: THSE_VERSION_INFO ): BOOL; stdcall;
  httpExtensionProc : function ( var ECB: TEXTENSION_CONTROL_BLOCK ): DWORD; stdcall;
  i : Integer;
begin
  s1:=work.headers.Method+#0;
  s2:=work.Query+#0;
  s4:=#0;
  if work.path='' then
    s3:=#0
  else
    s3:='/'+work.Path+#0;
  s4:=Work.Trans+#0;
  s5:=work.headers.Content_Type+#0;

  ecb.cbSize:=sizeof(ecb);
  ecb.dwVersion:=HSE_VERSION_DWORD;
  ecb.ConnID:=Integer(@Work);
  ecb.dwHttpStatusCode:=200;
  ecb.lpszMethod:=@s1[1];
  ecb.lpszQueryString:=@s2[1];
  ecb.lpszPathInfo:=@s3[1];
  ecb.lpszPathTranslated:=@s4[1];
  ecb.cbTotalBytes:=StrToIntdef(work.Headers.Content_Length, 0);
  ecb.cbAvailable:=length(work.rest);
  ecb.lpbData:=@work.rest[1];
  ecb.lpszContentType:=@s5[1];
  ecb.GetServerVariable:=GetServerVariable;
  ecb.WriteClient:=Writeclient;
  ecb.ReadClient:=readClient;
  ecb.ServerSupportFunction:=ServerSupportFunction;
  i:=LoadDll(work.filename);
  if i=0 then begin
    work.Client.Send(
    'HTTP/1.0 500 Internal Server Error'#13#10+
    'Content-Type: text/html'#13#10#13#10+
    '<h1>500 Internal Server Error</h1>The server could not respond to your request.');
    exit;
  end;
  GetExtensionVersionProc := GetProcAddress(i, 'GetExtensionVersion');
  HttpExtensionProc := GetProcAddress(i, 'HttpExtensionProc');
  if assigned(GetExtensionVersionProc) then begin
    if not GetExtensionVersionProc(ver) then begin
      work.Client.Send(
      'HTTP/1.0 500 Internal Server Error'#13#10+
      'Content-Type: text/html'#13#10#13#10+
      '<h1>500 Internal Server Error</h1>The server could not respond to your request.');
      exit;
    end;
  end;
  if not assigned(HttpExtensionProc) then begin
    work.Client.Send(
    'HTTP/1.0 500 Internal Server Error'#13#10+
    'Content-Type: text/html'#13#10#13#10+
    '<h1>500 Internal Server Error</h1>The server could not respond to your request.');
    exit;
  end;
  case HttpExtensionProc(ecb) of
    HSE_STATUS_SUCCESS,
    HSE_STATUS_SUCCESS_AND_KEEP_CONN: exit;
  else
    begin
      work.Client.Send(
      'HTTP/1.0 500 Internal Server Error'#13#10+
      'Content-Type: text/html'#13#10#13#10+
      '<h1>500 Internal Server Error</h1>The server could not respond to your request.');
      exit;
    end;
  end;
end;

procedure StopList;
var
  Tp : function (flags : dword) : Boolean; stdcall;
begin
  while worklist.count>0 do begin
    tp:=GetProcAddress(Integer(WorkList[worklist.count-1]), 'TerminateExtension');
    if assigned(tp) then
    tp(2);
    Worklist.Delete(Worklist.count-1);
    Freelibrary(Integer(WorkList[worklist.count-1]));
  end;
  Worklist.free;
end;

Procedure DoIsapi(Fn, ScriptPath, ScriptParams : String;Head : THttpHead; Client : TClientSockServ);
var
  w : TIsapiWork;
  Function ExtractFilePath2(S: String): string;
  begin
    while pos('/', s)>0 do begin
      delete(s, 1, pos('/', s));
    end;
    result:=s;
  end;
begin
  with w do begin
    id:=workid;
    Headers:=head;
    Client:=Client;
    FileName:=Fn;
    Trans:=ScriptPath;
    Rest:=Head.PostData;
    ScriptName:=ExtractFilePath2(trans);
    if pos('?', scriptparams)=0 then begin
      Query:='';
      Path:=ScriptParams;
    end else begin
      Path:=copy(scriptparams, 1, pos('?', scriptparams)-1);
      delete(scriptparams, 1, pos('?', scriptparams));
      Query:=scriptparams;
    end;
    LoadIsapi(w);
  end;
end;

initialization
  WorkList:=TStringList.Create;
finalization
  StopList;
end.