26 marzo 2010

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.

4 comentarios:

luk2009 dijo...

Esta libreria trabaja con comunicaciones por el puerto serial, me gustaria la analizaras en ese contexto y que dieras tu opinion sobre su uso en lazarus, como sustituto de las ASYNCPRO

Administrador dijo...

Vere lo que puedo hacer, pero en ese tema veo los ejemplos de Synapse algo pelados.

De hecho, el único ejemplo que tiene con puertos COM no funciona.

Con Lazarus no tengo mucha experiencia ya que me desilusionó un poco al ver que hacía unos ejecutables tan grandes. Un aplicación con 5 o 6 formularios me ocupaba 32 MB. Una burrada.

Espero que lo mejoren en el futuro.

luk2009 dijo...

gracias por responder, sobre lo que indicas sobre lazarus hay varias formas de evitar que el ejecutable sea tan grande:
1.-hay una opcion que hace eso desde el compilado

Menu - Proyecto - Opciones del Compilador - Enlazado -

En el grupo DEPURANDO puedes quitar todos, pero la importante es REMOVER LOS SIMBOLOS EN EL EJECUTABLE.

2.- Puedes utilizar un programa llamado "strip" para eliminar los símbolos de depuración en el archivo ejecutable. Se encuentra en el directorio de lazarus: lazarus\pp\bin\i386-win32\

strip --strip-all archivo_ejecutable (con su path completo)

Lazarus esta mejorando mucho y puedes bajar las ultimas versiones que siempre se estan actualizando desde aqui: http://www.hu.freepascal.org/lazarus/

es bueno que entres a los foros de lazarus ejemplo:
www.delphiaccess.com en la parte de lazarus
y http://www.lazarus.freepascal.org/index.php

Administrador dijo...

Mucha gracias por la información. Lo probaré a ver que tal va cuando vaya a la oficina.

Saludos.

Publicidad