Servidor web con delphi

[k-19]

Buenas gente, estuve viendo codigo por agunas paginas pero no encontre lo
que estaba buscando. Lo que pasa es que necesitaria un ejemplo basico de un
servidor web que sea multihilo, que use funciones API, que este hecho
en cgi y que muestre una respuesta en el navegador.
Eso es todo...lo necesitaria mas que todo para aprender como se hace porque de eso no entiendo nada.
Si tienen algo Avisenme y gracias!!!

[luisgutierrezb]

Creo que no esta claro el concepto, un servidor web que este hecho en CGI?? un cgi es algo que utiliza un servidor web no un servidor web en si, tal vez si puedieras ser mas especifico en la pregunta

[radenf]

En estos links puedes encontrar tutoriales de como realizar un servidor web en Delphi. No estoy seguro de si es lo que buscas.

http://www.delphiaccess.com/forum/(t...base-de-datos/

http://www.delphiaccess.com/forum/index.php?topic=210.0

Salu2

[k-19]

Gracias por responder...
Lo que busco es algo similar a lo del enlace pero en lugar de SOAP Server Application deberia ser Web Server Application (Disculpen mi ignorancia si es lo mismo, lo que pasa es que yo tengo otra version de delphi) y despues de eso deberia elegir la opcion del medio (que seria CGI).

[roman]

Empezado por radenf

En estos links puedes encontrar tutoriales de como realizar un servidor web en Delphi. No estoy seguro de si es lo que buscas.

No es lo mismo un servidor web que un servicio web.

// Saludos

[k-19]

Estuve trabajando con este código que saque de esta misma pagina:

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.

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.
para que ande hay que conectarse al LOCALHOST:1234
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.
Alguien puede ayudarme??

[radenf]

Empezado por roman

No es lo mismo un servidor web que un servicio web.

// Saludos

Pido disculpas por mi error.
Saludos