FTP server implemented by the idftpserver Control

Program ftpserver_console;
(*
Sample of the usage of the tidftpserver component.
Also shows how to use Indy in console apps
Created by: Bas gooijen (bas_gooijen@yahoo.com)

Disclaimer:
Use it at your own risk, it cocould contain bugs.

Copyright:
Freeware for all use
*)

{$ Apptype console}
Uses
Classes,
Windows,
Sysutils,
Idftplist,
Idftpserver,
Idtcpserver,
Idsockethandle,
Idglobal,
Idhashcrc;

Type
Tftpserver = Class
Private
{Private Declarations}
Idftpserver: tidftpserver;
Procedure idftpserver1userlogin (asender: tidftpserverthread; const ausername, apassword: string; var aauthenticated: Boolean );
Procedure idftpserver1listdirectory (asender: tidftpserverthread; const apath: string; adirectorylisting: tidftplistitems );
Procedure idftpserver1retrievefile (asender: tidftpserverthread; const afilename: string; var vstream: tstream );
Procedure idftpserver1storefile (asender: tidftpserverthread; const afilename: string; aappend: Boolean; var vstream: tstream );
Procedure idftpserver1makedirectory (asender: tidftpserverthread; var vdirectory: string );
// Procedure idftpserver1getfilesize (asender: tidftpserverthread; const afilename: string; var vfilesize: int64 );
Procedure idftpserver1changedirectory (asender: tidftpserverthread; var vdirectory: string );
// Procedure idftpserver1commandxcrc (asender: tidcommand );
// Procedure idftpserver1disconnect (athread: tidpeerthread );
Protected
Function translatepath (const apathname, homedir: string): string;
Public
Constructor create; reintroduce;
Destructor destroy; override;
End;
Constructor tftpserver. Create;
Begin
Idftpserver: = tidftpserver. Create (NiL );
Idftpserver. defaultport: = 1000;
Idftpserver. allowanonymouslogin: = false;
Idftpserver. emulatesystem: = ftpsunix;
Idftpserver. helpreply. Text: = 'help has not been implemented ';
Idftpserver. onchangedirectory: = idftpserver1changedirectory;
Idftpserver. onchangedirectory: = idftpserver1changedirectory;
// Idftpserver. ongetfilesize: = idftpserver1getfilesize;
Idftpserver. onlistdirectory: = idftpserver1listdirectory;
Idftpserver. onuserlogin: = idftpserver1userlogin;
Idftpserver. onretrievefile: = idftpserver1retrievefile;
Idftpserver. onstorefile: = idftpserver1storefile;
Idftpserver. onmakedirectory: = idftpserver1makedirectory;
Idftpserver. Greeting. Text. Text: = 'Welcome to the FTP server! ';
Idftpserver. Greeting. numericcode: = 220;
// Idftpserver. ondisconnect: = idftpserver1disconnect;
// With idftpserver. commandhandlers. Add do
// Begin
// Command: = 'xcrc ';
// Oncommand: = idftpserver1commandxcrc;
// End;
Idftpserver. Active: = true;
End;
{
Function calculatecrc (const path: string): string;
VaR
F: tfilestream;
Value: DWORD;
Idhashcrc32: tidhashcrc32;
Begin
Idhashcrc32: = nil;
F: = nil;
Try
Idhashcrc32: = tidhashcrc32.create;
F: = tfilestream. Create (path, fmopenread or fmsharedenywrite );
Value: = idhashcrc32.hashvalue (f );
Result: = inttohex (value, 8 );
Finally
F. Free;
Idhashcrc32.free;
End;
End;

Procedure tftpserver. idftpserver1commandxcrc (asender: tidcommand );
// Note, this is made up, and not defined in any RFC.
VaR
S: string;
Begin
With tidftpserverthread (asender. Thread) Do
Begin
If authenticated then
Begin
Try
S: = processpath (currentdir, asender. unparsedparams );
S: = translatepath (S, tidftpserverthread (asender. Thread). homedir );
Asender. Reply. setreply (213, calculatecrc (s ));
Except
Asender. Reply. setreply (500, 'file error ');
End;
End;
End;
End;
}
Destructor tftpserver. Destroy;
Begin
Idftpserver. Free;
Inherited destroy;
End;

Function startswith (const STR, substr: string): Boolean;
Begin
Result: = copy (STR, 1, length (substr) = substr;
End;

Function backslashtoslash (const STR: string): string;
VaR
A: DWORD;
Begin
Result: = STR;
For a: = 1 to length (result) Do
If result [a] = '/' then
Result [A]: = '/';
End;

Function slashtobackslash (const STR: string): string;
VaR
A: DWORD;
Begin
Result: = STR;
For a: = 1 to length (result) Do
If result [a] = '/' then
Result [A]: = '/';
End;

Function tftpserver. translatepath (const apathname, homedir: string): string;
VaR
Tmppath: string;
Begin
Result: = slashtobackslash (homedir );
Tmppath: = slashtobackslash (apathname );
If homedir = '/' then
Begin
Result: = tmppath;
Exit;
End;

If length (apathname) = 0 then
Exit;
If result [length (result)] = '/' then
Result: = copy (result, 1, length (result)-1 );
If tmppath [1] <> '/' then
Result: = Result + '/';
Result: = Result + tmppath;
End;

{Function getsizeoffile (const apathname: string): int64;
Begin
Result: = filesizebyname (apathname );
End;
}
Function getnewdirectory (old, Action: string): string;
VaR
A: integer;
Begin
If action = '../' then
Begin
If old = '/' then
Begin
Result: = old;
Exit;
End;
A: = length (old)-1;
While (old [a] <> '/') and (old [a] <> '/') Do
Dec ();
Result: = copy (old, 1, );
Exit;
End;
If (action [1] = '/') or (action [1] = '/') then
Result: = action
Else
Result: = old + action;
End;

Procedure tftpserver. idftpserver1userlogin (asender: tidftpserverthread;
Const ausername, apassword: string; var aauthenticated: Boolean );
Begin
Aauthenticated: = (ausername = 'wyun') and (apassword = 'jhw ');
If not aauthenticated then
Exit;
Asender. homedir: = './';
Asender. currentdir: = '/';
End;

Procedure tftpserver. idftpserver1listdirectory (asender: tidftpserverthread; const apath: string; adirectorylisting: tidftplistitems );

Procedure addlistitem (adirectorylisting: tidftplistitems; filename: string; itemtype: tiddiritemtype; Size: int64; date: tdatetime );
VaR
Listitem: tidftplistitem;
Begin
Listitem: = adirectorylisting. Add;
Listitem. itemtype: = itemtype;
Listitem. filename: = filename;
Listitem. ownername: = 'anonymous ';
Listitem. groupname: = 'all ';
Listitem. ownerpermissions: = 'rwx ';
Listitem. grouppermissions: = 'rwx ';
Listitem. userpermissions: = 'rwx ';
Listitem. Size: = size;
Listitem. modifieddate: = date;
End;

VaR
F: tsearchrec;
A: integer;
Begin
Adirectorylisting. directoryname: = apath;

A: = findfirst (translatepath (apath, asender. homedir) + '*. *', faanyfile, F );
While (a = 0) Do
Begin
If (F. ATTR and fadirectory> 0) then
Addlistitem (adirectorylisting, F. Name, ditdirectory, F. Size, filedatetodatetime (F. Time ))
Else
Addlistitem (adirectorylisting, F. Name, ditfile, F. Size, filedatetodatetime (F. Time ));
A: = findnext (f );
End;

Findclose (f );
End;

Procedure tftpserver. idftpserver1retrievefile (asender: tidftpserverthread;
Const afilename: string; var vstream: tstream );
Begin
Vstream: = tfilestream. Create (translatepath (afilename, asender. homedir), fmopenread or fmsharedenywrite );
End;

Procedure tftpserver. idftpserver1storefile (asender: tidftpserverthread;
Const afilename: string; aappend: Boolean; var vstream: tstream );
Begin
If fileexists (translatepath (afilename, asender. homedir) and aappend then
Begin
Vstream: = tfilestream. Create (translatepath (afilename, asender. homedir), fmopenwrite or fm1_exclusive );
Vstream. Seek (0, sofromend );
End
Else
Vstream: = tfilestream. Create (translatepath (afilename, asender. homedir), fmcreate or fm1_exclusive );
End;

Procedure tftpserver. idftpserver1makedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Begin
Mkdir (translatepath (vdirectory, asender. homedir ));
End;

{Procedure tftpserver. idftpserver1getfilesize (asender: tidftpserverthread;
Const afilename: string; var vfilesize: int64 );
Begin
// Vfilesize: = getsizeoffile (translatepath (afilename, asender. homedir ));
End ;}

Procedure tftpserver. idftpserver1changedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Begin
Vdirectory: = getnewdirectory (asender. currentdir, vdirectory );
End;

{Procedure tftpserver. idftpserver1disconnect (athread: tidpeerthread );
Begin
// Nothing much here
End ;}

Begin
With tftpserver. Create do
Try
Writeln ('the program is running. Press [enter] to exit. ');
Readln;
Finally
Free;
End;
End.