mORMot Open Source

program eventserv;

//{$define Debug}

uses
  {$ifdef linux}
    cthreads,
    cmem, // the c memory manager is on some systems much faster for multi-threading
  {$endif}

sysutils,classes,unix, baseunix,lnet;

type
{ TLTCPTest }

  TLTCPServer = class
   private
    FCon: TLTCP; // THE server connection
    procedure OnEr(const msg: string; aSocket: TLSocket);
    procedure OnAc(aSocket: TLSocket);
    procedure OnRe(aSocket: TLSocket);
    procedure OnDs(aSocket: TLSocket);
   public
    constructor Create;
    destructor Destroy; override;
    procedure Run; // main loop with CallAction
  end;
//===========================
Var
{ vars for daemonizing }
aOld,aTerm: pSigActionRec;
ps1  : psigset;
sSet : cardinal;
pid  : pid_t;
zerosigs : sigset_t;
//err: LongInt;
//mypid:integer;
TCP: TLTCPServer;
//==================================================================================
procedure TLTCPServer.OnEr(const msg: string; aSocket: TLSocket);
begin
//aSocket.Disconnect(true);
{$ifdef DEBUG}
Writeln(logfile, datetimetostr(now)+' TCPServer ERROR: '+msg+' '+aSocket.PeerAddress+CR+LF);
{$endif}
end;
//==================================================================================
procedure TLTCPServer.OnAc(aSocket: TLSocket); 
begin
//if BLACKLIST.Find(aSocket.PeerAddress,ind) then aSocket.Disconnect(True);
{$ifdef DEBUG}
//Writeln(logfile, datetimetostr(now)+' Accepted connection from: '+aSocket.PeerAddress+CR+LF);
{$endif}
end;
//==================================================================================
procedure TLTCPServer.OnDs(aSocket: TLSocket); 
begin
 // Writeln('Lost connection'); // write info if connection was lost
end;
//==================================================================================
procedure TLTCPServer.OnRe(aSocket: TLSocket);  // on recieve message

begin
///////////////////////////////////////// your functionality
end;
//==================================================================================
constructor TLTCPServer.Create;
begin
  FCon := TLTCP.Create(nil); // create new TCP connection
  FCon.OnError := @OnEr;     // assign all callbacks
  FCon.OnReceive := @OnRe;
  FCon.OnDisconnect := @OnDs;
  FCon.OnAccept := @OnAc;
  FCon.Timeout := 150; // responsive enough, but won't hog cpu
  FCon.ReuseAddress := True;
end;
//==================================================================================
destructor TLTCPServer.Destroy;
begin
  FCon.Free; // free the TCP connection
  inherited Destroy;
end;
//=================================== MAIN PROC ============================
procedure TLTCPServer.Run;
var counter,i:integer;
 myport:word;

begin
   ///..............
    if FCon.Listen(myPort) then
      begin // if listen went ok
        repeat
        inc(counter);
        FCon.Callaction; // eventize the lNet
        // some to do
        until Quit; // until user quit
      end;// else // listen
    {$ifdef DEBUG}
   // Writelog(datetimetostr(now)+' Listener not start!!! Port may be busy!!!');
    {$endif} ;
  
end;
{ handle SIGTERM }
//==================================================================================================
procedure DoSig(sig : longint);cdecl;
begin
     case sig of
     SIGTERM : Quit := true;
     end;
//---
{$ifdef DEBUG}
Writeln(logfile, datetimetostr(now)+' Closed by SIGTERM');
CloseFile(logfile);
{$endif}
end;

//==================================================================================================
procedure RunDaemon();

begin
//writeln('Connecting...');
{$hints off}
FpsigEmptySet(zerosigs);
{$hints on}
{ set global daemon booleans }
//bTerm := false;
{ block all signals except -TERM }
sSet := $ffffbffe;
ps1 := @sSet;
fpsigprocmask(sig_block,ps1,nil);
{ setup the signal handlers }
new(aOld);
new(aTerm);
aTerm^.sa_handler{.sh} := SigactionHandler(@DoSig);
aTerm^.sa_mask := zerosigs;
aTerm^.sa_flags := 0;
fpSigAction(SIGTERM,aTerm,aOld);
{ daemonize }
deletefile(iam);
pid := fpFork;
case pid of
0 : begin { we are in the child }
Close(input); { close standard in }
Assign(input,'/dev/null');
ReWrite(input);
Close(output); { close standard out }
Assign(output,'/dev/null');
ReWrite(output);
Close(stderr); { close standard error }
pid:=fpGetPid;
//createpidfile(pid);
end;
-1 :begin
//WriteLn('forking error, process not demonized!');
halt(1);
    end;
else begin
//Halt;
FpExit(0);{ successful fork, so parent dies }
end;
end;
//------------------------------------
if isroot then
begin
TCP := TLTCPServer.Create;
TCP.Run;
TCP.Free;
end;
//------------------------------------
//deletefile(mypath+'d.pid');
end;
//==================================================================================================


Begin

//remotekilled:=false;
mypath:=extractfilepath(paramstr(0));
iam:=paramstr(0);
isroot:=true;
//**Check for superuser rights**
 if fpGetUID <> 0 then
begin
//Writeln('Error: Need superuser rights');
isroot:=false;
//halt;
end;

RunDaemon;

End.