Another FTP Server Source Code

Source code:
Unit servicemainu;

Interface

Uses
Windows, messages, sysutils, classes, graphics, controls, svcmgr, dialogs,
Idbasecomponent, idcomponent, idtcpserver, idftpserver, registry, forms,
Iduseraccounts, idthreadmgr, idthreadmgrpool, idthreadmgrdefault, idftplist;

Type
Tservmain = Class (tservice)
Idftpserv: tidftpserver;
Iduserman: tidusermanager;
Procedure serviceafterinstall (Sender: tservice );
Procedure serviceafteruninstall (Sender: tservice );
Procedure servicestart (Sender: tservice; var started: Boolean );
Procedure servicestop (Sender: tservice; var stopped: Boolean );
Procedure serviceexecute (Sender: tservice );
Procedure idftpservafteruserlogin (asender: tidftpserverthread );
Procedure idftpservexception (athread: tidpeerthread;
Aexception: exception );
Procedure idftpservretrievefile (asender: tidftpserverthread;
Const afilename: string; var vstream: tstream );
Procedure idftpservchangedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Procedure idftpservlistdirectory (asender: tidftpserverthread;
Const apath: string; adirectorylisting: tidftplistitems );
Procedure idftpservbeforecommandhandler (asender: tidtcpserver;
Const aData: string; athread: tidpeerthread );
Procedure idftpservgetcustomlistformat (asender: tidftpserver;
Aitem: tidftplistitem; var vtext: string );
Procedure idftpservmakedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Procedure idftpservuserlogin (asender: tidftpserverthread;
Const ausername, apassword: string; var aauthenticated: Boolean );
Procedure idftpservstorefile (asender: tidftpserverthread;
Const afilename: string; aappend: Boolean; var vstream: tstream );
Private
{Private Declarations}
Public
Function getservicecontroller: tservicecontroller; override;
{Public declarations}
End;

VaR
Servmain: tservmain;

Const
Csregeventlog = 'System/CurrentControlSet/services/EventLog/application ';
Csservicename = 'servmain ';

Implementation

Uses mainu;

{$ R *. DFM}

Procedure servicecontroller (ctrlcode: DWORD); stdcall;
Begin
Servmain. Controller (ctrlcode );
End;

Function tservmain. getservicecontroller: tservicecontroller;
Begin
Result: = servicecontroller;
End;

Procedure regeventlog (aregister: Boolean );
VaR
Reg: Tregistry;
Begin
Reg: = Tregistry. Create;
Try
Reg. rootkey: = HKEY_LOCAL_MACHINE;
If (Reg. openkey (csregeventlog, false) then
Begin
If (aregister) then
Begin
If (Reg. openkey (csservicename, true) then
Begin
Reg. writestring ('eventmessagefile', paramstr (0 ));
Reg. writeinteger ('typessupported', eventlog_error_type
Or eventlog_warning_type or eventlog_information_type );
End;
End
Else
Reg. deletekey (csservicename );
End;
Finally
Reg. Free;
End;
End;

Procedure tservmain. serviceafterinstall (Sender: tservice );
Begin
Regeventlog (true );
End;

Procedure tservmain. serviceafteruninstall (Sender: tservice );
Begin
Regeventlog (false );
End;

Procedure tservmain. servicestart (Sender: tservice; var started: Boolean );
Begin
Idftpserv. Active: = true; // start the service
Started: = true;
End;

Procedure tservmain. servicestop (Sender: tservice; var stopped: Boolean );
Begin
Idftpserv. Active: = false; // The service is stopped.
Stopped: = true;
End;

Procedure tservmain. serviceexecute (Sender: tservice );
Begin
While not terminated do // service Response Message
Begin
Servicethread. processrequests (false );
Sleep (100 );
End;
End;

Procedure tservmain. idftpservafteruserlogin (asender: tidftpserverthread );
Begin
End;

Procedure tservmain. idftpservexception (athread: tidpeerthread;
Aexception: exception );
Begin
// Handle errors to solve the problem
End;

Procedure tservmain. idftpservretrievefile (asender: tidftpserverthread;
Const afilename: string; var vstream: tstream );
Begin // download the file and respond to get to solve the problem
Vstream: = tfilestream. Create (afilename, fmopenread or fmsharedenynone );
End;

Procedure tservmain. idftpservchangedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Begin // change the path to solve
If vdirectory [1] = '/' then
Vdirectory: = 'e:/ftproot '+ vdirectory;
If pos (vdirectory, 'e:/ftproot/') <> 0 then
Vdirectory: = 'e:/ftproot ';
End;

Procedure tservmain. idftpservlistdirectory (asender: tidftpserverthread;
Const apath: string; adirectorylisting: tidftplistitems );
Begin
End;

Procedure tservmain. idftpservbeforecommandhandler (asender: tidtcpserver;
Const aData: string; athread: tidpeerthread );
Begin

End;

Procedure tservmain. idftpservgetcustomlistformat (asender: tidftpserver;
Aitem: tidftplistitem; var vtext: string );
Begin

End;

Procedure tservmain. idftpservmakedirectory (asender: tidftpserverthread;
VaR vdirectory: string );
Begin // create a new path to solve
Vdirectory: = stringreplace (vdirectory, '/', '/', [rfreplaceall, rfignorecase]);
Forcedirectories (vdirectory );
End;

Procedure tservmain. idftpservuserlogin (asender: tidftpserverthread;
Const ausername, apassword: string; var aauthenticated: Boolean );
Begin
Aauthenticated: = true; // User Logon verification, implemented
End;

Procedure tservmain. idftpservstorefile (asender: tidftpserverthread;
Const afilename: string; aappend: Boolean; var vstream: tstream );
VaR // upload the file and finally solve it
HD: integer;
Begin
HD: = filecreate (afilename );
Fileclose (HD );
Vstream: = tfilestream. Create (afilename, fmopenwrite or fmsharedenynone );
End;

End;

End.