Código:
Código Delphi
[-]
program servidor;
{$APPTYPE CONSOLE}
uses
Windows,
SysUtils,
Classes,
Winsock;
type
THeaders = class
CacheControl,
Connection,
ContentLength,
ContentType,
Authorization,
Server,
WWWAuthenticate,
Username,
Password: string;
function Text: string;
end;
TConnection = class(TThread)
private
FSocket: TSocket;
FAddr: TSockaddr;
FTimeOut: DWord;
FPassword: string;
FRoot: string;
FInput: string;
FCommand: string;
FDocument: string;
FQuery: string;
FVersion: string;
FRequest: THeaders;
FResponse: THeaders;
function Readln(var s: string): boolean;
function WriteHeaders(ResponseNo: integer): boolean;
function SendMsg(Msg: string; ResponseNo: integer): boolean;
procedure SendIndex(Path: string);
procedure WriteResponse;
protected
procedure Execute; override;
public
constructor Create(Socket: TSocket; Addr: TSockaddr; TimeOut: integer);
destructor Destroy; override;
end;
var
ThreadsRunning: Integer;
procedure OutputString(Str: string);
begin
Writeln(Str);
end;
function token(Sub: string; var s: string): string;
var
i: integer;
begin
result := '';
s := Trimleft(s);
i := 1;
while (i <= length(s)) do
begin
if AnsiSameText(copy(s, i, length(Sub)), Sub) then
begin
result := copy(s, 1, i - 1);
delete(s, 1, i - 1);
break;
end;
inc(i);
end;
end;
function URLDecode(s: string): string;
var
i: integer;
Ch: integer;
begin
result := '';
i := 1;
while i <= Length(s) do
begin
if copy(s, i, 1) = '%' then
begin
Ch := StrToIntDef('$' + copy(s, i + 1, 2), -1);
if (Ch > 0) and (Ch < 256) then
result := result + Char(Ch);
inc(i, 2);
end
else
result := result + copy(s, i, 1);
inc(i);
end;
end;
function URLEncode(s: string): string;
var
i: integer;
begin
result := '';
for i := 1 to length(s) do
if s[i] in ['0'..'9', 'a'..'z', 'A'..'Z'] then
result := result + s[i]
else
result := result + '%' + IntToHex(ord(s[i]), 2);
end;
function ExtractValue(s, Param: string): string;
var
Name: string;
Value: string;
begin
result := '';
s:= s + '&';
s := StringReplace(s, '+', ' ', [rfReplaceAll]);
while (pos('&', s) > 0) and (result = '') do
begin
Value := Token('&', s);
delete(s, 1, 1);
Name := URLDecode(Token('=', Value));
delete(Value, 1, 1);
if AnsiSameText(Param, Name) then
result := URLDecode(value);
end;
end;
function ResponseText(ResponseNo: Integer): string;
begin
case ResponseNo of
200: result := 'OK';
400: result := 'Bad Request';
401: result := 'Unauthorized';
403: result := 'Forbidden';
404: result := 'Not Found';
405: result := 'Methode Not Allowed';
408: result := 'Request Timeout';
414: result := 'Request-URI Too Long';
500: result := 'Internal Server Error';
501: result := 'Not Implemented';
else
result := 'Unknown Response Code';
end;
end;
function THeaders.Text: string;
procedure Add(var text, value: string; const name: string);
begin
if value <> '' then
text := text + name + ': ' + value + #13#10;
end;
begin
result := '';
Add(result, CacheControl, 'Cache-Control');
Add(result, Connection, 'Connection');
Add(result, ContentLength, 'Content-Length');
Add(result, ContentType, 'Content-Type');
Add(result, Server, 'Server');
Add(result, WWWAuthenticate, 'WWW-Authenticate');
end;
constructor TConnection.Create(Socket: TSocket; Addr: TSockaddr; TimeOut:
integer);
begin
InterlockedIncrement(ThreadsRunning);
FreeOnTerminate:= TRUE;
FSocket := Socket;
FAddr := Addr;
FTimeOut := TimeOut;
FRequest:= THeaders.Create;
FResponse:= THeaders.Create;
if ParamStr(1) <> '' then
FRoot := ExpandFilename(ParamStr(1))
else
FRoot := ExpandFilename('\');
FPassword := UpperCase(ParamStr(2));
if copy(FRoot, length(FRoot), 1) = '\' then
delete(FRoot, length(FRoot), 1);
inherited Create(FALSE);
end;
destructor TConnection.Destroy;
begin
InterlockedDecrement(ThreadsRunning);
FRequest.Free;
FResponse.Free;
inherited Destroy;
end;
procedure TConnection.Execute;
var
SD_SEND:integer;
line: string;
Header: string;
buf: array[1..1024] of Char;
begin
SD_SEND:=1;
while (not Terminated) and Readln(line) do
if line <> '' then
begin
OutputString(inet_ntoa(FAddr.sin_addr) + ' - ' + line);
FCommand := Token(' ', line);
if (AnsiSameText(FCommand, 'GET')) or (AnsiSameText(FCommand, 'HEAD')) then
begin
if pos('?', line) > 0 then
begin
FDocument := URLDecode(Token('?', line));
delete(line, 1, 1);
FQuery := Token(' ', line);
end
else
begin
FDocument := URLDecode(Token(' ', line));
FQuery := '';
end;
FVersion := Trim(line);
if not Readln(line) then
Terminate;
while (not Terminated) and (line <> '') do
begin
Header := trim(Token(':', line));
delete(line, 1, 1);
line := trim(line);
if not Readln(line) then
Terminate;
end;
if not (Terminated) then
begin
try
WriteResponse;
except
FResponse.Connection := 'close';
SendMsg(ResponseText(500), 500);
Terminate;
end;
end;
end
else
begin
FResponse.Connection := 'close';
SendMsg(ResponseText(501), 501);
Terminate;
end;
end;
if Shutdown(FSocket, SD_SEND) <> SOCKET_ERROR then
repeat until recv(FSocket, buf, sizeof(buf) - 1, 0) <= 0;
CloseSocket(FSocket);
end;
function TConnection.Readln(var s: string): boolean;
var
i: longint;
Tick: DWORD;
FDSet: TFDSet;
TimeVal: TTimeVal;
buf: array[0..1024] of Char;
begin
s := '';
result := FALSE;
Tick := GetTickCount;
while not (Terminated or (pos(#13, FInput) > 0)) do
begin
TimeVal.tv_sec := 0;
TimeVal.tv_usec := 500;
FD_ZERO(FDSet);
FD_SET(FSocket, FDSet);
if select(0, @FDSet, nil, nil, @TimeVal) > 0 then
begin
fillchar(buf, sizeof(buf), 0);
i := recv(FSocket, buf, sizeof(buf) - 1, 0);
if (i <> SOCKET_ERROR) and (i > 0) then
if (length(FInput) + i <= 10000) then
begin
Tick := GetTickCount;
FInput := FInput + string(PChar(@buf));
end
else
begin
FResponse.Connection := 'close';
SendMsg(ResponseText(414), 414);
Terminate;
end
else
Terminate;
end
else if (GetTickCount - Tick) > FTimeOut then
begin
FResponse.Connection := 'close';
SendMsg(ResponseText(408), 408);
Terminate;
end;
end;
if not Terminated then
begin
while (copy(FInput, 1, 1) = #10) do
delete(FInput, 1, 1);
if pos(#13, FInput) > 0 then
begin
s := copy(FInput, 1, pos(#13, FInput) - 1);
delete(FInput, 1, pos(#13, FInput));
result := TRUE;
end;
end;
end;
function TConnection.WriteHeaders(ResponseNo: integer): boolean;
var
s: string;
begin
s := 'HTTP/1.1 ' + ResponseText(ResponseNo) + #13#10 + FResponse.Text + #13#10;
result := send(FSocket, PChar(s)^, length(s), 0) <> SOCKET_ERROR;
end;
function TConnection.SendMsg(Msg: string; ResponseNo: integer): boolean;
begin
if ResponseNo <> 200 then
OutputString(inet_ntoa(FAddr.sin_addr) + ' - ' + Msg);
result := FALSE;
Msg := '' + #13#10 + Msg + #13#10 + '';
FResponse.ContentType := 'text/html';
FResponse.ContentLength := IntToStr(length(Msg));
if WriteHeaders(ResponseNo) then
if AnsiSameText(FCommand, 'HEAD') then
result := TRUE
else
result := send(FSocket, PChar(Msg)^, length(Msg), 0) <> SOCKET_ERROR;
end;
procedure TConnection.SendIndex(Path: string);
var
s: string;
begin
s := Path;
s := 'hola';
SendMsg(s, 1);
end;
procedure TConnection.WriteResponse;
begin
SendIndex(FDocument)
end;
procedure Run;
var
WSADATA: TWSADATA;
ServerSocket: TSocket;
LocalAddr: TSockaddr;
ClientSocket: TSocket;
RemoteAddr: TSockaddr;
AddrSize: Integer;
FDSet: TFDSet;
TimeVal: TTimeVal;
Ticks: dword;
begin
if WSAStartup(MAKEWORD(1, 1), WSADATA) = 0 then
try
ServerSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);
if ServerSocket <> INVALID_SOCKET then
begin
with LocalAddr do
begin
sin_family := AF_INET;
sin_port := htons(1234);
sin_addr.s_addr := htonl(INADDR_ANY);
end;
if bind(ServerSocket, LocalAddr, sizeof(LocalAddr)) <> SOCKET_ERROR then
if listen(ServerSocket, SOMAXCONN) <> SOCKET_ERROR then
begin
repeat
TimeVal.tv_sec := 0;
TimeVal.tv_usec := 500;
FD_ZERO(FDSet);
FD_SET(ServerSocket, FDSet);
if select(0, @FDSet, nil, nil, @TimeVal) > 0 then
begin
AddrSize := sizeof(RemoteAddr);
ClientSocket := accept(ServerSocket, @RemoteAddr, @AddrSize);
if ClientSocket <> INVALID_SOCKET then
TConnection.Create(ClientSocket, RemoteAddr, 30000);
end;
until FALSE;
Ticks := GetTickCount;
while (ThreadsRunning > 0) and (GetTickCount - Ticks < 5000) do
Sleep(100);
end;
end;
finally
WSACleanup();
end;
end;
begin
Run;
end.
Lo fui simplificando de a poco como para entenderlo.Este servidor fue diseñado originalmente para mostrar un listado de archivos y carpetas del disco.
Mi intención era simplificarlo como para que muestre un simple mensaje en el navegador con la menor cantidad de código posible. Todavía falta sacar un poco mas de código que no sirve pero no se como seguir.