WebserverPlugin.pas
资源名称:DarkMoon.rar [点击查看]
上传用户:hndmjx
上传日期:2014-09-16
资源大小:3369k
文件大小:3k
源码类别:
Delphi控件源码
开发平台:
Delphi
- {
- 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.