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;



// Esta funcion la utilizamos para mostrar mensajes

procedure OutputString(Str: string);

begin

  Writeln(Str);

  //Si no queremos mostrar una consola podemos usar esto otro

  //OutputDebugString(PChar(Str));

end;



// Parte un texto en trocitos, Sub es el separador

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;



// A partir del codigo de error nos devuelve un texto describiendolo

function ResponseText(ResponseNo: Integer): string;

begin

  case ResponseNo of

    200: result := 'OK';

    // Client Error 4xx

    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';

    // Server Error 5xx

    500: result := 'Internal Server Error';

    501: result := 'Not Implemented';

  else

    result := 'Unknown Response Code';

  end;

end;



{THeaders}





//Juntamos todas la cabeceras en un solo string

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;



{TConnection}



// Aqui establecemos una conexion nueva

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;



// Este es el bucle de la conexion. Recibe los comandos y devuelve las respuestas

// Si ocurre algun error, intenta cerrar la conexion y termina el thread.

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);

      // Solo implementamos los comandos GET y HEAD

      if (AnsiSameText(FCommand, 'GET')) or (AnsiSameText(FCommand, 'HEAD')) then

      begin

        // Aqui destripamos la peticion

        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);

        // Ahora leemos una a una las cabeceras

        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;

        // Intentamos responder la peticion

        if not (Terminated) then

        begin

          try

            WriteResponse;

          except

            // Si ocurre algun error mandamos el codigo 500

            FResponse.Connection := 'close';

            SendMsg(ResponseText(500), 500);

            Terminate;

          end;

        end;

      end

      else

      begin

        // Si no es ni Get ni Head mandamos el codigo 501

        FResponse.Connection := 'close';

        SendMsg(ResponseText(501), 501);

        Terminate;

      end;

    end;

  // Cerramos conexion

  if Shutdown(FSocket, SD_SEND) <> SOCKET_ERROR then

    repeat until recv(FSocket, buf, sizeof(buf) - 1, 0) <= 0;

  CloseSocket(FSocket);

end;



// Esta funcion lee una linea, si ocurre un error, se cumple el Timeout

// o la linea es demasiado larga la funcion termina y devuelve FALSE.

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;



// Escribe las cabeceras de la respuesta

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;



// Envia un mensaje de texto

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;



// envia un mensaje al cliente

procedure TConnection.SendIndex(Path: string);

var

  s: string;

begin

  s := Path;

  s := 'hola';

  SendMsg(s, 1);

end;



procedure TConnection.WriteResponse;

begin

        SendIndex(FDocument)

end;



// Bucle principal, aqui se crea el socket del servidor y los

// diferentes threads con las conexiones.

procedure Run;

var

  WSADATA: TWSADATA;

  ServerSocket: TSocket;

  LocalAddr: TSockaddr;

  ClientSocket: TSocket;

  RemoteAddr: TSockaddr;

  AddrSize: Integer;

  FDSet: TFDSet;

  TimeVal: TTimeVal;

  Ticks: dword;

begin

  // Inicializamos Winsock

  if WSAStartup(MAKEWORD(1, 1), WSADATA) = 0 then

  try

    // Creamos el socket del servidor

    ServerSocket := socket(AF_INET, SOCK_STREAM, IPPROTO_IP);

    if ServerSocket <> INVALID_SOCKET then

    begin

      with LocalAddr do

      begin

        sin_family := AF_INET;

        // Aqui colocamos el puerto a usar

        sin_port := htons(1234);

        sin_addr.s_addr := htonl(INADDR_ANY);

        // sin_addr.s_addr:= Inet_Addr('127.0.0.1');

      end;

      // Ponemos el socket a la escucha ...

      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);

            // Comprobamos el estado del socket

            if select(0, @FDSet, nil, nil, @TimeVal) > 0 then

            begin

              AddrSize := sizeof(RemoteAddr);

              // Aceptamos la nueva conexion y creamos un nuevo thread

              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.