& pourquoi j’n’écrirais pas ça ?

unit main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs,
  ExtCtrls, IdBaseComponent, IdComponent, IdRawBase, IdRawClient, IdIcmpClient,
  StrUtils, DateUtils, WinInet;

const
  LONG_INTERVAL  = 180000; // toutes les 3mn
  SHORT_INTERVAL =  15000; // toutes les 15s
  SHORT_RETRY    =     50; // 50 essaies rapides après un plantage

  SUCCESS = 1;
  FAILURE = 0;

type
  TConnectionLoggerService = class(TService)
    tmrCheck: TTimer;
    idcmpclntPinger: TIdIcmpClient;
    procedure ServiceExecute(Sender: TService);
    procedure tmrCheckTimer(Sender: TObject);
    procedure ServicePause(Sender: TService; var Paused: Boolean);
    procedure ServiceContinue(Sender: TService; var Continued: Boolean);
  private
    { Déclarations privées }
    iLastValue: Integer;
    dtLastOtherValue: TDateTime;
    iSpeedRetry: Integer;
    fPointer:    TextFile;
    procedure WriteIt(sToWrite: string);
    function  Ping(): SmallInt;
    function  AddLeadingZeroes(const iNumber: Integer; iLength: Integer = 2): string;
    function  CheckIt: SmallInt;
    function  FakeDownload: SmallInt;
  public
    function GetServiceController: TServiceController; override;
    { Déclarations publiques }
  end;

var
  ConnectionLoggerService: TConnectionLoggerService;

implementation

{$R *.DFM}

procedure ServiceController(CtrlCode: DWord); stdcall;
begin
  ConnectionLoggerService.Controller(CtrlCode);
end;

function TConnectionLoggerService.AddLeadingZeroes(const iNumber: Integer;
  iLength: Integer): string;
begin
  Result := SysUtils.Format('%.*d', [iLength, iNumber]) ;
end;

function TConnectionLoggerService.CheckIt: SmallInt;
begin
  // Téléchargement d'un bout de page ET ping du serveur
  Result := (FakeDownload + Ping);
  if (Result = 2) then
  begin
    Dec(iSpeedRetry);
    if (iSpeedRetry = 0) then
    begin
      tmrCheck.Interval := LONG_INTERVAL;
    end;
  end
  else
  begin
    iSpeedRetry       := SHORT_RETRY;
    tmrCheck.Interval := SHORT_INTERVAL;
  end;
  // On n'écrit dans les logs que si le résultat change
  if (iLastValue <> Result) then
  begin
    // On ne stocke pas en double la première valeur
    if (iLastValue <> -1) then
    begin
      // Dernière précédente valeur
      WriteIt(DateTimeToStr(dtLastOtherValue) + ';' + IntToStr(DateTimeToUnix(dtLastOtherValue)) + ';' + IfThen(iLastValue = 2, '1', '0'));
    end;
    //           Caption                       Time Unix Format                            1=Ok ; 0=tombé
    WriteIt(DateTimeToStr(Now) + ';' + IntToStr(DateTimeToUnix(Now)) + ';' + IfThen(Result = 2, '1', '0'));
    iLastValue := Result;
  end;
  dtLastOtherValue := Now;
end;

function TConnectionLoggerService.FakeDownload: SmallInt;
var
  hSession, hURL: HInternet;
  Buffer: array[1..1024] of Byte;
  BufferLen: DWORD;
begin
  Result := FAILURE;
  hSession := InternetOpen(PChar(ExtractFileName(ParamStr(0))), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0) ;
  try
  hURL := InternetOpenURL(hSession, PChar('https://portail.free.fr/'), nil, 0, 0, 0) ;
    try
      InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen) ;
      Result := SUCCESS;
    finally
      InternetCloseHandle(hURL)
    end
  finally
    InternetCloseHandle(hSession)
  end
end;

function TConnectionLoggerService.GetServiceController: TServiceController;
begin
  Result := ServiceController;
end;

function TConnectionLoggerService.Ping(): SmallInt;
begin
  Result := SUCCESS;
  with idcmpclntPinger do
  begin
    try
      Ping();
    except
      Result := FAILURE;
      Exit;
    end;
    if (ReplyStatus.ReplyStatusType <> rsEcho) then
      Result := FAILURE; //pas d'écho, on renvoi false.
  end;
end;

procedure TConnectionLoggerService.ServiceContinue(Sender: TService;
  var Continued: Boolean);
begin
  CheckIt;
  tmrCheck.Enabled := True;
//  WriteIt('Restarted @ ' + DateTimeToStr(Now));
  Continued := True;
end;

procedure TConnectionLoggerService.ServiceExecute(Sender: TService);
begin
  iLastValue := -1;
  WriteIt('Started @ ' + DateTimeToStr(Now));
  tmrCheck.Interval := LONG_INTERVAL;
  // On vérifie au démarrage
  CheckIt;
  // On revérifiera à intervalles réguliers
  tmrCheck.Enabled := True;
  while not Terminated do
    ServiceThread.ProcessRequests(True);// wait for termination

  WriteIt('Stopped @ ' + DateTimeToStr(Now));
  tmrCheck.Enabled := False;
end;

procedure TConnectionLoggerService.ServicePause(Sender: TService;
  var Paused: Boolean);
begin
  // Une dernière vérification avant l'arrêt...
  CheckIt;
  tmrCheck.Enabled := False;
//  WriteIt('Paused @ ' + DateTimeToStr(Now));
  Paused := True;
end;

procedure TConnectionLoggerService.tmrCheckTimer(Sender: TObject);
begin
  CheckIt;
end;

procedure TConnectionLoggerService.WriteIt(sToWrite: string);
var
  sFileName: string;
begin
  // Je recalcule à chaque fois... parce que je ne suis pas radin en CPU.. et pour que le changement de jour fonctionne tout seul...
  sFileName := ExtractFilePath(ParamStr(0)) + 'ConnectionLogger-' + IntToStr(YearOf(Now)) + '-' + AddLeadingZeroes(MonthOf(Now)) + '-' + AddLeadingZeroes(DayOf(Now)) + '.log';
  AssignFile(fPointer, sFileName);
  if FileExists(sFileName) then
    Append(fPointer)
  else
    Rewrite(fPointer);

  Writeln(fPointer, sToWrite);
  CloseFile(fPointer);
end;

end.