IPC über NamedPipes - Generelles Problem

[quendolineDD]

Hallo DP-Community.

Ich hab vor ein paar Wochen mit der Planung eines Projektes angefangen, mir dafür alle in der DP zu findenden Beiträge angeschaut und ausprobiert, wobei mein Erfolg mäßig ausfällt.
Ich habe zuerst einen Service, welcher eine NamedPipe zur Verfügung stellt und auf diese soll mein Programm Daten an den Service schicken, welcher daraufhin Daten in einer lokalen Datenbank speichert, und bei erfolgreicher Verbindung zum Hauptserver ein Image der Datenbank hochladen soll.

Vorerst wichtig:
- Dienst stellt NamedPipe zur Verfügung und LIEST darauf (Pipe ist READONLY)
- Programm verbindet zur Pipe und SCHREIBT



Erstmal bin ich schon dabei zu scheitern, den Datenfluss zwischen Programm und Service fehlerfrei zum laufen zu bringen.
Bisher kommt "Zugriff Verweigert" obwohl ich lt. Forum Zugriff für jeden eingestellt habe ...

Woran liegts?

Delphi-Quellcode:

unit uLogService;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr, Dialogs;

const
  PipeName = '\\.\pipe\CtrPipe';

type
  TService1 = class(TService)
    procedure ServiceShutdown(Sender: TService);
    procedure ServiceExecute(Sender: TService);
    procedure WriteToLogfile(const aText: String);
    procedure ServiceStart(Sender: TService; var Started: Boolean);
  private
    PipeFileHandle : THandle;
  public
    function GetServiceController: TServiceController; override;
  end;

var
  Service1: TService1;

implementation

{$R *.DFM}

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

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

procedure TService1.ServiceShutdown(Sender: TService);
begin
  WriteToLogfile('Beendet');
end;

procedure TService1.ServiceExecute(Sender: TService);
var
  msg : ShortString;
  dw  : DWORD;
begin
msg := ''; dw := 0;

  WriteToLogfile('Begin Execute');
  while not Terminated do
  begin
    ServiceThread.ProcessRequests(False); 
    Try
      ReadFile(PipeFileHandle, msg, sizeof(msg), dw, nil);
      if msg <> '' then
      begin
        WriteToLogfile(msg);
      end;
    Except
      WriteToLogfile('ReadFile - '+SysErrorMessage(GetLastError));
    end;
  end;
  WriteToLogfile('End Execute');
end;

procedure TService1.WriteToLogfile(const aText: String);
const
  logfile = '\log\log.txt';
var
  List : TStringList;
  Time : String;
begin
  List := TStringList.Create;
  Time := TimeToStr(GetTime);
  try
    List.LoadFromFile(logfile);
  except
    List.SaveToFile(logfile);
    List.LoadFromFile(logfile);
  end;
  List.Add(format('%s Zeit: %s', [aText, Time]));
  List.SaveToFile(logfile);
  List.Destroy;
end;

procedure TService1.ServiceStart(Sender: TService; var Started: Boolean);
var
  FSA : SECURITY_ATTRIBUTES;
  FSD : SECURITY_DESCRIPTOR;
begin
  WriteToLogfile('Started');
   InitializeSecurityDescriptor(@FSD, SECURITY_DESCRIPTOR_REVISION);
   SetSecurityDescriptorDacl(@FSD, True, nil, False);
   FSA.lpSecurityDescriptor := @FSD;
   FSA.nLength := sizeof(SECURITY_ATTRIBUTES);
   FSA.bInheritHandle := True; 

  try
    CreateNamedPipe(PipeName, PIPE_ACCESS_INBOUND, PIPE_TYPE_MESSAGE or PIPE_READMODE_MESSAGE or PIPE_NOWAIT, PIPE_UNLIMITED_INSTANCES, 4096, 4096, 50, @FSA);
    try
      PipeFileHandle := CreateFile(PipeName, GENERIC_READ, 0, @FSA, OPEN_EXISTING, 0, 0);
    except
      WriteToLogfile('CreateFile - '+SysErrorMessage(GetLastError));
    end;
  except
    WriteToLogfile('CreateNamedPipe - '+SysErrorMessage(GetLastError));
  end;

  Started := True;
end;

end.

Programm

Delphi-Quellcode:

program ServiceCaller;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Windows;

const
  PipeName = '\\.\pipe\CtrPipe';

type
  RPIPEMessage = record
    Size : Cardinal;
    Msg  : String;
  end;

function ProcessMsg(aMsg : RPIPEMessage): RPIPEMessage;
begin
  Result.Size := SizeOf(Result);
  if WaitNamedPipe(PChar(PipeName), 10) then
    if not CallNamedPipe(
      PChar(PipeName), @aMsg, aMsg.Size, @Result, Result.Size, Result.Size, 3000
    ) then begin
      Writeln(SysErrorMessage(GetLastError));
      Readln;
    end;
end;

var
  Pipe   : THandle;
  inmsg, outmsg : RPIPEMessage;
begin

  inmsg.Msg := 'test';
  inmsg.Size := sizeof(inmsg);

  Writeln(inmsg.Msg);
  outmsg := ProcessMsg(inmsg);
  Writeln(outmsg.Msg);
  Readln;
end.

Bin für alles offen.