unit WebControlu;
{ Controlling Chromulan through web browser interface }
{
  (C) 2000 - 2003 Jindrich Jindrich, Pavel Pisa, PiKRON Ltd.

  Originators of the CHROMuLAN project:

  Jindrich Jindrich - http://jindrich.com
                      http://chromulan.org
                      software developer, project coordinator
  Pavel Pisa        - http://cmp.felk.cvut.cz/~pisa
                      embeded software developer
  PiKRON Ltd.       - http://www.pikron.com
                      project initiator, sponsor, instrument developer

  The CHROMuLAN project is distributed under the GNU General Public Licence.
  See file COPYING for details.

  Originators reserve the right to use and publish sources
  under different conditions too. If third party contributors
  do not accept this condition, they can delete this statement
  and only GNU license will apply.
}

interface
uses
  Windows, SysUtils, Classes,
  Fileu, WinUtl, PropUtl, Attrib,
  UlanType, CuLSharedMemu, Images;

type
  TWebClients = class;

  TWebClient = class(TComponent)
  private
    FChannelIndex: integer;
    FAcq: integer;
    FSrc: TStringList;// html source beeing built
    FChl: TStringList; // channel list
    FCmdID: integer;
    function GetClientAddr: string;
    procedure SetClientAddr(AAddr: string);
    function GetWebClients: TWebClients;
    function GetImageURL: string;
    function GetImageFileName: string;

    {v0.67}
    { procedures for building the html file to FSrc }
    procedure Checked(onoff:boolean; var st: string);
    { Add line to FSrc }
    procedure Add(const aline: string);
    { Add HTML start (html, head, body) tags }
    procedure AddHead;
    { Add code for channel selection, return false if no channels found }
    function AddChannelList: boolean;
    { Add code for selection of acquisition action }
    procedure AddAcq;
    { Add closing part of HTML document (/body, /html) }
    procedure AddFoot;
    {/procedures ... FSrc }
    procedure ImageErase;
    function GetImgSuffix: string;
    {/v0.67}
  public
    constructor Create(AOwner: TComponent); override;
    { Creates HTML file that contains the necessary form/buttons/inputs
      to control chromulan (according to ACmd). Returns its filename. }
    function MakeHTMLFile(const ACmd: string): string;
    { Gets converted to Name (dots replaced with underscore, starts with IP) }
    property ClientAddr: string read GetClientAddr write SetClientAddr;
    property WebClients: TWebClients read GetWebClients;
    property ImageURL: string read GetImageURL;
    property ImageFileName: string read GetImageFileName;
    property ImgSuffix: string read GetImgSuffix;
  published
    { What channel was using this WebClient last time }
    property ChannelIndex: integer read FChannelIndex write FChannelIndex;
    { What acquisition action was requested by this client last time }
    property Acq: integer read FAcq write FAcq;
    property CmdID: integer read FCmdID write FCmdID;
  end;

  TWebClients = class(TComponent)
  private
    FCulSubDir: string;
    FHtmlRootDir: string;
    FCulExePathName: string;
    //FSharedMem: TSharedMem;
    FLocalHost: string;
    FCuLMessage: integer;
    function GetHtmlCulDir: string;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function FindOrAdd(const AClientAddr: string): TWebClient;
    { Full local path to the directory (subdir in HtmlRootDir) where images
      or other static files should be placed. }
    property HtmlCulDir: string read GetHtmlCulDir;
  published
    { Root directory for documents of web server. }
    property HtmlRootDir: string read FHtmlRootDir write FHtmlRootDir;
    { Subdirectory in HtmlRootDir where CHROMuLAN related static html files
      or images  should be placed. }
    property CulSubDir: string read FCulSubDir write FCulSubDir;
    { Full file name of CHROMuLAN executable. Used to start it or find out if
      it is running. }
    property CulExePathName: string read FCulExePathName write FCulExePathName;
    { Name of the host where is the web server running }
    property LocalHost: string read FLocalHost write FLocalHost;
  end;
  {/TWebClients}

function WebClients: TWebClients;


{ This function can be called from CGI module (using SendMessage CHROMuLANMessage?) -
  giving address of the web
  client requesting the command cmd. Returns name of a unique temporary file
  that contains  html code that should be returned to the web client. The
  caller should erase the file.

  cmd:
    'acq=1 channel=x filename=y updateInterval=z'
       - start acquisition on the channel x
         x is integer 0 -> max channel index (in channels browser)
       - store the acquired data to filename y
       - request update (generated by JavaScript from the web client) every
         z second
    'acq=2 [channel=x]'
       requesting update of the chromatogram (snapshot) on running channel x
    'acq=0 [channel=x]'
       stop acquisition on the channel x
    ''
      no command - returned status of all channels, allows selection/control
      of them

  Attributes name=value pairs can be separated by ' ', '&' or '&amp;'.
}
function WebRequestAnswer(const AClientAddr: shortstring; const cmd: shortstring): shortstring; export;

implementation
//uses
//  Channelsu;

function ClientAddrToName(const AAddr: string): string;
begin
  Result := 'IP' + StringReplace(AAddr, '.', '_', [rfReplaceAll]);
end;

function NameToClientAddr(const AName: string): string;
begin
  Result := StringReplace(copy(AName, 3, length(AName)), '_', '.', [rfReplaceAll]);
end;

{TWebClient.}
constructor TWebClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FChannelIndex := -1;
  FAcq := acqStart;
end;

function TWebClient.GetWebClients: TWebClients;
begin
  Result := TWebClients(Owner);
end;

function TWebClient.GetClientAddr: string;
begin
  Result := NameToClientAddr(Name);
end;

procedure TWebClient.SetClientAddr(AAddr: string);
begin
  Name := ClientAddrToName(AAddr);
end;

procedure TWebClient.Checked(onoff:boolean; var st: string);
begin
  if onoff then
    st := 'checked="checked"'
  else
    st := '';
end;

procedure TWebClient.Add(const aline: string);
begin
  FSrc.Add(aline);
end;

procedure TWebClient.AddHead;
begin
  Add('<html><head>');
  Add('<title>CHROMuLAN Control Page for Web Clients</title>');
  Add('</head><body>');
end;

function TWebClient.AddChannelList: boolean;
var
  i: integer;
  s: string;
begin
  Result := false;
  if ParseLine([','], CuLSharedMem^.ChannelList, FChl) then begin
    Add('<strong>Select Channel</strong> <br />');
    Add('<select id="channel" name="channel">');
    for i := 0 to FChl.Count - 1 do begin
      s := '<option value="' + IntToStr(i) + '" ';
      if i = ChannelIndex then
        s := s + 'selected="selected" ';
      Add(s + '>' + FChl[i] + '</option>');
    end;
    Add('</select><br />');
    Result := true;
  end;
end;

procedure TWebClient.AddAcq;
var s: string;
begin
  Add('<strong>Select acquisition action</strong><br />');
  Checked(FAcq = acqStart, s);
  Add('<input id="acq" name="acq" type="radio" value="1" ' + s + '>Start</input><br />');
  Checked(FAcq = acqUpdate, s);
  Add('<input id="acq" name="acq" type="radio" value="2" ' + s + '>Update</input><br />');
  Checked(FAcq = acqStop, s);
  Add('<input id="acq" name="acq" type="radio" value="0" ' + s + '>Stop</input><br />');
end;

procedure TWebClient.AddFoot;
begin
  Add('</body></html>');
end;

procedure TWebClient.ImageErase;
begin
  DeleteFile(ImageFileName);
end;

function TWebClient.MakeHTMLFile(const ACmd: string): string;
{  ACmd:
    'acq=1 channel=x filename=y updateInterval=z'
       - start acquisition on the channel x
         x is integer 0 -> max channel index (in channels browser)
       - store the acquired data to filename y
       - request update (generated by JavaScript from the web client) every
         z second
    'acq=2 [channel=x]'
       requesting update of the chromatogram (snapshot) on running channel x
    'acq=0 [channel=x]'
       stop acquisition on the channel x
    ''
      no command - returned status of all channels, allows selection/control
      of them
}
var
  fn: shortstring;
  i: integer;
  s: string;
  code: integer;

  acq, channel: string;
  cid: string;
  line, n, v: string;


  a: PShortString;

  procedure parseCmd;
  begin
    line := ACmd;
    acq := '';
    channel := '';
    while GetNextAttrib(line, n, v) do begin
      if n = 'channel' then begin
        channel := v;
        val(channel, FChannelIndex, code);
      end;
      if n = 'acq' then begin
        acq := v;
        val(acq, FAcq, code);
        if code <> 0 then begin
          if acq = 'start' then
            FAcq := acqStart
          else if acq = 'stop' then
            FAcq := acqStop
          else if acq = 'update' then
            FAcq := acqUpdate;
        end;
      end;
      if n = 'cmdid' then begin
        val(v, FCmdID, code);
        ImageErase;
        inc(FCmdID);
      end;
    end;
  end;

begin
  parseCmd;
  try
    FChl := TStringList.Create;
    FSrc := TStringList.Create;

    addHead;

    Add('<form name="CHROMuLANForm" id="CHROMuLANForm" method="get" ' +
      'action="http://' + WebClients.LocalHost + '/cgi-bin/CuLCGI.exe" >');
    Add('ClientAddr: ' + ClientAddr + ' Last command: ' + ACmd + '<br />');
    Add('<input name="cmdid" type="hidden" value="' + IntToStr(FCmdID) + '" />');


    a := CuLSharedMemGetStr;
    a^ := ACmd;
    SendMessage(HWND_BROADCAST, WebClients.FCuLMessage, culChannelUpdate, integer(a));
    if pos('OK', a^) <> 1 then begin
      if pos('ER ', a^) = 1 then begin
        Add('CHROMuLAN Error: ' + a^);
      end else begin
        Add('CHROMuLAN is not running on the server. Start it first.');
      end;
    end else begin
      if AddChannelList then begin
        AddAcq;
        Add('<hr />');
        Add('<input type="submit" />');
        Add('<hr />');

        // extract file name of BMP file (snapshot of the active channel chromatogram)
        // from the answer from the CHROMuLAN:
        fn := copy(a^, 4, length(a^));

        if FileExists(fn) then begin
          if BMPToPNG(fn, ImageFileName) then begin
            Add('<img src="' + ImageURL + '" alt="chromatogram" />');
            DeleteFile(fn);
          end else begin
            Add('!!! Failed to convert Chromatogram bmp image ' + fn + ' to png format (' +
              ImageFileName + ') !!!');
          end;
        end;
      end;
    end;
    Add('</form>');
    AddFoot;

    fn := GetTempFileName;
    FSrc.SaveToFile(fn);
    Result := fn;
  finally
    FChl.Free;
    FSrc.Free;
    FChl := nil;
    FSrc := nil;
  end;
end;

function TWebClient.GetImageURL: string;
begin
  Result := 'http://' + WebClients.LocalHost + '/' + WebClients.CulSubDir + '/'
    + Name + ImgSuffix + '.png';
end;

function TWebClient.GetImageFileName: string;
begin
  Result := WebClients.HtmlCuLDir + Name + ImgSuffix + '.png';
end;

function TWebClient.GetImgSuffix: string;
begin
  Result := '_' + IntToStr(FCmdID);
end;

{/TWebClient.}

{TWebClients.}
constructor TWebClients.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FHtmlRootDir := 'C:\Program Files\Apache Group\Apache\htdocs\';
  FCulExePathName := 'C:\Program Files\CHROMuLAN\CHROMuLAN.exe';
  FCulSubDir := 'CuL';
  FLocalHost := 'www.jindrich.com';
{  FSharedMem := TSharedMem.Create(self);
  FSharedMem.MemName := CHROMuLANName;
  FSharedMem.MemSize := sizeof(TCuLGlobalMem);
  FSharedMem.Active := true;}
  FCuLMessage := RegisterWindowMessage(CHROMuLANName);
  ClassReadWriteIniFile(Self, 0, '', true);
end;

destructor TWebClients.Destroy;
begin
  ClassReadWriteIniFile(Self, 0, '', false);
  inherited Destroy;
end;

//ulfobju createmutex postmessage sendmessage createfilemapping

function TWebClients.FindOrAdd(const AClientAddr: string): TWebClient;
var c: TComponent;
begin
  c := FindComponent(ClientAddrToName(AClientAddr));
  if c = nil then begin
    c := TWebClient.Create(Self);
    TWebClient(c).ClientAddr := AClientAddr;
  end;
  Result := TWebClient(c);
end;

function TWebClients.GetHtmlCulDir: string;
begin
  Result := FHtmlRootDir + FCulSubDir + '\';
end;
{/TWebClients.}

var
  FWebClients: TWebClients;

function WebClients: TWebClients;
begin
  if FWebClients = nil then
    FWebClients := TWebClients.Create(nil);
  Result := FWebClients;
end;

function WebRequestAnswer(const AClientAddr: shortstring; const cmd: shortstring): shortstring;
var
  wc: TWebClient;
  s: string;
begin
  s := StringReplace(cmd, '&amp;', ' ', [rfReplaceAll]);
  s := StringReplace(s, '&', ' ', [rfReplaceAll]);
  wc := WebClients.FindOrAdd(AClientAddr);
  Result := wc.MakeHTMLFile(s);
end;

initialization
  FWebClients := nil;
finalization
  FWebClients.Free;
end.
