La librería Synapse (2)

Continuando con otro protocolo, vamos a ver como implementar un servidor de FTP con esta librería. Basándome en el caos que trae de ejemplo y que esta repartido en dos unidades, lo he fusionado en una unidad pasando a español la mayoría de las variables.

También he tenido que corregir algunas cosas que trae defectuosas, como por ejemplo, subir al directorio padre o listar el contenido de un directorio.

CREAR UN SERVIDOR FTP

Creamos un nuevo proyecto cuyo único formulario va a tener un componente TMemo llamado Mensajes donde monitorizamos los eventos del servidor.

Para gestionar las peticiones de los clientes, lo que se hace es crear primero un hilo de ejecución que espera la conexión de cualquier cliente. Cuando un cliente intenta conectar con el servidor, se abre un nuevo hilo de ejecución exclusivo para ese cliente y deja el hilo principal libre para el resto de usuarios.

Esta sería la implementación del hilo principal:

THiloServidor = class(TThread)
private
  { Private declarations }
protected
  procedure Execute; override;
public
  constructor Create;
end;

Este sería su constructor:

constructor THiloServidor.create;
begin
  inherited create(False);
  FreeOnTerminate := False;
end;

Al ejecutarse este hilo abre un Sock (una conexión) en escucha por el puerto 21 y en canto oiga la conexión de un cliente le abre un hilo para él (THiloFTP):

procedure THiloServidor.Execute;
var
  ClienteSock: TSocket;
  Sock: TTCPBlockSocket;
begin
  // Una vez se ejecuta el hilo del servidor,
  // se queda escuchando indefinidamente las
  // peticiones de los clientes

  Sock := TTCPBlockSocket.Create;
  try
    Sock.Bind('0.0.0.0','21');
    Sock.SetLinger(true, 10000);
    Sock.Listen;

    if Sock.LastError <> 0 then
      Exit;

    while not Terminated do
    begin
      if Sock.CanRead(1000) then
      begin
        ClienteSock := Sock.Accept;
        if Sock.LastError = 0 then
          THiloFtp.create(ClienteSock);
      end;
    end;
  finally
    Sock.Free;
  end;
end;

Este hilo destinado al cliente es el que se quedará activo mientras el cliente esté conectado:

  THiloFTP = class(TThread)
  private
    Clientes: TSocket;
    sIP, sPuerto, sMensaje, sDirectorioActual: string;
  protected
    procedure Execute; override;
    procedure Enviar(const sock: TTcpBlocksocket; sValor: string);
    procedure AnalizarRutaRemota(sValor: string);
    function CrearNombre(sDirectorio, sValor: string): string;
    function CrearNombreReal(sValor: string): string;
    function CrearLista(sValor: string): string;
    procedure Monitorizar;
  public
    constructor Create(sock: TSocket);
  end;

Aquí viene el auténtico ladrillo, el encargado de leer todos los comandos FTP y enviar la respuesta:

procedure THiloFTP.Execute;
var
  Sock, dSock: TTCPBlockSocket;
  s, t: string;
  bAutenticado: boolean;
  sUsuario: string;
  sComando, par: string;
  st: TFileStream;
begin
  Sock := TTCPBlockSocket.Create;
  dSock := TTCPBlockSocket.Create;
  try
    Sock.Socket := Clientes;
    Enviar(Sock, '220 Bienvenido ' + Sock.GetRemoteSinIP);
    bAutenticado := False;
    sUsuario := '';

    // Esperamos cíclicamente hasta que el usuario se autentifique
    repeat
      s := Sock.RecvString(LimiteTiempo);
      sComando := UpperCase(SeparateLeft(s, ' '));
      par := SeparateRight(s, ' ');
      sMensaje := s;
      Synchronize(Monitorizar);

      if Sock.LastError <> 0 then
        Exit;

      if Terminated then
        Exit;

      // ¿Nos han enviado el nombre del usuario?
      if sComando = 'USER' then
      begin
        sUsuario := par;
        Enviar(Sock, '331 Introduzca la contraseña.');
        Continue;
      end;

      // ¿Nos han enviado la contraseña?
      if sComando = 'PASS' then
      begin
        //user verification...
        if ((sUsuario = 'admin') and (par = '1234')) then
        begin
          Enviar(Sock, '230 Conectado correctamente.');
          bAutenticado := True;
          Continue;
        end;
      end;

      Enviar(Sock, '500 Usuario o contraseña incorrecta.');
    until bAutenticado;

    sDirectorioActual := '/';

    // Una vez que el usuario se ha identificado
    // esperamos los comandos del mismo
    
    repeat
      s := Sock.RecvString(LimiteTiempo);
      sComando := UpperCase(SeparateLeft(s, ' '));
      par := SeparateRight(s, ' ');
      sMensaje := s;
      Synchronize(Monitorizar);

      if par = s then
        par := '';

      if Sock.LastError <> 0 then
        Exit;

      if Terminated then
        Exit;

      // ¿El usuario quiere desconectarse?  
      if sComando = 'QUIT' then
      begin
        Enviar(Sock, '221 Cerrando conexión.');
        Break;
      end;

      // ¿No hace nada? (comando para evitar la desconexión por tiempo)
      if sComando = 'NOOP' then
      begin
        Enviar(Sock, '200 tururu');
        Continue;
      end;

      // Nos piden el directorio actual
      if (sComando = 'PWD') or (sComando = 'XPWD') then
      begin
        Enviar(Sock, '257 ' + Quotestr(sDirectorioActual, '"'));
        Continue;
      end;

      // Cambiar de directorio
      if sComando = 'CWD' then
      begin
        t := UnquoteStr(par, '"');
        t := CrearNombre(sDirectorioActual, t);
        
        if DirectoryExists(CrearNombreReal(t)) then
        begin
          sDirectorioActual := t;
          Enviar(Sock, '250 OK ' + t);
        end
        else
          Enviar(Sock, '550 La acción requerida no pudo realizarse.');

        Continue;
      end;

      // Crear un directorio
      if (sComando = 'MKD') or (sComando = 'XMKD') then
      begin
        t := UnquoteStr(par, '"');
        t := CrearNombre(sDirectorioActual, t);

        if CreateDir(CrearNombreReal(t)) then
        begin
          //sDirectorioActual := t;
          Enviar(Sock, '257 "' + t + '" directorio creado');
        end
        else
          Enviar(Sock, '521 "' + t + '" La acción requerida no pudo realizarse.');
          
        Continue;
      end;

      // Volver al directorio padre
      if sComando = 'CDUP' then
      begin
        sDirectorioActual := '/';
        Enviar(Sock, '250 OK');
        Continue;
      end;

      // Estos comandos quedan sin implementar
      if (sComando = 'TYPE') or (sComando = 'ALLO')
        or (sComando = 'STRU') or (sComando = 'MODE') or
        (sComando = 'PASV') then
      begin
        Enviar(Sock, '200 OK');
        Continue;
      end;

      // Cambiar puerto de datos
      if sComando = 'PORT' then
      begin
        AnalizarIPRemota(par);
        Enviar(Sock, '200 OK');
        Continue;
      end;

      // Listar el contenido del directorio actual
      if sComando = 'LIST' then
      begin
        t := UnquoteStr(par, '"');
        t := CrearNombre(sDirectorioActual, t);
        dSock.CloseSocket;
        dSock.Connect(sIP, sPuerto);

        if dSock.LastError <> 0 then
          Enviar(Sock, '425 No se puede abrir la conexión de datos.')
        else
        begin
          Enviar(Sock, '150 OK ' + t);
          dSock.SendString(CrearLista(CrearNombreReal(t)));
          Enviar(Sock, '226 OK ' + t);
        end;
        
        dSock.CloseSocket;
        Continue;
      end;

      // Leee un archivo del servidor
      if sComando = 'RETR' then
      begin
        t := UnquoteStr(par, '"');
        t := CrearNombre(sDirectorioActual, t);
        
        if FileExists(CrearNombreReal(t)) then
        begin
          dSock.CloseSocket;
          dSock.Connect(sIP, sPuerto);
          dSock.SetLinger(true, 10000);
          
          if dSock.LastError <> 0 then
            Enviar(Sock, '425 No puedo abrir la conexión.')
          else
          begin
            Enviar(Sock, '150 OK ' + t);
            try
              st := TFileStream.Create(CrearNombreReal(t),
                fmOpenRead or fmShareDenyWrite);
              try
                dSock.SendStreamRaw(st);
              finally
                st.free;
              end;
              Enviar(Sock, '226 OK ' + t);
            except
              on exception do
                Enviar(Sock, '451 La acción requerida ha sido abortada: error al procesarlo.');
            end;
          end;
          
          dSock.CloseSocket;
        end
        else
          Enviar(Sock, '550 Archivo no disponible. ' + t);
          
        Continue;
      end;

      // Enviar un fichero al servidor
      if sComando = 'STOR' then
      begin
        t := UnquoteStr(par, '"');
        t := CrearNombre(sDirectorioActual, t);

        if DirectoryExists(ExtractFileDir(CrearNombreReal(t))) then
        begin
          dSock.CloseSocket;
          dSock.Connect(sIP, sPuerto);
          dSock.SetLinger(True, 10000);
          
          if dSock.LastError <> 0 then
            Enviar(Sock, '425 No se puede abrir la conexión para datos.')
          else
          begin
            Enviar(Sock, '150 OK ' + t);
            try
              st := TFileStream.Create(CrearNombreReal(t), fmCreate or fmShareDenyWrite);
              try
                dSock.RecvStreamRaw(st, LimiteTiempo);
              finally
                st.free;
              end;
              Enviar(Sock, '226 OK ' + t);
            except
              on Exception do
                Enviar(Sock, '451 La acción requerida ha sido abortada: error al procesarlo.');
            end;
          end;
          dSock.CloseSocket;
        end
        else
          Enviar(Sock, '553 El directorio no existe. ' + t);

        Continue;
      end;
      Enviar(Sock, '500 Error de sintaxis, comando no reconocido.');
    until false;

  finally
    dSock.free;
    Sock.free;
  end;
end;

Lo que tiene dentro son dos bucles:

1º Espera que el usuario se identifique.

2º Una vez identificado espera comandos hasta que el usuario manda un QUIT (un bye en el cliente).

Este procedimiento utiliza otros como el de enviar mensajes:

procedure THiloFTP.Enviar(const Sock: TTcpBlockSocket; sValor: string);
begin
  // Envia los mensajes a los clientes incluyendo el fin de línea
  Sock.SendString(sValor + CRLF);
  sMensaje := sValor;
  Synchronize(Monitorizar);
end;

También tienen otro chorizo para analizar las direcciones remotas:

procedure THiloFTP.AnalizarIPRemota(sValor: string);
var
  n: integer;
  nb, ne: integer;
  s: string;
  x: integer;
begin
  sValor := trim(sValor);
  nb := Pos('(',sValor);
  ne := Pos(')',sValor);

  if (nb = 0) or (ne = 0) then
  begin
    nb := RPos(' ',sValor);
    s := Copy(sValor, nb + 1, Length(sValor) - nb);
  end
  else
    s:=Copy(sValor,nb+1,ne-nb-1);

  for n := 1 to 4 do
    if n = 1 then
      sIP := Fetch(s, ',')
    else
      sIP := sIP + '.' + Fetch(s, ',');

  x := StrToIntDef(Fetch(s, ','), 0) * 256;
  x := x + StrToIntDef(Fetch(s, ','), 0);
  sPuerto := IntToStr(x);
end;

Tenemos otra rutina que junta las rutas con los nombres de los archivos:

function THiloFTP.CrearNombre(sDirectorio, sValor: string): string;
begin
  // Crea una composición con el nombre del directorio y del archivo

  if sValor = '' then
  begin
    Result := sDirectorio;
    Exit;
  end;

  if sValor[1] = '/' then
    Result := sValor
  else
    if (sDirectorio <> '') and (sDirectorio[Length(sDirectorio)] = '/') then
      Result := sDirectorio + sValor
    else
      Result := sDirectorio + '/' + sValor;
end;

A esta otra le he tenido que dar un buen meneo para que se vaya al directorio padre, porque lo que traía implementado era una chapuza:

function THiloFTP.CrearNombreReal(sValor: string): string;
var i: Integer;
begin
  // ¿Hay que subir al directorio padre?
  if Copy(sValor, Length(sValor)-1, 2) = '..' then
  begin
    // Nos saltamos la primera barra
    i := Length(sValor);
    while (i > 1) and (sValor[i] <> '/') do
      Dec(i);

    // Y saltamos hasta la segunda barra
    Dec(i);
    while (i > 1) and (sValor[i] <> '/') do
      Dec(i);

    sValor := Copy(sValor, 1, i);
    sDirectorioActual := sValor;

    if sDirectorioActual = '' then
      sDirectorioActual := '/';
  end;

  sValor := ReplaceString(sValor, '/', '\');
  sValor := '.\datos' + sValor;
  Result := sValor;
end;

Luego esta la rutina que devuelve el formato de fecha y hora para listar los directorios. También la he modificado para adaptarla a lo estándar en Windows:

function FormatoFechaHora(iValor: Integer): string;
var
  FechaHora: TDateTime;
  wAnio, wMes, wDia, wHora, wMinutos, wSegundos, wMilisegundos: word;
begin
  FechaHora := FileDateToDateTime(iValor);
  DecodeDate(FechaHora, wAnio, wMes, wDia);
  DecodeTime(FechaHora, wHora, wMinutos, wSegundos, wMilisegundos);
  Result := Meses[wMes] + ' ' + FormatCurr('00', wDia) + ' ' +
  FormatCurr('00', wHora) + ':' + FormatCurr('00', wMinutos);
end;

Esta es otra de las más importantes. Se encarga de listar el contenido de un directorio al estilo unix:

function THiloFTP.CrearLista(sValor: string): string;
var
  Busqueda: TSearchRec;
  rResultadoBusqueda: integer;
  s: string;
begin
  // Devuelve el contenido del directorio que le pasamos como parámetro
  Result := '';

  if sValor = '' then
    Exit;

  // Si el directorio no termina en contrabarra, se la ponemos
  if sValor[Length(sValor)] <> '\' then
    sValor := sValor + '\';

  rResultadoBusqueda := FindFirst(sValor + '*.*', faAnyFile, Busqueda);
  while rResultadoBusqueda = 0 do
  begin
    if ((Busqueda.Attr and faHidden) = 0) and
       ((Busqueda.Attr and faSysFile) = 0) and
       ((Busqueda.Attr and faVolumeID) = 0) then
    begin
      s := '';
      if (Busqueda.Attr and faDirectory) > 0 then
      begin
        s := s + 'drwxrwxrwx   1 root     root           1 ';
        s := s + FormatoFechaHora(Busqueda.Time) + ' ';
        s := s + Busqueda.Name;
      end
      else
      begin
        s := s + '-rwxrwxrwx   1 root     other      ';
        s := s + CompletarEI(FormatCurr('###,###,#0', Busqueda.Size), 5) + ' ';
        s := s + FormatoFechaHora(Busqueda.Time) + ' ';
        s := s + Busqueda.Name;
      end;
      
      if s <> '' then
        Result := Result + s + CRLF;
    end;
    
    rResultadoBusqueda := FindNext(Busqueda);
  end;
  
  FindClose(Busqueda);
end;

A toda esta parafernalia he tenido que añadir otra función para monitorizar por pantalla el servidor (con synchronize):

procedure THiloFTP.Monitorizar;
begin
  FServidorFTP.Mensajes.Lines.Add(sMensaje);
end;

Y otra para que complete con espacios por la izquierda los números que le pasemos. El listado original se torcía según si listaba archivos con tamaño distinto o directorios:

function CompletarEI(sCadena: string; iLongitud: Integer): string;
begin
  // Completa espacios por la izquierda
  Result := StringOfChar(' ', iLongitud - Length(sCadena)) + sCadena;
end;

Y por último y lo más importante, ponemos en marcha el hilo principal del servidor en el evento OnCreate de este formulario:

procedure TFServidorFTP.FormCreate(Sender: TObject);
begin
  THiloServidor.Create;
end;

EJECUTANDO EL SERVIDOR

Al ejecutar el servidor tiene que quedar a la espera:

Abrimos una ventana de comandos y conectamos con nosotros mismos:

El usuario es admin y la contraseña 1234:

Como podemos apreciar en la imagen, las eñes y las tildes se estropean en modo texto. Nuestro servidor habrá confirmado que estamos dentro:

Dentro de la carpeta de nuestro proyecto tenemos que crear la carpeta datos que será la carpeta raíz de nuestro servidor FTP. He creado tres archivos y una carpeta dentro de datos para probarlo:

Podemos subir o bajar cualquier archivo del servidor:

También podemos entrar y salir de cualquier carpeta:

O crear una nueva carpeta dentro del servidor:

La ventana del servidor nos dirá siempre lo que va ocurriendo:

A este servidor todavía le quedan muchas cosas por implementar, como pueden ser la gestión de usuarios, los permisos de usuarios y carpetas, programar el modo pasivo, los comandos binary, hash, etc.

CONCLUSIONES

A menos que queramos aprender como funciona un servidor FTP, esta librería no sirve de mucho si queremos crear un servidor rápidamente de manera profesional. Ya hemos visto que todo hay que hacerlo a mano, lo cual no es muy práctico si tenemos prisa.

Para mí, un auténtico componente o librería que haga de servidor sería donde solo tenemos que dar de alta usuarios, habilitar permisos en directorios y poco más. Y desde luego, la librería Synapse no sería la candidata. Eso sí, si queréis aprender como funciona desde sus tripas un servidor FTP, esta es la mejor opción. Tenéis el control absoluto sobre todo lo que sucede en el servidor. Eso si no os explota la cabeza antes.

Estos son algunos de los comandos de un servidor FTP según el RFC 959:

USER, PASS, ACCT, CWD, CDUP, SMNT, REIN, QUIT, PORT, PASV, TYPE, STRU, MODE, RETR, STOR, STOU, APPE, ALLO, REST, RNFR, RNTO, ABOR, DELE, etc.

Próximamente seguiré analizando más protocolos con esta librería. Todavía le quedan cosas muy interesantes.

Pruebas realizadas en RAD Studio 2007.