SBase.pas

//VPSERVER 3.0 - HTTP Server
//Copyright (C) 2009 Ivanov Viktor
//
//This program is free software; you can redistribute it and/or
//modify it under the terms of the GNU General Public License
//as published by the Free Software Foundation; either version 2
//of the License, or (at your option) any later version.
//
//This program is distributed in the hope that it will be useful,
//but WITHOUT ANY WARRANTY; without even the implied warranty of
//MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
//GNU General Public License for more details.

unit SBase;

interface

{Ïåðåêëþ÷àòåëü îòëàäî÷íîãî ðåæèìà ñåðâåðà}
//{$DEFINE DEBUG_MODE1}

uses STypes;

{Îïðåäåëèòü ðåæèì çàïóñêà}
function LoadMode:TMode;
{Ïîêàçûâàòü ëîãî}
procedure ShowLogo;
{Çàãðóçèòü êîôèãóðàöèþ}
procedure LoadConfig(out Conf:TConfig);
{Çàïóñòèòü ñåðâåðû}
procedure StartServers(const Config:TConfig;out Servers:TServers);
{Çàïóñòèòü äèàëîã}
procedure StartDialogAndWait(var Config:TConfig;var Servers:TServers);
{Îñòàíîâèòü ñåðâåðû}
procedure StopServers(var Servers:TServers);
{Ïðî÷èòàòü íàñòðîéêè ñåðâåðà}
procedure ReadSettings(out Settings:TSettings);
{Âûïîëíèòü êîìàíäû}
procedure ExecuteCommands(var Settings:TSettings);

implementation

uses {$IFDEF MSWINDOWS}Windows{$ENDIF}, SUtils, SLog, PipeUtils, WSUtils, HTTP11;

{Îïðåäåëèòü ðåæèì çàïóñêà}
function LoadMode:TMode;
var
 i:LongWord;
 s:String;
begin
 if ParamCount=1 then
  begin {Ïðîâåðèòü ïîäëèííîñòü}
   LoadMode:=mUnk;
   {Ñïðîñèòü MD5 ïðîèçâîëüíîãî ÷èñëà}
   i:=Random(255);
   writeln(i);
   readln(s);
   if s<>GetMD5(i, sizeof(i)) then
    Exit;
   {Ñïðîñèòü MD5 ðåæèìà}
   i:=StrToInt(ParamStr(1));
   readln(s);
   if (s<>GetMD5(i, sizeof(i))) or (TMode(i)<>mServer) then
    Exit;
   {Âñ¸ ïîëèííîñòü ïîäòâåðæäåíà}
   LoadMode:=TMode(i);
   writeln(OKMsg);
{$IFDEF MSWINDOWS}
   {Óêàçàíèå ðåæèìà äëÿ îòëàäêè}
   SetConsoleTitle(PChar('Server Mode: '+ParamStr(1)));
{$ENDIF}
   Exit;
  end
 else
  begin {Íåò ïàðàìåòðîâ çàïóñêà}
{$IFDEF DEBUG_MODE1}
   LoadMode:=mServer; {Îòëàäêà ñåðâåðà}
{$ELSE}
   LoadMode:=mMain; {Çàïóñê ãëàâíîãî îêíà}
{$ENDIF}
   Exit;
  end;
 {Ñîîáùèòü îá îøèáêå ðàñïîçíàâàíèÿ}
 writeln(BADMsg);
end;

{Ïîêàçàòü ëîãî}
procedure ShowLogo;

  {Âûâåñòè ïðîáåëû}
  procedure ShowSpace;
  begin
   write(' ':(((80-Length(SERV)-2) div 2)-1));
  end;

  {Âûâåñòè ><}
  procedure ShowSubLogo;
  var
   n:Integer;
  begin
   ShowSpace;
   for n:=0 to (Length(SERV) div 2) do
    write('>');
   for n:=0 to Length(SERV)-(Length(SERV) div 2) do
    write('<');
   writeln;
  end;

begin   
{$IFDEF MSWINDOWS}
 SetConsoleTitle(PChar(SERV)); {Óñòàíàâëèâàåì çàãîëîâîê îêíà}
{$ENDIF}
{Âûâîäèì ëîãî}
 ShowSubLogo;
 ShowSpace;
 write('>'+SERV+'<'#13#10);
 ShowSubLogo;
{Âûâîäèì äîï. òåêñò}
 writeln(#13#10, LogoText);
 Sleep(200);
end;

{----------------------Config procs}

{Óñòàíàâëèâèòü êîìàíäû çàïóñêà}
function SetStartupCommands(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
var
 t, c:PStringC;
begin
 SetStartupCommands:=true;
 if val='' then
  begin
   {Çàãîëîâîê ñåêöèè}
   Wait:=true;
   Exit;
  end;
 {Äîáàâëÿåì êîìàíäó}
 New(t);
 t^.Next:=nil;
 t^.S:=val;
 if Conf.StartupCom=nil then
  Conf.StartupCom:=t
 else
  begin
   c:=Conf.StartupCom;
   while c^.Next<>nil do
    c:=c^.Next;
   c^.Next:=t;
  end;
end;

{Óñòàíàâëèâèòü êîìàíäû âûõîäà}
function SetEndCommands(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
var
 t, c:PStringC;
begin
 SetEndCommands:=true;
 if val='' then
  begin
   {Çàãîëîâîê ñåêöèè}
   Wait:=true;
   Exit;
  end;
 {Äîáàâëÿåì êîìàíäó}
 New(t);
 t^.Next:=nil;
 t^.S:=val;
 if Conf.EndCom=nil then
  Conf.EndCom:=t
 else
  begin
   c:=Conf.EndCom;
   while c^.Next<>nil do
    c:=c^.Next;
   c^.Next:=t;
  end;
end;

{Óñòàíîâèòü äîìàøíþþ ïàïêó}
function SetHomeDir(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetHomeDir:=false;
 if curserv=nil then
  Exit; {Íå â ñåêöèè ñåðâåðà}
 {Èçâëåêàåì %%}
 curserv^.Params.HomeDir:=ExpandEnvString(val);
 SetHomeDir:=true;
end;

{Óñòàíîâèòü IP ñåðâåðà}
function SetIP(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetIP:=false;
 if curserv=nil then
  Exit; {Íå â ñåêöèè ñåðâåðà}
 curserv^.Params.IP:=val;
 SetIP:=true;
end;

{Óñòàíîâèòü ïîðò ñåðâåðà}
function SetPort(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetPort:=false;
 if curserv=nil then
  Exit; {Íå â ñåêöèè ñåðâåðà}
 curserv^.Params.Port:=StrToInt(val);
 SetPort:=true;
end;

{Óñòàíîâèòü óðîâåíü æóðíàëèðîâàíèÿ}
function SetLogLevel(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetLogLevel:=false;
 if (curserv=nil) or (Length(val)<>1) or (not (val[1] in ['0'..'2'])) then
  Exit; {Íåïðàâèëüíàÿ ñòðîêà}
 curserv^.Params.LogLevel:=ord(val[1])-ord('0');
 SetLogLevel:=true;
end;

{Óñòàíîâèòü òàéìàóò ñîåäèíåíèÿ}
function SetReadWait(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetReadWait:=false;
 if curserv=nil then
  Exit; {Íå â ñåêöèè ñåðâåðà}
 curserv^.Params.RWait:=StrToInt(val);
 SetReadWait:=true;
end;

{Óñòàíîâèòü òàéìàóò Keep-Alive ñîåäèíåíèÿ}
function SetKATimeout(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
begin
 SetKATimeout:=false;
 if curserv=nil then
  Exit; {Íå â ñåêöèè ñåðâåðà}
 curserv^.Params.KAWait:=StrToInt(val);
 SetKATimeout:=true;
end;

{Óñòàíîâèòü ñåêöèþ ñåðâåðà}
function SetServer(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
var
 ServerName:String;
 tempsrv:PServerRecord;
begin
 SetServer:=false;
 if val[Length(val)]<>']' then
  Exit; {Íåïðàâèëüíî çàïèñàííàÿ ñåêöèÿ}
 ServerName:=val;
 {Ïîëó÷àåì èìÿ ñåðâåðà}
 SetLength(ServerName, Length(ServerName)-1);
 {Èùåì ñåðâåð}
 tempsrv:=Conf.ServerRecords;
 while tempsrv<>nil do
  begin
   if tempsrv^.Params.Name=ServerName then
    break;
   tempsrv:=tempsrv^.Next;
  end;
 if tempsrv=nil then
  begin {Íå íàøëè}
   New(curserv);
   if Conf.ServerRecords=nil then
    Conf.ServerRecords:=curserv {Ïåðâûé ñåðâåð}
   else
    begin {Äîáàâëÿåì ñåðâåð â êó÷ó}
     tempsrv:=Conf.ServerRecords;
     while tempsrv^.Next<>nil do
      tempsrv:=tempsrv^.Next;
     tempsrv^.Next:=curserv;
    end;
   tempsrv:=curserv;
   tempsrv^.Next:=nil;
   if Conf.Main<>nil then
    tempsrv^.Params:=Conf.Main^.Params {Ïðèìåíÿåì ïàðàìåòðû ñåðâåðà Main}
   else
    with tempsrv^.Params do
     begin {Ïðèìåíÿåì äåôîëòíûå ïàðàìåòðû}
      HomeDir:=ServerDir;
      IP:='0.0.0.0';
      Port:=80;
      LogLevel:=0;
      RWait:=5000;
      KAWait:=5000;
     end;
   tempsrv^.Params.Name:=ServerName;
   inc(Conf.AmServers);
  end
 else
  curserv:=tempsrv; {Óñòàíàâëèâàåì òåêóùèé ñåðâåð}
 if ServerName='Main' then
  Conf.Main:=tempsrv;
 SetServer:=true;
end;

{-------------------------------End}

{Çàãðóçèòü êîôèãóðàöèþ}
procedure LoadConfig(out Conf:TConfig);
var
 curserv:PServerRecord;
 Wait:Boolean;
 ind:Integer;
type
 TConfProc=function(var Conf:TConfig;var curserv:PServerRecord;val:String;var Wait:Boolean):Boolean;
const
 PRCS=9;
 {Ñïèñîê ñòðîê}
 ParseVals:array[0..PRCS-1] of String=(
  '[Server=', 'HomeDir=', 'IP=', 'LogLevel=', 'Port=', 'ReadWait=',
  'KeepAliveTimeout=', '[StartupCommands]', '[EndCommands]'
 );
 {Ñïèñîê îáðàáîò÷èêîâ}
 ParseProc:array[0..PRCS-1] of TConfProc=(
  SetServer, SetHomeDir, SetIP, SetLogLevel, SetPort, SetReadWait,
  SetKATimeout, SetStartupCommands, SetEndCommands
 );
  {Ïàðñèòü ñòðîêó}
  function ParseLine(const val:String):Boolean;
  var
   newval:String;
  begin
   ParseLine:=false;
   Wait:=false;
   {Îáðàáàòûâàåì ñòðîêó}
   newval:=val;
   while Pos('[ ', newval)=1 do
    Delete(newval, 2, 1);
   while Pos(' ]', newval)=(Length(newval)-1) do
    Delete(newval, Length(newval)-1, 1);
   if Pos(' =', newval)<>0 then
    Delete(newval, Pos(' =', newval), 1);
   if Pos('= ', newval)<>0 then
    Delete(newval, Pos('= ', newval)+1, 1);
   {Èùåì îáðàáîò÷èê}
   if Pos('=', newval)<>0 then
    ind:=IndexStr(copy(newval, 1, Pos('=', newval)), ParseVals)
   else
    if (newval[Length(newval)]=']') and (newval[1]='[') then
     ind:=IndexStr(newval, ParseVals)
    else
     Exit;
   if ind<0 then
    Exit;
   {Çàïóñêàåì îáðàáîò÷èê}
   Delete(newval, 1, Length(ParseVals[ind]));
   ParseLine:=ParseProc[ind](Conf, curserv, newval, Wait);
  end;

var
 F:Text;
 s:String;
 r:Boolean;
 Line:LongWord;
begin    
 ConsoleLog('×èòàþ íàñòðîéêè...');
 FillChar(Conf, sizeof(Conf), 0);
 {Îòêðûâàåì ôàéë}
 Assign(F, 'config.conf');
 FileMode:=0;
{$I-}
 FileMode:=0;
 Reset(F);
{$I+}
 if IOResult<>0 then
  begin
   ConsoleLog('Error: íå ìîãó îòêðûòü ôàéë êîôèãóðàöèè');
   MyHalt(2);
   Exit;
  end;
 {Ñáðàñûâàåì íàñòðîéêè}
 curserv:=nil;
 Line:=0;
 r:=true;
 Wait:=false;
 {×èòàåì ôàéë}
 while not Eof(F) do
  begin
   inc(Line);
   readln(F, s);
   {Îáðàáàòûâàåì ñòðîêó}
   if Pos(';', s)<>0 then
    s:=copy(s, 1, Pos(';', s)-1);
   DelStr(s, '  ', 1);
   Crop(s);
   if s='' then
    continue;
   if (not Wait) or (copy(s, 1, 1)='[') then
    r:=ParseLine(s)
   else
    r:=ParseProc[ind](Conf, curserv, s, Wait);
   if not r then
    break;
  end;
 {Çàïðåò íà èçìåíåíèå ôàéëà}
// Close(F);
 if r then
  Exit;
 {Ñîîáùàåì îá îøèáêå}
 writeln('Error: íå ìîãó îáðàáîòàòü ôàéë êîíôèãóðàöèè (Ñòðîêà '+IntToStr(Line)+')');
 MyHalt(1);
end;

{Íàéòè ñåðâåð â êó÷å}
function FindServer(const Records:PServerRecord;const Name:String):Integer;
var
 T:PServerRecord;
 C:Integer;
begin
 FindServer:=-1;
 T:=Records;
 C:=0;
 {Ïåðå÷èñëÿåì êó÷ó}
 while T<>nil do
  begin
   inc(C);
   if T^.Params.Name=Name then
    begin {Íàøëè}
     FindServer:=C;
     Exit;
    end;
   T:=T^.Next;
  end;
end;

{Ïîëó÷èòü äàííûå î ñåðâåðå ïî íîìåðó}
function GetServerData(const Servers:TServers;const Num:Integer):PServerData;
begin
 GetServerData:=nil;
 if (Num<0) or (LongWord(Num)>Servers.Count) then
  Exit; {Íåïðàâèëüíûé íîìåð}
 GetServerData:=PServerData(Pointer(@membuf(Servers.Arr)^[(Num-1)*sizeof(PServerData)+1])^);
end;

{Çàïèñàòü íàñòðîéêè ñåðâåðà â ôàéë}
procedure WriteSettings(var F:TextFile;const Settings:TSettings); forward;

{Çàïóñòèòü ñåðâåðîâ}
procedure StartServers(const Config:TConfig;out Servers:TServers);
var
 P:PServerRecord;
 L:PServerData;
 o, t:LongWord;
 s:String;
 Pipe:TPipes;
 PI:TProcessInformation;
 OK:Boolean;
 Settings:TSettings;
begin
 ConsoleLog('Ñîçäàþ ñåðâåðû...');
 {Ñáðàñûâàåì äàííûå}
 FillChar(Servers, sizeof(Servers), 0);
 P:=Config.ServerRecords;
 Servers.Count:=Config.AmServers;
 GetMem(Servers.Arr, Servers.Count*sizeof(PServerData));
 FillChar(Servers.Arr^, Servers.Count*sizeof(PServerData), 0);
 o:=0;
 {Ïåðå÷èñëÿåì êó÷ó}
 while P<>nil do
  begin
   {Çàïóñêàåì ïðîöåññ}
   if WinExecWithPipe(ParamStr(0)+' '+IntToStr(ord(mServer)), {$IFDEF MSWINDOWS}SW_HIDE{$ENDIF}, Pipe, PI)=0 then
    begin
     New(L);
     FillChar(L^, sizeof(L^), 0);
     if OpenPipe(L^.PipeIn, L^.PipeOut, Pipe)=0 then
      begin {Óäà÷íûé çàïóñê}
       L^.Params:=@P^.Params;
       L^.PI:=PI;
{$I-}
       {Äîêàçûâàåì ïîäëèííîñòü}
       readln(L^.PipeIn, t);
       writeln(L^.PipeOut, GetMD5(t, sizeof(t)));
       t:=ord(mServer);
       writeln(L^.PipeOut, GetMD5(t, sizeof(t)));
       readln(L^.PipeIn, s);
{$I+}
       PServerData(Pointer(@membuf(Servers.Arr)^[o+1])^):=L;
       OK:=(s=OKMsg) and (IOResult=0);
      end
     else
      OK:=false;
     if not OK then
      begin {Óäàëÿåì ïðîöåññ}
{$IFDEF MSWINDOWS}
       TerminateProcess(PI.hProcess, INFINITE);
       CloseHandle(PI.hProcess);
       CloseHandle(PI.hThread);
       if PServerData(Pointer(@membuf(Servers.Arr)^[o+1])^)=nil then
        ClosePipe(Pipe)
       else
        begin
         Close(L^.PipeOut);
         Close(L^.PipeIn);
        end;
{$ENDIF}
       Dispose(L);
      end
     else
      begin
       {Ïåðåäà¸ì íàñòðîéêè}
       FillChar(Settings, sizeof(Settings), 0);
       Settings.Params:=P^.Params;
       WriteSettings(L^.PipeOut, Settings);
      end;
    end;
   P:=P^.Next;
   inc(o, sizeof(PServerData));
  end;
end;

{---------------------Command procs}

const
 NoEPar='Êîìàíäà ââåäåíà íåâåðíî';
 UnkSer='Íåèçâåñòíûé ñåðâåð: ';
 CantS='Íåâîçìîæíî çàïóñòèòü ñåðâåð ';
 SerIsNot=': ñåðâåð íå ñîçäàí';
 LogServS='Æóðíàë ñåðâåðà ';

{Êîìàíäà HELP}
function HelpFunc(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
begin
 ConsoleLog('Ñïðàâêà íàõîäèòñÿ â ôàéëå README.TXT');
 HelpFunc:=0;
end;

{Êîìàíäà START}
function StartFunc(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
var
 Num:Integer;
 L:PServerData;
 Res:LongWord;
begin
 StartFunc:=1;
 if Param='' then
  begin {Íåò ïàðàìåòðà}
   ConsoleLog(NoEPar);
   Exit;
  end;
 {Èùåì ñåðâåð}
 Num:=FindServer(Config.ServerRecords, Param);
 if Num<0 then
  begin {Íå íàøëè}
   ConsoleLog(UnkSer+Param);
   Exit;
  end;
 {Ïîëó÷àåì äàííûå}
 L:=GetServerData(Servers, Num);
 if L=nil then
  begin {Äàííûõ íåò}
   ConsoleLog(CantS+Param+SerIsNot);
   Exit;
  end;
 {Ïðîâåðÿåì ñîñòîÿíèå}
 if L^.IsStart then
  begin
   ConsoleLog('Ñåðâåð '+Param+' óæå çàïóùåí');
   Exit;
  end;
 with L^.Params^ do {Îòêðûâàåì ïîðò}
  Res:=ListenPort(IP, Port, Sock);
 if Res<>0 then
  begin {Íå îòêðûëè}
   ConsoleLog(CantS+Param+': ñîêåò íå ìîæåò áûòü ñîçäàí');
   StartFunc:=Res;
   Exit;
  end;
 with L^.Params^ do {Êîïèðóåì ñîêåò äëÿ ñåðâåðà}
  Res:=DuplicateSocket(Sock, L^.PI.dwProcessId, Info);
 if Res<>0 then
  begin {Íå ïîëó÷èëîñü}
   StopConnection(L^.Params^.Sock);
   ConsoleLog(CantS+Param+': îøèáêà ïðè ïåðåäà÷å ñîêåòà ñåðâåðó');
   StartFunc:=Res;
   Exit;
  end;
{$I-}
 {Çàïóñêàåì ñåðâåð}
 writeln(L^.PipeOut, TCommandOrd(cmStart));
 for Res:=1 to sizeof(L^.Params^.Info) do
  writeln(L^.PipeOut, membuf(@L^.Params^.Info)^[Res]);
 readln(L^.PipeIn, Res);
{$I+}
 {Ïðîâåðêà íà îøèáêè}
 if Res=0 then
  Res:=IOResult
 else
  IOResult;
 L^.IsStart:=Res=0;
 if L^.IsStart then {Âñ¸ ÎÊ}
  ConsoleLog('Ñåðâåð '+Param+' çàïóùåí')
 else
  begin {Åñòü îøèáêà}
   StopConnection(L^.Params^.Sock);
   ConsoleLog(CantS+Param+': îøèáêà ñåðâåðà');
  end;
 StartFunc:=Res;
end;

{Êîìàíäà STOP}
function StopFunc(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
var
 Num:Integer;
 L:PServerData;
 Res:LongWord;
begin
{Ïðîâåðêè òå æå, ÷òî è â START}
 StopFunc:=1;
 if Param='' then
  begin
   ConsoleLog(NoEPar);
   Exit;
  end;
 Num:=FindServer(Config.ServerRecords, Param);
 if Num<0 then
  begin
   ConsoleLog(UnkSer+Param);
   Exit;
  end;
 L:=GetServerData(Servers, Num);
 if L=nil then
  begin
   ConsoleLog('Íåâîçìîæíî îñòàíîâèòü ñåðâåð '+Param+SerIsNot);
   Exit;
  end;
 if not L^.IsStart then
  begin
   ConsoleLog('Ñåðâåð '+Param+' íå çàïóùåí');
   Exit;
  end;
 {Çàêðûâàåì ïîðò}
 StopConnection(L^.Params^.Sock);
{$I-}
 {Îñòàíàâëèâàåì ñåðâåð}
 writeln(L^.PipeOut, TCommandOrd(cmStop));
 readln(L^.PipeIn, Res);
{$I+}
 {Ïðîâåðêà íà îøèáêè}
 if Res=0 then
  Res:=IOResult
 else
  IOResult;
 if Res<>0 then
  begin {Ñîîáùàåì îá îøèáêå}
   ConsoleLog('Ïðîèçîøëà îøèáêà íà ñòîðîíå ñåðâåðà '+Param);
   ConsoleLog('Ñåðâåð '+Param+' ðàáîòàåò íåñòàáèëüíî. Ðåêîìåíäóåòñÿ åãî ïåðåçàïóñòèòü');
  end;
 L^.IsStart:=false;
 ConsoleLog('Ñåðâåð '+Param+' îñòàíîâëåí');
 StopFunc:=Res;
end;

{Êîìàíäà STARTLOG}
function StartLogFunc(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
var
 Num:Integer;
 L:PServerData;
 Res:LongWord;
 LogPipe:TPipes;
begin
{Ïðîâåðêè òå æå, ÷òî è â START}
 StartLogFunc:=1;
 if Param='' then
  begin
   ConsoleLog(NoEPar);
   Exit;
  end;
 Num:=FindServer(Config.ServerRecords, Param);
 if Num<0 then
  begin
   ConsoleLog(UnkSer+Param);
   Exit;
  end;
 L:=GetServerData(Servers, Num);
 if L=nil then
  begin
   ConsoleLog('Íåâîçìîæíî çàïóñòèòü æóðíàë ñåðâåðà '+Param+SerIsNot);
   Exit;
  end;
 if L^.IsLogging then
  begin
   ConsoleLog('Æóðíàë ñåðâåðà '+Param+' óæå çàïóùåí');
   Exit;
  end;
 Res:=CreateEmptyPipe(L^.Params^.LogPipe);
 if Res=0 then
  Res:=DuplicatePipe(L^.Params^.LogPipe, LogPipe, L^.PI.hProcess);
 if Res=0 then
  begin
{$I-}
   writeln(L^.PipeOut, TCommandOrd(cmStartLog));
   for Res:=1 to sizeof(LogPipe) do
    writeln(L^.PipeOut, membuf(@LogPipe)^[Res]);
   readln(L^.PipeIn, Res);
{$I+}
   if Res=0 then
    Res:=IOResult
   else
    IOResult;
  end;
 if Res<>0 then
  begin
   ClosePipe(LogPipe);
   ClosePipe(L^.Params^.LogPipe);
   ConsoleLog('Ïðîèçîøëà îøèáêà âî âðåìÿ ñâÿçûâàíèÿ ïðîöåññà êàíàëîì ñ ñåðâåðîì '+Param);
  end
 else
  ConsoleLog(LogServS+Param+' çàïóùåí');
 StartLogFunc:=Res;
 L^.IsLogging:=Res=0;
end;

{Êîìàíäà STOPLOG}
function StopLogFunc(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
var
 Num:Integer;
 L:PServerData;
 Res:LongWord;
begin
{Ïðîâåðêè òå æå, ÷òî è â START}
 StopLogFunc:=1;
 if Param='' then
  begin
   ConsoleLog(NoEPar);
   Exit;
  end;
 Num:=FindServer(Config.ServerRecords, Param);
 if Num<0 then
  begin
   ConsoleLog(UnkSer+Param);
   Exit;
  end;
 L:=GetServerData(Servers, Num);
 if L=nil then
  begin
   ConsoleLog('Íåâîçìîæíî îòñàíîâèòü æóðíàë ñåðâåðà '+Param+SerIsNot);
   Exit;
  end;
 if not L^.IsLogging then
  begin
   ConsoleLog(LogServS+Param+' íå çàïóùåí');
   Exit;
  end;
 ClosePipe(L^.Params^.LogPipe);
{$I-}
 writeln(L^.PipeOut, TCommandOrd(cmStopLog));
 readln(L^.PipeIn, Res);
{$I+}
 if Res=0 then
  Res:=IOResult
 else
  IOResult;
 L^.IsLogging:=false;
 if Res=0 then
  ConsoleLog(LogServS+Param+' îñòàíîâëåí')
 else
  ConsoleLog('Ïðîèçîøëà îøèáêà âî âðåìÿ îñòàíîâêè æóðíàëà ñåðâåðà '+Param);
 StopLogFunc:=Res;
end;

{-------------------------------End}

{Çàïóñòèòü äèàëîã}
procedure StartDialogAndWait(var Config:TConfig;var Servers:TServers);
type
 ComFunc=function(const Param:String;var Config:TConfig;var Servers:TServers):LongWord;
const
 ACOM=5;
 {Ñïèñîê êîìàíä}
 coms:array[0..ACOM-1] of String=(
  'HELP', 'START', 'STOP', 'STARTLOG', 'STOPLOG'
 );
 {Ñïèñîê îáðàáîò÷èêîâ}
 comp:array[0..ACOM-1] of ComFunc=(
  HelpFunc, StartFunc, StopFunc, StartLogFunc, StopLogFunc
 );
var
 Com, Param:String;
 I:Integer;
 R:LongWord;
 P, t:PStringC;
 Q:Boolean;
begin
 ConsoleLog('Çàïóñê êîìàíäíîé ñòðîêè...');
 {Ïîäãîòîâêà ê äèàëîãó}
 StartDialog;
 P:=Config.StartupCom;
 Q:=false;
 while true do
  begin
   if P<>nil then
    begin {Âûïîëíèòü êîìàíäó èç ñïèñêà}
     Param:=P^.S;
     t:=P;
     P:=P^.Next;
     Dispose(t);
     WriteInputLine(Param);
    end
   else
    if Q then
     break {Âûõîäèì}
    else
     Param:=GetInputLine; {×èòàåì êîìàíäó}
   Crop(Param);
   if Param='' then
    continue; {Íåò êîìàíäû}
   {Îáðàáàòûâàåì ñòðîêó}
   if Pos(' ', Param)<>0 then
    Com:=copy(Param, 1, Pos(' ', Param)-1)
   else
    Com:=Param;
   Delete(Param, 1, Length(Com));
   Crop(Param);
   Com:=UpString(Com);
   if Com='QUIT' then
    begin {Ïåðåêëþ÷àåì ñïèñîê}
     P:=Config.EndCom;
     Q:=true;
     continue;
    end;
   {Èùåì êîìàíäó}
   I:=IndexStr(Com, coms);
   if I<0 then {Íå íàøëè}
    ConsoleLog('Error: íåèçâåñòíàÿ êîìàíäà')
   else
    begin
     {Âûïîëíÿåì}
     R:=comp[I](Param, Config, Servers);
     if R<>0 then
      ConsoleLog(Com+': Îøèáêà '+IntToStr(R));
    end;
  end;
 {Ñîîáùàåì SLog, ÷òî ìû îòêëþ÷àåì äèâëîã}
 StopDialog;
end;

{Óäàëèòü ñåðâåðû}
procedure StopServers(var Servers:TServers);
var
 I:LongWord;
 L:PServerData;
begin
 ConsoleLog('Óäàëÿþ ñåðâåðû...');
 {Ïåðå÷èñëÿåì êó÷ó}
 for I:=1 to Servers.Count do
  begin
   L:=GetServerData(Servers, I);
   if L=nil then
    continue;
{$I-}
   {Îòïðàâëÿåì êîìàíäó âûõîäà}
   writeln(L^.PipeOut, TCommandOrd(cmQuit));
   Close(L^.PipeOut);
   Close(L^.PipeIn);
{$I+}
   IOResult;
{$IFDEF MSWINDOWS}
   {Çàâåðøàå ïðîãðàììó}
   if WaitForSingleObject(L^.PI.hProcess, TermTimeout)=WAIT_TIMEOUT then
    TerminateProcess(L^.PI.hProcess, INFINITE); {Ïðèíóäèòåëüíî}
   CloseHandle(L^.PI.hProcess);
   CloseHandle(L^.PI.hThread);
{$ENDIF}
   Dispose(L);
  end;
 FreeMem(Servers.Arr);
end;

{Çàïèñàòü ïàðàìåòðû}
procedure WriteSettings(var F:TextFile;const Settings:TSettings);
begin
{$I-}
 with Settings.Params do
  begin
   writeln(F, Name);
   writeln(F, HomeDir);
   writeln(F, IP);
   writeln(F, Port);
   writeln(F, LogLevel);
   writeln(F, RWait);
   writeln(F, KAWait);
  end;
{$I+}
 IOResult;
end;

{--------- Mode Server Start ----------}

var
 ClientThreads:Integer=0; {Ñ÷¸ò÷èê ïîòîêîâ}

{Ïðî÷èòàòü ïàðàìåòðû}
procedure ReadSettings(out Settings:TSettings); 
begin
 FillChar(Settings, sizeof(Settings), 0);
 with Settings.Params do
  begin
   readln(Name);
{$IFDEF MSWINDOWS}
   SetConsoleTitle(PChar('Server: '+Name));
{$ENDIF}
   readln(HomeDir);
   readln(IP);
   readln(Port);
   readln(LogLevel);
   readln(RWait);
   readln(KAWait);
  end;
end;

{Ïîòîê îáðàáîòêè çàïðîñà}
function ProccessThread(P:Pointer):Integer;
var
 Settings:PSettingsRecord absolute P;
begin
 ProccessThread:=0;
 try
  {Çàïóñê îáðàáîòêè}
  ProccessRequest(Settings^.Socket, @Settings^.Settings^.Params);  
 except
  MessageBeep(MB_ICONHAND);
 end;
 {Óäàëÿåì ïîòîê è ñîêåò}
 StopConnection(Settings^.Socket);
 Dispose(Settings);
 InterlockedDecrement(ClientThreads);
end;

{Íàéòè ìåñòî äëÿ íîâîãî ïîòîêà}
function FindNewTID(var Tids:Pointer):PThreadID;
var
 s, p, t:LongWord;
 N:Pointer;
 i:Boolean;
begin
 if Tids=nil then
  begin {Ïåðâûé ïîòîê}
   GetMem(Tids, sizeof(TThreadID)+1);
   membuf(Tids)^[1]:=1;
   Result:=PThreadID(@membuf(Tids)^[2]);
  end
 else
  if membuf(Tids)^[1]=255 then
   begin {Ïåðåïîëíåíèå}
    repeat {Èùåì ì¸ðòâûå äóøè}
     p:=1;
     s:=1;
     GetMem(N, 255*sizeof(TThreadID)+1);
     while p<>(255*sizeof(TThreadID)+1) do
      begin
       Result:=PThreadID(@membuf(Tids)^[p+1]);
{$IFDEF MSWINDOWS}
       i:=WaitForSingleObject(Result^, 0)=WAIT_TIMEOUT;
{$ENDIF}
       if i then
        begin {Ïîòîê íå çàâåðø¸í}
         PThreadID(@membuf(Tids)^[s+1])^:=Result^;
         inc(s, sizeof(TThreadID));
{$IFDEF MSWINDOWS}
        end
       else
        begin {Ïîëó÷àåì îøèáêó çàâåðøåíèÿ ïîòîêà}
         GetExitCodeThread(Result^, t);
         SetLastError(t);
         CloseHandle(Result^);
        end;
{$ENDIF}
       inc(p, sizeof(TThreadID));
      end;
     {Ïåðåôîðìèðóåì ñïèñîê}
     FreeMem(Tids);
     GetMem(Tids, s);
     move(N^, Tids^, s);
     membuf(Tids)^[1]:=(s-1) div sizeof(TThreadID);
     FreeMem(N);
     if s=p then {Æä¸ì çàâåðøåíèÿ}
      Sleep(TermTimeout);
    until s<>p;
    {Èùåì ìåñòî ñíîâà}
    Result:=FindNewTID(Tids);
   end
  else
   begin {Äîïîëíÿåì ñïèñîê}
    s:=membuf(Tids)^[1]*sizeof(TThreadID)+1;
    {Ñîçäà¸ì íîâûé ñïèñîê}
    GetMem(N, s+sizeof(TThreadID));
    move(Tids^, N^, s);
    {Óäàëÿåì ñòàðûé}
    FreeMem(Tids);
    inc(membuf(N)^[1]);
    Tids:=N;
    Result:=PThreadID(@membuf(Tids)^[s+1]);
   end;
end;

{Óäàëèòü âñå ïîòîêè}
procedure CloseAllTIDS(Tids:Pointer);
var
 p:LongWord;
begin
 if Tids=nil then
  Exit;
 p:=1;
 {Ïåðå÷èñëÿåì âåñü ñïèñîê}
 while p<>(membuf(Tids)^[1]*sizeof(TThreadID)+1) do
  begin
{$IFDEF MSWINDOWS}
   {Æä¸ì çàâåðøåíèÿ}
   if WaitForSingleObject(PThreadID(@membuf(Tids)^[p+1])^, TermTimeout)=WAIT_TIMEOUT then
    begin {Íåäîæäàëèñü}
     TerminateThread(PThreadID(@membuf(Tids)^[p+1])^, INFINITE);
     InterlockedDecrement(ClientThreads);
     SetLastError(WAIT_TIMEOUT);
    end;
   CloseHandle(PThreadID(@membuf(Tids)^[p+1])^);
{$ENDIF}
   inc(p, sizeof(TThreadID));
  end;
end;

{Ñåðâåðíàÿ ÷àñòü}
function ServerThread(P:Pointer):Integer;
var
 Settings:PSettings absolute P;
 SettingsRecord:PSettingsRecord;
 Socket:TSocket;
 From:String;
 tids:Pointer;
 tid:TTID;
 hThread:PThreadID;
 le:LongWord;
begin
 SetLastError(0);
 try
  tids:=nil;
  while true do
   begin
    le:=GetLastError;
    {Æä¸ì ñîåäèíåíèÿ}
    Result:=AcceptConnection(Settings^.Params.Sock, From, Socket);
    if Result<>0 then
     begin {Îøèáêà - çàâåðøàåìñÿ}
      {Èãíîðèðóåì ïðåðûâàíèå ñîåäèíåíèÿ}
      IgnoreIntr(le);
      {Óäàëÿåì ïîòîêè}
      CloseAllTIDS(tids);
      break;
     end
    else
     begin {Çàïóñêåì îáðàáîò÷èê}
      New(SettingsRecord);
      SettingsRecord^.Settings:=Settings;
      SettingsRecord^.Socket:=Socket;
      hThread:=FindNewTid(tids);
      hThread^:=BeginThread(nil, 0, ProccessThread, SettingsRecord, 0, tid);
      InterlockedIncrement(ClientThreads);
     end;
   end;
 finally
  {Óäàëÿåì ñïèñîê}
  if tids<>nil then
   FreeMem(tids);
 end;
 ServerThread:=GetLastError;
end;

{--------------Server command procs}

{Êîìàíäà çàâïóñêà}
procedure cmStartProc(var Settings:TSettings);
var
 R:LongWord;
begin
 if Settings.IsStart then
  begin {Óæå çàïóùåí}
   writeln(1);
   Exit;
  end;
 with Settings.Params do
  begin {Çàãðóæàåì ïàðàìåòðû}
{$IFDEF DEBUG_MODE1}
   R:=ListenPort(IP, Port, Sock);
{$ELSE}
   for R:=1 to sizeof(Info) do
    readln(membuf(@Info)^[R]);
   R:=CreateDuplicatedSocket(Sock, Info);
{$ENDIF}
   if R=0 then
    begin
     {Çàïóñêàåì ñåðâåðíóþ ÷àñòü}
     Settings.hThread:=BeginThread(nil, 0, ServerThread, @Settings, 0, Settings.tid);
     if Settings.hThread=INVALID_HANDLE_VALUE then
      R:=GetLastError;
    end;
  end;
 Settings.IsStart:=R=0;
 {Ñîîáùèòü î ðåçóëüòàòå}
 writeln(R);
end;

{Êîìàíäà îñòàíîâêè ñåðâåðà}
procedure cmStopProc(var Settings:TSettings);
var
 R:LongWord;
begin
 if not Settings.IsStart then
  begin {Íå çàïóùåí}
   writeln(1);
   Exit;
  end;
 {Çàêðûâàåì ïîðò}
 StopConnection(Settings.Params.Sock);
{$IFDEF MSWINDOWS}
 {Çàâåðøàåì ïîòîê}
 WaitForSingleObject(Settings.hThread, INFINITE);
 GetExitCodeThread(Settings.hThread, R);
 CloseHandle(Settings.hThread);
{$ENDIF}
 Settings.IsStart:=false;
 {Ñîîáùèòü î ðåçóëüòàòå}
 writeln(R);
end;

procedure cmStartLogProc(var Settings:TSettings);
var
 I:LongWord;
begin
 if Settings.IsLogging then
  begin
   writeln(1);
   Exit;
  end;
 for I:=1 to sizeof(Settings.Params.LogPipe) do
  readln(membuf(@Settings.Params.LogPipe)^[I]);
 InstallPipeConnect(Settings.Params.LogPipe, true);
 Settings.IsLogging:=true;
 writeln(0);
end;

procedure cmStopLogProc(var Settings:TSettings);
begin
 if not Settings.IsLogging then
  begin
   writeln(1);
   Exit;
  end;
 UnInstallPipeConnect(Settings.Params.LogPipe);
 Settings.IsLogging:=false;
 writeln(0);
end;

{-------------------------------End}

{Âûïîëíèòü êîìàíäû}
procedure ExecuteCommands(var Settings:TSettings);
type
 TServCommProc=procedure(var Settings:TSettings);
const
 {Ñïèñîê îáðàáîò÷èêîâ êîììàíä}
 cmhndrs:array[TCommand] of TServCommProc=(
  nil, cmStartProc, cmStopProc, cmStartLogProc, cmStopLogProc
 );
var
 Com:TCommand;
begin
{$IF DECLARED(MimeInit)}
 {Èíèöèàëèçàöèÿ mime-ìåíåäæåðà}
 MimeInit;
{$IFEND}
 while true do
  begin
   {Ïðèíèìàåì êîìàíäó}
   readln(TCommandOrd(Com));
   if Com=cmQuit then
    break;
   {Âûïîëíÿåì}
   cmhndrs[Com](Settings);
  end;
{$IF DECLARED(MimeDestroy)}
 {Ñîîáùàåì mime-ìåíäæåðó î çàâåðøåíèè}
 MimeDestroy;
{$IFEND}
end;

{--------- Mode Server End ----------}

{$IFDEF MSWINDOWS}
{Çàïðåò íà âûõîä}
function MyHandlerRoutine(dwCtrlType:LongWord):Boolean; stdcall;
begin
 ConsoleLog('Error: ïðîãðàììó ñëåäóåò çàâåðøàòü òîëüêî ñ ïîìîùüþ êîìàíäû QUIT');
 MyHandlerRoutine:=true;
end;

var
 DefaultTitle:String;
 Len:LongWord;
{$ELSE}
var
{$ENDIF}
 LastExceptProc:Pointer;
 LastErrorProc:Pointer;
 LastExitProc:Pointer;
 LCounter:LongWord;
 LParams:String='';

{Îáðàáîò÷èêè îøèáîê}

procedure ExceptHandler(ExceptObject:TObject;ExceptAddr:Pointer{$IFDEF FPC};FrameCount:LongInt;Frame:PPointer{$ENDIF});
begin
{$I-}
 PauseAllThreads;
 writeln(ErrOutput, 'Ïðîèçîøëî íåîáðàáîòàííîå èñêëþ÷åíèå');
 writeln(ErrOutput, 'Àäðåñ: ', LongWord(ExceptAddr));
{$IFDEF FPC}
 writeln(ErrOutput, 'Frame count: ', FrameCount);
 if Frame<>nil then
  writeln(ErrOutput, 'Frame: ', LongWord(Frame^));
{$ELSE}
 if Assigned(ExceptObject) then
  ExceptObject.Destroy;
{$ENDIF}
{$I+}     
 IOResult;
end;

procedure SErrorProc(ErrorCode:{$IFDEF FPC}LongInt{$ELSE}Byte{$ENDIF};Addr:Pointer{$IFDEF FPC};Frame:Pointer{$ENDIF});
begin
{$I-}
 PauseAllThreads;
 writeln(ErrOutput, 'Ïðîèçîøëà îøèáêà â ñèñòåìíîé áèáëèîòåêå ïðîãðàììû');
 writeln(ErrOutput, 'Àäðåñ: ', LongWord(Addr));
 writeln(ErrOutput, 'Êîä îøèáêè: ', ErrorCode);
{$IFDEF FPC}
 writeln(ErrOutput, 'Frame: ', LongWord(Frame));
{$ENDIF}
 ExitCode:=0;
 ErrorAddr:=nil;
{$I+}
 IOResult;
end;

procedure SExitProc;
begin
 ExitProc:=LastExitProc;
 if ErrorAddr<>nil then
  SErrorProc(ExitCode, ErrorAddr{$IFDEF FPC}, nil{$ENDIF});
end;

initialization
{$IFDEF MSWINDOWS}
 {Çàïðåò íà âûõîä}
 SetConsoleCtrlHandler(@MyHandlerRoutine, true);
 {Ïîëó÷àåì çàãëîâîê îêíà ïî óìîë÷àíèþ}
 Len:=GetConsoleTitle(nil, 0);
 SetLength(DefaultTitle, Len);
 if Len<>0 then
  GetConsoleTitle(PChar(DefaultTitle), Len);
 {Óñòàíàâëèâàåì ðåæèì îáðàòîêè îøèáîê}
 SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOOPENFILEERRORBOX or SEM_NOALIGNMENTFAULTEXCEPT);
{$ENDIF}
 {Óñòàíàâëèâàåì îáðàáîò÷èêè îøèáîê}
 LastExceptProc:={$IFDEF FPC}@{$ENDIF}ExceptProc;
 LastErrorProc:=@ErrorProc;
 LastExitProc:=ExitProc;
 ExceptProc:=@ExceptHandler;
 ErrorProc:=SErrorProc;
 ExitProc:=@SExitProc;
 {Äîáàâëÿåì ñâîþ ïåðåìåííóþ îêðóæåíèÿ}
 SetEnvironmentVariable('VPSERVERdir', ServerDir);
 {Ïîäãîíÿåì ïîä ñåáÿ STDIO}
 Rewrite(Output);
 Reset(Input);
 for LCounter:=0 to ParamCount do
  LParams:=LParams+' '+ParamStr(LCounter);
 Delete(LParams, 1, 1);
 for LCounter:=0 to MaxInt do
  begin
   Assign(ErrOutput, LogDir+'CrashLog'+IntToStr(LCounter)+LogExt);
{$I-}
   Rewrite(ErrOutput);
{$I+}
   if IOResult=0 then
    begin
     writeln(ErrOutput, 'Executed at ', GetRFC1123DateTime(GetCurrentDateTime));
     writeln(ErrOutput, 'Command line: ', LParams);
     writeln(ErrOutput, 'Error output:');
     break;
    end;
  end;
 AutoFlush(ErrOutput);
 AutoFlush(Output);
 AutoFlush(Input);
finalization
{$IFDEF MSWINDOWS}
 {Âîçâðàùàåì çàãîëîâîê}
 SetConsoleTitle(PChar(DefaultTitle));
{$ENDIF}
 {Âîçâðàùàåì îáðàáîò÷èêè îøèáîê}
 if {$IFDEF FPC}@{$ENDIF}ExceptProc=@ExceptHandler then
  ExceptProc:=LastExceptProc;
 if @ErrorProc=@SErrorProc then
  ErrorProc:=LastErrorProc;
 if ExitProc=@SExitProc then
  ExitProc:=LastExitProc;
end.