labradconnection.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 LabRADConnection;

interface

 uses
  Classes, LabRADSocket, LabRADDataStructures, LabRADPacketQueues, Controls;

 type
  TLabRADGetPasswordEvent = function (Sender: TObject): string of object;
  TLabRADConnectEvent     = procedure(Sender: TObject; ID: Cardinal; Welcome: string) of object;
  TLabRADMessageEvent     = procedure(Sender: TObject; const Packet: TLabRADPacket) of object;

  TLabRADManagerInfo = class(TPersistent)
   private
    fHost: string;
    fPort: word;
    fPass: string;

   protected
    procedure AssignTo(Dest: TPersistent); override;

   public
    constructor Create; reintroduce;

   published
    property Hostname: string read fHost write fHost;
    property Port:     word   read fPort write fPort;
    property Password: string read fPass write fPass;
  end;

  TLabRADAPIPacket = class(TLabRADPacket)
   private
    fTarget:   string;
    fSettings: array of string;
    fLookup:   boolean;

   public
    constructor Create(                                    Target: TLabRADID); reintroduce; overload;
    constructor Create(Context: TLabRADContext;            Target: TLabRADID); reintroduce; overload;
    constructor Create(ContextHigh, ContextLow: TLabRADID; Target: TLabRADID); reintroduce; overload;
    constructor Create(                                    Target: string   ); reintroduce; overload;
    constructor Create(Context: TLabRADContext;            Target: string   ); reintroduce; overload;
    constructor Create(ContextHigh, ContextLow: TLabRADID; Target: string   ); reintroduce; overload;

    function    AddRecord(Setting: TLabRADID; TypeTag: string):              TLabRADRecord; reintroduce; overload;
    function    AddRecord(Setting: TLabRADID; Data: TLabRADData=nil):        TLabRADRecord; reintroduce; overload;
    function    AddRecord(Setting: TLabRADID; Code: integer; Error: string): TLabRADRecord; reintroduce; overload;
    function    AddRecord(Setting: string;    TypeTag: string):              TLabRADRecord; reintroduce; overload;
    function    AddRecord(Setting: string;    Data: TLabRADData=nil):        TLabRADRecord; reintroduce; overload;
    function    AddRecord(Setting: string;    Code: integer; Error: string): TLabRADRecord; reintroduce; overload;
  end;

  TLookupCacheEntry = record
    Name: string;
    ID:   TLabRADID;
  end;

  TLookupCacheServerEntry = record
    Server:   TLookupCacheEntry;
    Settings: array of TLookupCacheEntry;
  end;

  TLabRADConnection = class(TLabRADComponent)
   private
    fActive:    Boolean;
    fSocket:    TLabRADSocket;

    fManInfo:   TLabRADManagerInfo;
    fConnName:  string;
    fWelcome:   string;
    fID:        cardinal;

    fGetPass:   TLabRADGetPasswordEvent;
    fOnConnect: TLabRADConnectEvent;
    fOnMessage: TLabRADMessageEvent;
    fOnReply:   TLabRADPacketCallback;
    fOnDisc:    TNotifyEvent;

    fMsgQueue:  TLabRADPacketQueue;
    fReqQueue:  TLabRADPacketQueue;

    fCBDummy:   TLabRADPacketCallback;

    fCurContxt: TLabRADContext;

    fLookupCache: array of TLookupCacheServerEntry;

    procedure SetActive(Active: Boolean);
    procedure SetManInfo(const Value: TLabRADManagerInfo);

    procedure OnRecvReq  (const Packet: TLabRADPacket);
    procedure OnRecvMsg  (const Packet: TLabRADPacket);
    procedure OnRecvReply(const Packet: TLabRADPacket);
    
    procedure LookupPacket(Packet: TLabRADAPIPacket);

   protected
    procedure OnConn; virtual;
    procedure OnDisc;

    procedure OnSyncReq  (const Packet: TLabRADPacket); virtual;
    procedure OnSyncMsg  (const Packet: TLabRADPacket); virtual;
    procedure OnChallenge(Sender: TObject; const Packet: TLabRADPacket; Data: integer);
    procedure OnWelcome  (Sender: TObject; const Packet: TLabRADPacket; Data: integer);
    procedure OnID       (Sender: TObject; const Packet: TLabRADPacket; Data: integer);

    function  GetLoginData: TLabRADData; virtual; abstract;

   public
    constructor Create(AOwner: TComponent); override;
    destructor  Destroy; override;

    procedure Send(Packet: TLabRADPacket; FreePacket: Boolean);
    function  Request(Packet: TLabRADPacket; FreePacket: Boolean = True; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;       overload;
    procedure Request(Packet: TLabRADPacket; Data: integer; FreePacket: Boolean = True);                                  overload;
    procedure Request(Packet: TLabRADPacket; Callback: TLabRADPacketCallback; Data: integer = 0; FreePacket: Boolean = True); overload;
    function  AsyncRequest(Packet: TLabRADPacket; FreePacket: Boolean = True): Integer;
    function  WaitForRequest(ID: Integer; Timeout: Cardinal = $FFFFFFFF): TLabRADPacket;
    function  NewContext: TLabRADContext;

    procedure ClearCache;

    property CurrentContext: TLabRADContext          read fCurContxt;

   published
    property Active:         Boolean                 read fActive    write SetActive;
    property ConnectionName: string                  read fConnName  write fConnName;
    property ID:             cardinal                read fID;
    property Manager:        TLabRADManagerInfo      read fManInfo   write SetManInfo;

    property OnGetPassword:  TLabRADGetPasswordEvent read fGetPass   write fGetPass;
    property OnConnect:      TLabRADConnectEvent     read fOnConnect write fOnConnect;
    property OnDisconnect:   TNotifyEvent            read fOnDisc    write fOnDisc;
    property OnMessage:      TLabRADMessageEvent     read fOnMessage write fOnMessage;
    property OnReply:        TLabRADPacketCallback   read fCBDummy   write fCBDummy;

    property CreateCallback: TLabRADPacketCallback   read fCBDummy   write fCBDummy;
  end;

implementation

{$R LabRADIcons.res}

uses Forms, LabRADMD5, LabRADAPIExceptions, LabRADManagerDialog, LabRADPasswordDialog,
     LabRADExceptions, LabRADEnvironmentVariables;

constructor TLabRADManagerInfo.Create;
begin
  inherited;
  fHost:='';
  fPort:=7682;
  fPass:='';
end;

procedure TLabRADManagerInfo.AssignTo(Dest: TPersistent);
begin
  if Dest is TLabRADManagerInfo then begin
    (Dest as TLabRADManagerInfo).fHost:=self.fHost;
    (Dest as TLabRADManagerInfo).fPort := self.fPort;
    (Dest as TLabRADManagerInfo).fPass := self.fPass;
   end else begin
    inherited AssignTo(Dest);
  end;
end;



constructor TLabRADConnection.Create(AOwner: TComponent);
begin
  inherited;
  fActive:=False;
  fManInfo:=TLabRADManagerInfo.Create;
  fSocket:=nil;
  fID:=0;
  fWelcome:='';
  fConnName:='Delphi Connection';
  fMsgQueue:=nil;
  fReqQueue:=nil;
  fCurContxt.High:=0;
  fCurContxt.Low :=1;
  setlength(fLookupCache, 0);
end;

destructor TLabRADConnection.Destroy;
begin
  if assigned(fSocket)   then fSocket.Kill;
  if assigned(fMsgQueue) then fMsgQueue.Kill;
  if assigned(fReqQueue) then fReqQueue.Kill;
  fManInfo.Free;
  inherited;
end;

function TLabRADConnection.NewContext: TLabRADContext;
begin
  fCurContxt.Low:=fCurContxt.Low+1;
  Result:=fCurContxt;
end;

procedure TLabRADConnection.SetManInfo(const Value: TLabRADManagerInfo);
begin
  fManInfo.Assign(Value);
end;

procedure TLabRADConnection.SetActive(Active: Boolean);
var Host: string;
    Port: word;
    Pkt:  TLabRADPacket;
begin
  if Active=fActive then exit;
  if not (csDesigning in ComponentState) then begin
    if Active then begin
      if not assigned(fSocket) then begin
        Host:=fManInfo.Hostname;
        Port:=fManInfo.Port;
        if Host='' then Host:=GetEnvironmentString ('LabRADHost');
        if Port=0  then Port:=GetEnvironmentInteger('LabRADPort');
        if (Host='') or (Port=0) then begin
          if not assigned(ManagerDialogForm) then
            ManagerDialogForm:=TManagerDialogForm.Create(nil);
          if not ManagerDialogForm.Execute(Host, Port) then exit;
          Host:=ManagerDialogForm.Host;
          Port:=ManagerDialogForm.Port;
        end;
        fSocket:=TLabRADSocket.Create(Host, Port, self, OnDisc, OnRecvReq, OnRecvMsg, OnRecvReply);
        Pkt:=TLabRADPacket.Create(0, 1, 0, 1);
        fSocket.Request(Pkt, OnChallenge);
        fMsgQueue:=TLabRADPacketQueue.Create(OnSyncMsg);
        fReqQueue:=TLabRADPacketQueue.Create(OnSyncReq);
      end;
     end else begin
      if assigned(fSocket) then begin
        fID:=0;
        fWelcome:='';
        fSocket.Kill;
        fSocket:=nil;
        fMsgQueue.Kill;
        fMsgQueue:=nil;
        fReqQueue.Kill;
        fReqQueue:=nil;
      end;
    end;
  end;
  fActive:=Active;
end;

procedure TLabRADConnection.OnChallenge(Sender: TObject; const Packet: TLabRADPacket; Data: integer);
var Challenge:    string;
    Authenticate: TLabRADPacket;
    Pass:         string;
begin
  if not assigned(fSocket) then exit;
  if (Packet.Count=1) and Packet[0].Data.IsString then begin
    Challenge:=Packet[0].Data.GetString;
    Pass:=fManInfo.Password;
    if  Pass='' then Pass:=GetEnvironmentString ('LabRADPassword');
    if (Pass='') and assigned(fGetPass) then Pass:=fGetPass(self);
    if Pass='' then begin
      if not assigned(PasswordDialogForm) then
        Application.CreateForm(TPasswordDialogForm, PasswordDialogForm);
      if not PasswordDialogForm.Execute then begin
        fID:=0;
        fWelcome:='';
        fSocket.Kill;
        fSocket:=nil;
        fMsgQueue.Kill;
        fMsgQueue:=nil;
        fReqQueue.Kill;
        fReqQueue:=nil;
        fActive:=False;
        exit;
      end;
      Pass:=PasswordDialogForm.Password;
    end;
    Authenticate:=TLabRADPacket.Create(0, 1, 0, 1);
    Authenticate.AddRecord(0, 's');
    Authenticate[0].Data.SetString(MD5Digest(Challenge+Pass));
    fSocket.Request(Authenticate, OnWelcome);
   end else begin
    fSocket.Disconnect;
  end;
end;

procedure TLabRADConnection.OnWelcome(Sender: TObject; const Packet: TLabRADPacket; Data: integer);
var Login: TLabRADPacket;
begin
  if (Packet.Count=1) and Packet[0].Data.IsString then begin
    fWelcome:=Packet[0].Data.GetString;
    Login:=TLabRADPacket.Create(0, 1, 0, 1);
    Login.AddRecord(0, GetLoginData);