labradserver.pas

As science advances, novel experiments are becoming more and more complex, requiring a zoo of contro

{ Copyright (C) 2007 Markus Ansmann
 
  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.
 
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.  }

unit LabRADServer;

interface

 uses
  Classes, LabRADSocket, LabRADConnection, LabRADDataStructures;

 const
  ContextExpirationSettingID = longword(maxint)+2876341;

 type
  TLabRADNewContextEvent = function (Sender: TObject; Context: TLabRADContext; Source: TLabRADID): pointer of object;
  TLabRADExpireCtxtEvent = procedure(Sender: TObject; Context: TLabRADContext; ContextData: pointer) of object;
  TLabRADRecordEvent     = function (Sender: TObject; Context: TLabRADContext; ContextData: pointer; Setting: TLabRADID; Data: TLabRADData): TLabRADData of object;

  TLabRADServerContexts = record
    Context: TLabRADContext;
    Queue:   array of TLabRADPacket;
    CurRec:  integer;
    Reply:   TLabRADPacket;
    Data:    pointer;
  end;

  TLabRADContextDataArray = array of pointer;

  TLabRADServer = class(TLabRADConnection)
   private
    { Private declarations }
    fDescr:     string;
    fRemarks:   string;
    fContexts:  array of TLabRADServerContexts;

    fOnNewCtxt: TLabRADNewContextEvent;
    fOnExpCtxt: TLabRADExpireCtxtEvent;
    fOnRequest: TLabRADRecordEvent;

    function GetAllContexts: TLabRADContextDataArray;

    procedure DoConn(Sender: TObject; const Packet: TLabRADPacket; Data: integer);

   protected
    { Protected declarations }
    procedure OnConn; override;
    function  GetLoginData: TLabRADData; override;
    procedure OnSyncReq(const Packet: TLabRADPacket); override;
    procedure OnSyncMsg(const Packet: TLabRADPacket); override;
    procedure HandleRecords(Index: integer); virtual;

   public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    procedure StartServing;
    procedure RegisterSetting(ID: TLabRADID; Name: string; Description: string; AcceptedTags, ReturnedTags: array of string; Remarks: string);
    procedure SendReply(Context: TLabRADContext; Reply: TLabRADData);
    procedure SendError(Context: TLabRADContext; Code: integer; Error: string);

    property  AllContexts: TLabRADContextDataArray read GetAllContexts;

   published
    { Published declarations }
    property Description: string read fDescr   write fDescr;
    property Remarks:     string read fRemarks write fRemarks;

    property OnNewContext:    TLabRADNewContextEvent read fOnNewCtxt write fOnNewCtxt;
    property OnExpireContext: TLabRADExpireCtxtEvent read fOnExpCtxt write fOnExpCtxt;
    property OnRequest:       TLabRADRecordEvent     read fOnRequest write fOnRequest;
  end;

procedure Register;

implementation

uses SysUtils, LabRADExceptions, LabRADEnvironmentVariables, LabRADEnvironmentDialog;

constructor TLabRADServer.Create(AOwner: TComponent);
begin
  inherited;
  ConnectionName:='Delphi Server';
  fDescr:='No description for this server available...';
  fRemarks:='';
  setlength(fContexts, 0);
end;

function TLabRADServer.GetLoginData: TLabRADData;
var S, S2, N, V: String;
    done:        Boolean;
    a:           integer;
begin
  // Replace all %blahs% in clientname with environment or user supplied values
  s:=ConnectionName;
  repeat
    done:=true;
    a:=pos('%', S);
    if a>0 then begin
      S2:=copy(S, a+1, 100000);
      S :=copy(S, 1, a-1);
      a:=pos('%', S2);
      if a>0 then begin
        done:=false;
        N :=copy(S2, 1, a-1);
        S2:=copy(S2, a+1, 100000);
        V:=GetEnvironmentString(N);
        if V='' then begin
          if not assigned(EnvironmentDialogForm) then
            EnvironmentDialogForm:=TEnvironmentDialogForm.Create(nil);
          if EnvironmentDialogForm.Execute(ConnectionName, N) then
            V:=EnvironmentDialogForm.Value;
        end;
        S:=S+V+S2;          
      end;
    end;
  until done;
  Result:=TLabRADData.Create('(wsss)');
  Result.SetWord  (0, 1);
  Result.SetString(1, S);
  Result.SetString(2, fDescr);
  Result.SetString(3, fRemarks);
end;

procedure TLabRADServer.OnSyncReq(const Packet: TLabRADPacket);
var a: integer;
begin
  a:=0;
  while (a<length(fContexts)) and ((fContexts[a].Context.High<>Packet.Context.High) or
                                   (fContexts[a].Context.Low <>Packet.Context.Low )) do inc(a);
  if a=length(fContexts) then begin
    setlength(fContexts, a+1);
    setlength(fContexts[a].Queue, 0);
    fContexts[a].Context:=Packet.Context;
    fContexts[a].Reply:=nil;
    if assigned(fOnNewCtxt) then fContexts[a].Data:=fOnNewCtxt(self, Packet.Context, Packet.Source)
                            else fContexts[a].Data:=nil;
  end;
  setlength(fContexts[a].Queue, length(fContexts[a].Queue)+1);
  Packet.Keep;
  fContexts[a].Queue[high(fContexts[a].Queue)]:=Packet;
  if not assigned(fContexts[a].Reply) then HandleRecords(a);
end;

procedure TLabRADServer.HandleRecords(Index: integer);
var r: TLabRADRecord;
    d: TLabRADData;
    a: integer;
begin
  if (Index<0) or (Index>=length(fContexts)) then exit;
  while length(fContexts[Index].Queue)>0 do begin
    if not assigned(fContexts[Index].Reply) then begin
      fContexts[Index].Reply:=TLabRADPacket.Create(fContexts[Index].Context,
                                                  -fContexts[Index].Queue[0].Request,
                                                   fContexts[Index].Queue[0].Source);
      fContexts[Index].CurRec:=0;
    end;
    while (fContexts[Index].CurRec>=0) and (fContexts[Index].CurRec<fContexts[Index].Queue[0].Count) do begin
      r:=fContexts[Index].Queue[0][fContexts[Index].CurRec];
      try
        if assigned(fOnRequest) then begin
          d:=fOnRequest(self, fContexts[Index].Context, fContexts[Index].Data, r.Setting, r.Data);
          if not assigned(d) then exit;
//          if d=r.data then d:=r.Data.Copy;
          fContexts[Index].Reply.AddRecord(r.Setting, d);
          if d.IsError then fContexts[Index].CurRec:=-2;
         end else begin
          fContexts[Index].Reply.AddRecord(r.Setting, TLabRADData.Create(-1, 'Server does not handle settings yet'));
        end;
        inc(fContexts[Index].CurRec);
       except
        on E: ELabRADException do begin
          fContexts[Index].Reply.AddRecord(r.Setting, TLabRADData.Create(E.Code, E.Message));
          fContexts[Index].CurRec:=-1;
        end;
        on E: Exception do begin
          fContexts[Index].Reply.AddRecord(r.Setting, TLabRADData.Create(-1, 'Server exception: '+E.Message));
          fContexts[Index].CurRec:=-1;
        end;
      end;
    end;
    Send(fContexts[Index].Reply, True);
    fContexts[Index].Reply:=nil;
    fContexts[Index].Queue[0].Free;
    for a:=1 to high(fContexts[Index].Queue) do
      fContexts[Index].Queue[a-1]:=fContexts[Index].Queue[a];
    setlength(fContexts[Index].Queue, length(fContexts[Index].Queue)-1);
  end;
end;

procedure TLabRADServer.SendReply(Context: TLabRADContext; Reply: TLabRADData);
var a: integer;
begin
  a:=0;
  while (a<length(fContexts)) and ((fContexts[a].Context.High<>Context.High) or
                                   (fContexts[a].Context.Low <>Context.Low )) do inc(a);
  if a=length(fContexts) then exit;
  if length(fContexts[a].Queue)=0 then exit;
  if (fContexts[a].CurRec<0) or (fContexts[a].CurRec>=fContexts[a].Queue[0].Count) then exit;
  if not assigned(fContexts[a].Reply) then exit;
  fContexts[a].Reply.AddRecord(fContexts[a].Queue[0][fContexts[a].CurRec].Setting, Reply);
  if Reply.IsError then fContexts[a].CurRec:=-1 else inc(fContexts[a].CurRec);
  HandleRecords(a);
end;

procedure TLabRADServer.SendError(Context: TLabRADContext; Code: integer; Error: string);
var a: integer;
begin
  a:=0;
  while (a<length(fContexts)) and ((fContexts[a].Context.High<>Context.High) or
                                   (fContexts[a].Context.Low <>Context.Low )) do inc(a);
  if a=length(fContexts) then exit;
  if length(fContexts[a].Queue)=0 then exit;
  if (fContexts[a].CurRec<0) or (fContexts[a].CurRec>=fContexts[a].Queue[0].Count) then exit;
  if not assigned(fContexts[a].Reply) then exit;
  fContexts[a].Reply.AddRecord(fContexts[a].Queue[0][fContexts[a].CurRec].Setting, Code, Error);
  fContexts[a].CurRec:=-1;
  HandleRecords(a);
end;


procedure TLabRADServer.StartServing;
var Pkt: TLabRADPacket;
begin
  Pkt:=TLabRADPacket.Create(0, 1, 1, 1);
  Pkt.AddRecord(120);
  Request(Pkt).Free;
end;

procedure TLabRADServer.RegisterSetting(ID: TLabRADID; Name: string; Description: string; AcceptedTags, ReturnedTags: array of string; Remarks: string);
var Pkt: TLabRADPacket;
    a:   integer;
begin
  Pkt:=TLabRADPacket.Create(0, 1, 1, 1);
  Pkt.AddRecord(100, '(wss*s*ss)');
  Pkt[0].Data.SetWord     (0, ID);
  Pkt[0].Data.SetString   (1, Name);
  Pkt[0].Data.SetString   (2, Description);
  Pkt[0].Data.SetArraySize(3, length(AcceptedTags));
  Pkt[0].Data.SetArraySize(4, length(ReturnedTags));
  Pkt[0].Data.SetString   (5, Remarks);
  for a:=1 to length(AcceptedTags) do Pkt[0].Data.SetString([3, a-1], AcceptedTags[a-1]);
  for a:=1 to length(ReturnedTags) do Pkt[0].Data.SetString([4, a-1], ReturnedTags[a-1]);
  Request(Pkt).Free;
end;

function TLabRADServer.GetAllContexts: TLabRADContextDataArray;
var a: integer;
begin
  setlength(Result, length(fContexts));
  for a:=1 to length(fContexts) do
    Result[a-1]:=fContexts[a-1].Data;
end;

procedure TLabRADServer.OnConn;
var Pkt: TLabRADPacket;
begin
  Pkt:=TLabRADPacket.Create(1, 0, 1, 1);
  Pkt.AddRecord(110, '(wb)');
  Pkt[0].Data.SetWord   (0, ContextExpirationSettingID);
  Pkt[0].Data.SetBoolean(1, True);
  Request(Pkt, DoConn);
end;

procedure TLabRADServer.DoConn(Sender: TObject; const Packet: TLabRADPacket; Data: integer);
begin
  inherited OnConn;
end;

procedure TLabRADServer.OnSyncMsg(const Packet: TLabRADPacket);
var a, b: integer;
begin
  if (Packet.Source=1) and (Packet.Count=1) and (Packet.Records[0].Setting=ContextExpirationSettingID) then begin
    if assigned(fOnExpCtxt) then begin
      if Packet[0].Data.IsWord then begin
        a:=0;
        while a<length(fContexts) do begin
          if fContexts[a].Context.High=Packet[0].Data.GetWord then begin
            fOnExpCtxt(self, fContexts[a].Context, fContexts[a].Data);
            for b:=a+1 to high(fContexts) do fContexts[b-1]:=fContexts[b];
            setlength(fContexts, length(fContexts)-1);
           end else begin
            inc(a);
          end;
        end;
       end else begin
        a:=0;
        while (a<length(fContexts)) and
             ((fContexts[a].Context.High<>Packet[0].Data.GetWord(0)) or
              (fContexts[a].Context.Low <>Packet[0].Data.GetWord(1))) do inc(a);
        if a<length(fContexts) then begin
          fOnExpCtxt(self, fContexts[a].Context, fContexts[a].Data);
          for b:=a+1 to high(fContexts) do fContexts[b-1]:=fContexts[b];
          setlength(fContexts, length(fContexts)-1);
        end;
      end;
    end;
   end else begin
    inherited;
  end;
end;


procedure Register;
begin
  RegisterComponents('LabRAD', [TLabRADServer]);
end;

end.