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{v0.68}, IdComponent, IdIPWatch, Pipes{/v0.68};

type
  TWebClients = class;

  TWebClient = class(TComponent)
  private
    FChannelIndex: integer;
    FAcq: integer;
    FSrc: TStringList;// html source beeing built
    FChl: TStringList; // channel list
    FCmdID: integer;
    {v0.68}
    FRefresh: integer;
    FOSVersion:OSVERSIONINFO;
      { initialized upon call to UlanConfigRead
        DWORD dwOSVersionInfoSize;
        DWORD dwMajorVersion;
        DWORD dwMinorVersion;
        DWORD dwBuildNumber;
        DWORD dwPlatformId;
            VER_PLATFORM_WIN32s	        Win32s on Windows 3.1.
            VER_PLATFORM_WIN32_WINDOWS	Win32 on Windows 95.
            VER_PLATFORM_WIN32_NT	        Win32 on Windows NT.
        TCHAR szCSDVersion[ 128 ];
      }
    FPipeClient: TPipeClient;
    {/v0.68}
    function GetClientAddr: string;
    procedure SetClientAddr(AAddr: string);
    function GetWebClients: TWebClients;
    function GetImageURL: string;
    function GetImageFileName: string;
    {v0.68}
    function GetImageFileDir: string;
    function GetActionURLPath: string;
    function GetActionURLPars: string;
    {/v0.68}

    {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}
    {v0.68}
    { SendMessage to CHROMuLAN.exe for Win95/98, use pipes for NT platforms }
    procedure AskChromulan(culMsg: TculMsg; var cmd: shortstring);
    {/v0.68}

  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;
    {v0.68}
    { Directory where the chromatogram image will be placed, including final slash
      (backslash). }
    property ImageFileDir: string read GetImageFileDir;
    { Returns 'http://..../CuLCGI.exe' }
    property ActionURLPath: string read GetActionURLPath;
    { Returns parameter part of the final url created upon submitting form, e.g.
      '?acq=0&amp;channel=0' }
    property ActionURLPars: string read GetActionURLPars;
    {/v0.68}
    //procedure AfterConstruction; override;

  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;
    {v0.68}
    { How often (in seconds) should be the web page requested again from the server
      (used only if FAcq=2 for updating the chromatogram). }
    property Refresh: integer read FRefresh write FRefresh;
    {/v0.68}
  end;

  TWebClients = class(TComponent)
  private
    FCulSubDir: string;
    FHtmlRootDir: string;
    FCulExePathName: string;
    //FSharedMem: TSharedMem;
    FLocalHost: string;

    FCuLMessage: integer;
    function GetHtmlCulDir: string;
    {v0.68}
    function GetLocalHost: string;
    {/v0.68}
  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;
    {v0.68}
    { Name of the host where is the web server running }
    property LocalHost: string read GetLocalHost;
    {/v0.68}
  published
    { Root directory for documents of web server including final slash (backslash) }
    property HtmlRootDir: string read FHtmlRootDir write FHtmlRootDir;
    { Subdirectory in HtmlRootDir where CHROMuLAN related static html files
      or images  should be placed. Without any slash or backslash. }
    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;
    {v0.68}
    { Name of the host where is the web server running }
    {/v0.68
    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;
  FRefresh := 20;
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>');
  if (FAcq = acqUpdate) then begin
    if FRefresh <> 0 then begin
      if FRefresh < 0 then
        FRefresh := 0
      else if FRefresh < 5 then
        FRefresh := 5;
    end;
    if FRefresh <> 0 then begin
      Add('<meta http-equiv="refresh" content="' + IntToStr(FRefresh) +
      '; url=' + ActionURLPath + ActionURLPars + '">');
    end;
  end;
  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>' +
   {v0.68}
   ' Refresh [s]: <input id="refresh" name="refresh" value="' + IntToStr(FRefresh) + '" />' +
   {/v0.68}
   '<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;

procedure TWebClient.AskChromulan(culMsg: TculMsg; var cmd: shortstring);
var
  bw: integer;
  br: integer;
  s: shortstring;
begin
{ulanglob winutl}
  try
    FOSVersion.dwOSVersionInfoSize := sizeof(FOSVersion);
    GetVersionEx(FOSVersion);
    if FOSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then begin
      case culMsg of
        culChannelUpdate: begin
          s := 'channelupdate ' + cmd;
        end;
      else
        cmd := 'ER unsupported culMsg: ' + IntToStr(culMsg);
        exit;
      end;
      FPipeClient := TPipeClient.Create(nil);
      try
        FPipeClient.PipeName := CHROMuLANName;
        FPipeClient.Active := true;
        FPipeClient.Write(s[1], length(s), bw);
        FPipeClient.Read(cmd[1], sizeof(cmd) - 1, br);
        SetLength(cmd, br);
      finally
        FreeAndNil(FPipeClient);
      end;
    end else begin
      SendMessage(HWND_BROADCAST, WebClients.FCuLMessage, culChannelUpdate, integer(@cmd));
    end;
  except
    on E: Exception do begin
      cmd := 'ER ' + E.Message;
    end;
  end;
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;
      {v0.68}
      if n = 'refresh' then begin
        val(v, FRefresh, code);
      end;
      {/v0.68}
    end;
  end;

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

    addHead;

    {v0.68}
    Add('<form name="CHROMuLANForm" id="CHROMuLANForm" method="get" ' +
       'action="' + ActionURLPath + '">');
    {/v0.68
    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;
    {v0.68}
    AskChromulan(culChannelUpdate, a^);
    {/v0.68
    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      //createfile
      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
          {v0.68}
          if not CheckDirExists(ImageFileDir) then begin
            Add('!!! could not create directory for the image file: ' + ImageFileDir + ' !!!');
          end else
          {/v0.68}
          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;
    end;
    Add('</form>');
    AddFoot;

    fn := GetTempFileName;
    FSrc.SaveToFile(fn);
    Result := fn;
  finally
    FChl.Free;
    FSrc.Free;
    FChl := nil;
    FSrc := nil;
  end;
end;
{v0.68}
function TWebClient.GetActionURLPath: string;
begin
  Result := 'http://' + WebClients.LocalHost + '/cgi-bin/CuLCGI.exe';
end;

function TWebClient.GetActionURLPars: string;
begin
  Result := '?' +
    'cmdid='+ IntToStr(FCmdID) +
    '&amp;channel=' + IntToStr(FChannelIndex) +
    '&amp;acq='+ IntToStr(FAcq) +
    '&amp;refresh=' + IntToStr(FRefresh);
end;
{/v0.68}

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

function TWebClient.GetImageFileDir: string;
begin
  Result := WebClients.HtmlCulDir;
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';
  {v0.68}{/v0.68 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;

function TWebClients.GetLocalHost: string;
var
  ic: TIdComponent;
  ii: TIdIpWatch;{idUDPClient idipwatch}
begin
  if FLocalHost = '' then begin
    ii := TIdIpWatch.Create(nil);
    try
      //ii.ForceCheck;
      FLocalHost := ii.LocalIP;
    finally
      ii.free;
    end;
    {ic := TIdComponent.Create(nil);
    try
      FLocalHost := ic.LocalName;
    finally
      ic.Free;
    end;
    }
  end;
  Result := FLocalHost;
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.
