lina-components/Source/uWebCtrls.pas

unit uWebCtrls;

//////////////////////////////////////
///  Lina Web Controls Unit        ///
///  ****************************  ///
///  (c) 2014 Dennis Göhlert a.o.  ///
//////////////////////////////////////

interface

uses
  { Standard-Units }
  SysUtils, Classes,
  { Indy-Units }
  idHTTP, idSSLOpenSSL, idComponent,
  { Andere Package-Units }
  uBase, uSysTools;

type
  { Fehlermeldungen }
  EInvalidWebAddress = class(Exception);

type
  { Ereignisse }
  TDownloadWorkEvent = procedure(Sender: TObject; AWorkMode: TWorkMode) of object;
  TDownloadWorkBeginEvent = procedure(Sender: TObject; AWorkMode: TWorkMode) of object;
  TDownloadWorkEndEvent = procedure(Sender: TObject; AWorkMode: TWorkMode) of object;

type
  { Hilfsklassen }
  TWebProtocol = String[8];
  TWebProtocols = array[1..5] of TWebProtocol;

type
  { Hauptklassen }
  TDownload = class(TComponent)
  private
    { Private-Deklarationen }
    idHTTPObject: TidHTTP;
    SSLHandler: TIdSSLIOHandlerSocketOpenSSL;
    FAbout: TComponentAbout;
    FAddress: String;
    FProgress: Int64;
    FProgressMax: Int64;
    FSSL: Boolean;
    { Ereignisse }
    FWorkEvent: TDownloadWorkEvent;
    FWorkBeginEvent: TDownloadWorkBeginEvent;
    FWorkEndEvent: TDownloadWorkEndEvent;
    { Methoden }
    procedure SetAddress(Value: String);
    procedure idHTTPObjectWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
    procedure idHTTPObjectWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
    procedure idHTTPObjectWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
  protected
    { Protected-Deklarationen }
    procedure Prepare;
  public
    { Public-Deklarationen }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    { Fortschritt }
    function GetProgress: Int64;
    function GetProgressMax: Int64;
    function GetProgressPercent: Byte;
    { Herunterladen }
    function GetText: String;
    procedure SaveToFile(const FileName: TFileName);
    procedure SaveToStream(var Stream: TStream);
  published
    { Published-Deklarationen }
    { Ereignisse }
    property OnWork: TDownloadWorkEvent read FWorkEvent write FWorkEvent;
    property OnWorkBegin: TDownloadWorkBeginEvent read FWorkBeginEvent write FWorkBeginEvent;
    property OnWorkEnd: TDownloadWorkEndEvent read FWorkEndEvent write FWorkEndEvent;
    { Eigenschaften }
    property About: TComponentAbout read FAbout;
    property Address: String read FAddress write SetAddress;
    property SSL: Boolean read FSSL write FSSL default False;
  end;

var
  WebProtocols: TWebProtocols;
  WebProtocolsSimple: TWebProtocols;
  WebProtocolsSpecial: TWebProtocols;

  procedure InitializeProtocols;
  function ValidProtocol(const Protocol: TWebProtocol; const Protocols: TWebProtocols): Boolean;
  function StrIsURL(const S: String): Boolean;

  procedure Register;

const
  { Web-Protokolle }
  WP_HTTP: TWebProtocol = 'http://';
  WP_HTTPS: TWebProtocol = 'https://';
  WP_FTP: TWebProtocol = 'ftp://';
  WP_CALL: TWebProtocol = 'callto:';
  WP_MAIL: TWebProtocol = 'mailto:';
  { Meta-Daten }
  DownloadComponent_Name = 'Download';
  DownloadComponent_Version = 1.0;
  DownloadComponent_Copyright = 'Copyright © 2014';
  DownloadComponent_Author = 'Dennis Göhlert a.o.';

implementation

procedure Register;
begin
  RegisterComponents(ComponentsPage,[TDownload]);
end;

procedure InitializeProtocols;
begin
  WebProtocols[1] := WP_HTTP;
  WebProtocols[2] := WP_HTTPS;
  WebProtocols[3] := WP_FTP;
  WebProtocols[4] := WP_CALL;
  WebProtocols[5] := WP_MAIL;
  WebProtocolsSimple[1] := WP_MAIL;
  WebProtocolsSimple[2] := WP_CALL;
  WebProtocolsSpecial[1] := WP_HTTP;
  WebProtocolsSpecial[2] := WP_HTTPS;
  WebProtocolsSpecial[3] := WP_FTP;
end;

function ValidProtocol(const Protocol: TWebProtocol;
 const Protocols: TWebProtocols): Boolean;
var
  Index: 1..5;
begin
  InitializeProtocols;
  Result := False;
  for Index := Low(Protocols) to High(Protocols) do
  begin
    if Protocols[Index] = Protocol then
    begin
      Result := True;
      Exit;
    end;
  end;
end;

function StrIsURL(const S: String): Boolean;
{ Ein einfacher (iterativer) Parser, der überprüfen soll, ob ein String die
  Anforderungen an eine URL-Internetadresse erfüllt.
  Hier sei gesagt, dass dies KEINE vollständige Prüfung ist, sondern nur die
  wichtigsten Kriterien beinhaltet.
  Außerdem wird auch nicht überprüft, ob eine Adresse verfügbar ist. }
const
  //Diese Zeichen sind zwar erlaubt, dürfen jedoch nicht doppelt hintereinander vorkommen
  InvalidDoubleChars = [':','.'];
var
  Index: Integer;
  DomainLength: Integer;
  Protocol: TWebProtocol;
  ProtocolValid: Boolean;
  DoubleSlashRequired: Boolean;
begin
  Result := True;
  ProtocolValid := False;
  DoubleSlashRequired := False;
  DomainLength := 0;
  Protocol := '';
  for Index := 1 to Length(S) do
  begin
    if (S[Index] in InvalidDoubleChars) and
       (S[Index] = S[Index - 1]) then
    begin
      Result := False;
      Exit;
    end;
    if (S[Index] in Spaces) or
       ((S[Index] = ':') and (ProtocolValid = True)) then
    begin
      Result := False;
      Exit;
    end;
    if ProtocolValid = False then
    begin
      Protocol := Protocol + S[Index];
      if S[Index] = ':' then
      begin
        ProtocolValid := True;
        if ValidProtocol(Protocol,WebProtocolsSimple) = False then
        begin
          DoubleSlashRequired := True;
          Continue;
        end;
      end;
      if S[Index] = '/' then
      begin
        Result := False;
        Exit;
      end;
    end else
    begin
      if S[Index] = '/' then
      begin
        if DoubleSlashRequired = True then
        begin
          Protocol := Protocol + S[Index];
          DoubleSlashRequired := False;
        end else
        begin
          if S[Index - 1] = '/' then
          begin
            if ValidProtocol(Protocol + S[Index],WebProtocolsSpecial) = False then
            begin
              Result := False;
              Exit;
            end else
            begin
              Protocol := Protocol + S[Index];
            end;
          end;
        end;
      end else
      begin
        if (DoubleSlashRequired = True) or ((S[Index - 1] = '/') and (S[Index - 2] <> '/') and (DomainLength = 0)) then
        begin
          Result := False;
          Exit;
        end else
        begin
          DomainLength := DomainLength + 1;
        end;
      end;
    end;
  end;
  Result := (ProtocolValid and (DomainLength > 3));
end;

constructor TDownload.Create(AOwner: TComponent);
begin
  inherited;
  FAbout := TComponentAbout.Create(DownloadComponent_Name,DownloadComponent_Version,DownloadComponent_Copyright,DownloadComponent_Author);
  idHTTPObject := TidHTTP.Create(Self);
  idHTTPObject.HandleRedirects := True;
  idHTTPObject.OnWork := idHTTPObjectWork;
  idHTTPObject.OnWorkBegin := idHTTPObjectWorkBegin;
  idHTTPObject.OnWorkEnd := idHTTPObjectWorkEnd;
  SSLHandler := TIdSSLIOHandlerSocketOpenSSL.Create(Self);
  SSL := False;
end;

destructor TDownload.Destroy;
begin
  FAbout.Free;
  inherited;
end;

procedure TDownload.SetAddress(Value: String);
begin
  if (StrIsURL(Value) = True) or (Length(Value) = 0) then
  begin
    FAddress := Value;
  end else
  begin
    raise EInvalidWebAddress.Create('"' + Value + '" is not a valid URL address');
  end;
end;

procedure TDownload.idHTTPObjectWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
  FProgress := AWorkCount;
  if Assigned(OnWork) then
  begin
    OnWork(Self,AWorkMode);
  end;
end;

procedure TDownload.idHTTPObjectWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
  FProgressMax := AWorkCountMax;
  if Assigned(OnWorkBegin) then
  begin
    OnWorkBegin(Self,AWorkMode);
  end;
end;

procedure TDownload.idHTTPObjectWorkEnd(ASender: TObject; AWorkMode: TWorkMode);
begin
  if Assigned(OnWorkEnd) then
  begin
    OnWorkEnd(Self,AWorkMode);
  end;
end;

function TDownload.GetProgress: Int64;
begin
  Result := FProgress;
end;

function TDownload.GetProgressMax: Int64;
begin
  Result := FProgressMax;
end;

function TDownload.GetProgressPercent: Byte;
begin
  if FProgressMax > 0 then
  begin
    Result := (FProgress div FProgressMax) * 100;
  end else
  begin
    { Bei aktivierter SSL-Verschlüsselung wird keine insgesamte Dateigröße
      übermittelt. Deshalb wird hier eine 0 angegeben, um das Ergebnis nicht
      undefiniert zu lassen. }
    Result := 0;
  end;
end;

function TDownload.GetText: String;
begin
  Prepare;
  Result := idHTTPObject.Get(Address);
end;

procedure TDownload.SaveToFile(const FileName: TFileName);
var
  FS: TFileStream;
begin
  Prepare;
  FS := TFileStream.Create(FileName,fmCreate or fmShareDenyWrite);
  try
    idHTTPObject.Get(Address,FS);
  finally
    FS.Free;
  end;
end;

procedure TDownload.SaveToStream(var Stream: TStream);
begin
  Prepare;
  idHTTPObject.Get(Address,Stream);
end;

procedure TDownload.Prepare;
begin
  if SSL = True then
  begin
    idHTTPObject.IOHandler := SSLHandler;
  end else
  begin
    idHTTPObject := nil;
  end;
end;

end.