{******************************************************************}
{ InetUtil.pas                                                     }
{                                                                  }
{ Author    : A.Nasir Senturk                                      }
{ Home Page : http://www.shenturk.com                              }
{ Email     : shenturk@gmail.com                                   }
{                                                                  }
{ Date      : 22.12.2006                                           }
{                                                                  }
{ Sizden iki şey rica edicem:                                      }
{ 1. Lutfen bu baslik kismini kaldirmayiniz.                       }
{ 2. Mumkunse bagis yapiniz.                                       }
{ *****************************************************************}

unit InetUtil;

interface

uses Windows, Messages, SysUtils, Variants, Classes, WinInet;

const
  MAX_STRINGS = 12;

var
  CallbackProc: INTERNET_STATUS_CALLBACK = nil;

type

  TResponse = class;

  { TRequest }
  TRequest = class(TObject)
  private
    FResponse: TResponse;
    FContent: string;
    FVariables: array[0..MAX_STRINGS - 1] of string;
    FInternet: HINTERNET;
    FContext: Pointer;
  protected
    function GetVariable(const Index: Integer): string;
    procedure SetVraiable(const Index: Integer; const Value: string);
  public
    constructor Create;
    destructor Destroy; override;
    function OpenInternet: Boolean;
    procedure CloseInternet;
    property Context: Pointer read FContext write FContext;
    function SendRequest(InetHandle: HINTERNET): Integer;
    property Host: string index 0 read GetVariable write SetVraiable;
    property URL: string index 1 read GetVariable write SetVraiable;
    property Method: string index 2 read GetVariable write SetVraiable;
    property Cookie: string index 3 read GetVariable write SetVraiable;
    property Content: string read FContent write FContent;
    property ContentType: string index 4 read GetVariable write SetVraiable;
    property ContentLength: string index 5 read GetVariable write SetVraiable;
    property Accept: string index 6 read GetVariable write SetVraiable;
    property Connection: string index 7 read GetVariable write SetVraiable;
    property Version: string index 8 read GetVariable write SetVraiable;
    property Response: TResponse read FResponse;
  end;

  { TResponse }
  TResponse = class(TObject)
  private
    FRequestHandle: HINTERNET;
    FVariables: array[0..MAX_STRINGS - 1] of string;
    FContentStream: TMemoryStream;
    function GetVariable(const Index: Integer): string;
    procedure SetVraiable(const Index: Integer; const Value: string);
    function GetContent: string;
  public
    constructor Create(RequestHandle: HINTERNET);
    destructor Destroy; override;
    property SetCookie: string index 4 read GetVariable write SetVraiable;
    property ContentStream: TMemoryStream read FContentStream;
    property Content: string read GetContent;
  end;


implementation

{ TRequest }

procedure TRequest.CloseInternet;
begin
  if FInternet <> nil then
    if InternetCloseHandle(FInternet) then
      FInternet := nil;
end;

constructor TRequest.Create;
begin
  inherited Create;
  Method := 'GET';
  Version := 'HTTP/1.1';
  FResponse := TResponse.Create(nil);
end;

destructor TRequest.Destroy;
begin
  FResponse.Free;
  inherited Destroy;
end;

function TRequest.GetVariable(const Index: Integer): string;
begin
  if (Index >= 0) and (Index < MAX_STRINGS) then
    Result := FVariables[Index]
  else Result := '';
end;

function TRequest.OpenInternet: Boolean;
begin
  CloseInternet;
  FInternet := InternetOpen('Jadelax Explorer v1.0',
    INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  Result := FInternet <> nil;
  if Result and Assigned(CallbackProc) then
    InternetSetStatusCallback(FInternet, CallbackProc);
end;

function TRequest.SendRequest(InetHandle: HINTERNET): Integer;
var
  Headers: string;
  hConnect, hRequest: HINTERNET;
  Buffer: array[0..8191] of Char;
  dwNumberOfBytes, dwAvailable: DWORD;
  ReadResult: BOOL;

  procedure AddHeaderItem(const Item, FormatStr: string);
  begin
    if Item <> '' then
      Headers := Headers + Format(FormatStr, [Item]);
  end;

  function GetHttpVariable(Index: Integer): string;
  var
    Buffer: array[0..1023] of Char;
    dwLength, dwReserved: DWORD;
  begin
    Result := '';
    dwLength := SizeOf(Buffer);
    dwReserved := 0;
    if HttpQueryInfo(hRequest, Index, @Buffer, dwLength, dwReserved) then
    begin
      SetString(Result, Buffer, dwLength);
      Result := PChar(Result);
    end;
  end;

begin

  Result := -1;

  if not Assigned(InetHandle) then Exit;

  hConnect := InternetConnect(InetHandle, PChar(Host),
    INTERNET_DEFAULT_HTTP_PORT, nil, nil, INTERNET_SERVICE_HTTP, 0, Cardinal(FContext));

  if hConnect <> nil then
  begin

    try
      hRequest := HttpOpenRequest(hConnect, PChar(Method), PChar(URL),
        PChar(Version), nil, nil, INTERNET_FLAG_HYPERLINK, Cardinal(FContext));

      if hRequest <> nil then
      begin
        try

          AddHeaderItem(Accept, 'Accept: %s'#13#10);
          AddHeaderItem(Cookie, 'Cookie: %s'#13#10);
          AddHeaderItem(Connection, 'Connection: %s'#13#10);
          AddHeaderItem(ContentType, 'Content-Type: %s'#13#10);

          if HttpSendRequest(hRequest, PChar(Headers), Length(Headers),
            PChar(Content), Length(Content)) then
          begin

            Response.SetCookie := GetHttpVariable(HTTP_QUERY_SET_COOKIE);

            repeat
              if InternetQueryDataAvailable(hRequest, dwAvailable, 0, Cardinal(FContext)) then
              begin
                FillChar(Buffer, SizeOf(Buffer), 0);
                ReadResult := InternetReadFile(hRequest, @Buffer, SizeOf(Buffer), dwNumberOfBytes);
                if (not ReadResult) and (GetLastError() <> ERROR_IO_PENDING) then
                begin
                  Result := -1;
                  Break;
                end;
                Response.ContentStream.Write(Buffer, dwNumberOfBytes);
              end
              else begin
                if GetLastError() <> ERROR_IO_PENDING then
                begin
                  Result := -1;
                  Break;
                end;
              end;
            until dwNumberOfBytes = 0;
            Result := 0;
          end;
        {
        HttpEndRequest(hRequest, nil, 0, 0);
        }
        finally
          InternetCloseHandle(hRequest);
        end;
      end;
    finally
      InternetCloseHandle(hConnect);
    end;

  end;

end;

procedure TRequest.SetVraiable(const Index: Integer; const Value: string);
begin
  if (Index >= 0) and (Index < MAX_STRINGS) then
    FVariables[Index] := Value;
end;

{ TResponse }

constructor TResponse.Create(RequestHandle: HINTERNET);
begin
  inherited Create;
  FRequestHandle := RequestHandle;
  FContentStream := TMemoryStream.Create;
end;

destructor TResponse.Destroy;
begin
  FContentStream.Free;
  inherited Destroy;
end;

function TResponse.GetContent: string;
var
  Stream: TStringStream;
begin
  Stream := TStringStream.Create('');
  try
    ContentStream.SaveToStream(Stream);
    Result := Stream.DataString;
  finally
    Stream.Free;
  end;
end;

function TResponse.GetVariable(const Index: Integer): string;
begin
  if (Index >= 0) and (Index < MAX_STRINGS) then
    Result := FVariables[Index]
  else Result := '';
end;

procedure TResponse.SetVraiable(const Index: Integer; const Value: string);
begin
  if (Index >= 0) and (Index < MAX_STRINGS) then
    FVariables[Index] := Value;
end;

end.