{*------------------------------------------------------------------------------
  Simple HTTP downloads using functions from wininet.dll library

  @Author CCRDude
  @Version 2006/07/01  Stripped dependencies for making it available.
  @Todo FTP etc.
-------------------------------------------------------------------------------}
unit ceWinINet;

{$IFDEF FPC}
{$mode objfpc}{$H+}
{$ENDIF FPC}

interface

uses Windows, Classes, SysUtils;

type
   TInternetHandle = THandle;

const
   INTERNET_INVALID_PORT_NUMBER = 0;
   INTERNET_DEFAULT_FTP_PORT    = 21;
   INTERNET_DEFAULT_GOPHER_PORT = 70;
   INTERNET_DEFAULT_HTTP_PORT   = 80;
   INTERNET_DEFAULT_HTTPS_PORT  = 443;
   INTERNET_DEFAULT_SOCKS_PORT  = 1080;

   INTERNET_FLAG_ASYNC      = $10000000;
   INTERNET_FLAG_FROM_CACHE = $01000000;
   INTERNET_FLAG_OFFLINE    = INTERNET_FLAG_FROM_CACHE;

   INTERNET_OPEN_TYPE_PRECONFIG                   = 0;
   INTERNET_OPEN_TYPE_DIRECT                      = 1;
   INTERNET_OPEN_TYPE_PROXY                       = 3;
   INTERNET_OPEN_TYPE_PRECONFIG_WITH_NO_AUTOPROXY = 4;

   INTERNET_SERVICE_FTP    = 1;
   INTERNET_SERVICE_GOPHER = 2;
   INTERNET_SERVICE_HTTP   = 3;

   HTTP_QUERY_ALLOW                  =   7;
   HTTP_QUERY_CONNECTION             =  23;
   HTTP_QUERY_ACCEPT                 =  24;
   HTTP_QUERY_ACCEPT_CHARSET         =  25;
   HTTP_QUERY_ACCEPT_ENCODING        =  26;
   HTTP_QUERY_ACCEPT_LANGUAGE        =  27;
   HTTP_QUERY_AUTHORIZATION          =  28;
   HTTP_QUERY_ACCEPT_RANGES          =  42;
   HTTP_QUERY_AGE                    =  48;
   HTTP_QUERY_CACHE_CONTROL          =  49;
   HTTP_QUERY_CONTENT_BASE           =  50;
   HTTP_QUERY_CONTENT_ENCODING       =  29;
   HTTP_QUERY_CONTENT_DISPOSITION    =  47;
   HTTP_QUERY_CONTENT_ID             =   3;
   HTTP_QUERY_CONTENT_DESCRIPTION    =   4;
   HTTP_QUERY_CONTENT_LANGUAGE       =   6;
   HTTP_QUERY_CONTENT_LENGTH         =   5;
   HTTP_QUERY_CONTENT_LOCATION       =  51;
   HTTP_QUERY_CONTENT_MD5            =  52;
   HTTP_QUERY_CONTENT_RANGE          =  53;
   HTTP_QUERY_CONTENT_TYPE           =   1;
   HTTP_QUERY_COOKIE                 =  44;
   HTTP_QUERY_COST                   =  15;
   HTTP_QUERY_CUSTOM                 =  65535;
   HTTP_QUERY_DATE                   =   9;
   HTTP_QUERY_DERIVED_FROM           =  14;
   HTTP_QUERY_ECHO_HEADERS           =  73;
   HTTP_QUERY_ECHO_HEADERS_CRLF      =  74;
   HTTP_QUERY_ECHO_REPLY             =  72;
   HTTP_QUERY_ECHO_REQUEST           =  71;
   HTTP_QUERY_ETAG                   =  54;
   HTTP_QUERY_EXPECT                 =  68;
   HTTP_QUERY_EXPIRES                =  10;
   HTTP_QUERY_FORWARDED              =  30;
   HTTP_QUERY_FROM                   =  31;
   HTTP_QUERY_HOST                   =  55;
   HTTP_QUERY_IF_MATCH               =  56;
   HTTP_QUERY_IF_MODIFIED_SINCE      =  32;
   HTTP_QUERY_IF_NONE_MATCH          =  57;
   HTTP_QUERY_IF_RANGE               =  58;
   HTTP_QUERY_IF_UNMODIFIED_SINCE    =  59;
   HTTP_QUERY_LAST_MODIFIED          =  11;
   HTTP_QUERY_LINK                   =  16;
   HTTP_QUERY_LOCATION               =  33;
   HTTP_QUERY_MAX                    =  78;
   HTTP_QUERY_MAX_FORWARDS           =  60;
   HTTP_QUERY_MESSAGE_ID             =  12;
   HTTP_QUERY_MIME_VERSION           =   0;
   HTTP_QUERY_ORIG_URI               =  34;
   HTTP_QUERY_PRAGMA                 =  17;
   HTTP_QUERY_PROXY_AUTHENTICATE     =  41;
   HTTP_QUERY_PROXY_AUTHORIZATION    =  61;
   HTTP_QUERY_PROXY_CONNECTION       =  69;
   HTTP_QUERY_PUBLIC                 =   8;
   HTTP_QUERY_RANGE                  =  62;
   HTTP_QUERY_RAW_HEADERS            =  21;
   HTTP_QUERY_RAW_HEADERS_CRLF       =  22;
   HTTP_QUERY_REFERER                =  35;
   HTTP_QUERY_REFRESH                =  46;
   HTTP_QUERY_REQUEST_METHOD         =  45;
   HTTP_QUERY_RETRY_AFTER            =  36;
   HTTP_QUERY_SERVER                 =  37;
   HTTP_QUERY_SET_COOKIE             =  43;
   HTTP_QUERY_STATUS_CODE            =  19;
   HTTP_QUERY_STATUS_TEXT            =  20;
   HTTP_QUERY_TITLE                  =  38;
   HTTP_QUERY_TRANSFER_ENCODING      =  63;
   HTTP_QUERY_UNLESS_MODIFIED_SINCE  =  70;
   HTTP_QUERY_UPGRADE                =  64;
   HTTP_QUERY_URI                    =  13;
   HTTP_QUERY_USER_AGENT             =  39;
   HTTP_QUERY_VARY                   =  65;
   HTTP_QUERY_VERSION                =  18;
   HTTP_QUERY_VIA                    =  66;
   HTTP_QUERY_WARNING                =  67;
   HTTP_QUERY_WWW_AUTHENTICATE       =  40;

function InternetOpen(lpszAgent: PAnsiChar;
                      dwAccessType: DWord;
                      lpszProxyName, lpszProxyBypass: PAnsiChar;
                      dwFlags: DWord): TInternetHandle;
         stdcall; external 'wininet.dll' name 'InternetOpenA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/internetopen.asp

function InternetCloseHandle(hInternet: TInternetHandle): boolean;
         stdcall; external 'wininet.dll';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/internetclosehandle.asp

function InternetConnect(hInternet: TInternetHandle;
                         lpszServerName: PAnsiChar;
                         nServerPort: Word; //  INTERNET_PORT
                         lpszUsername, lpszPassword: PAnsiChar;
                         dwService, dwFlags: DWord;
                         var dwContext: DWord): TInternetHandle;
         stdcall; external 'wininet.dll' name 'InternetConnectA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/internetconnect.asp

function InternetOpenUrl(hInternet: TInternetHandle;
                         lpszUrl, lpszHeaders: PAnsiChar;
                         dwHeadersLength, dwFlags: DWord;
                         var dwContext: Dword): TInternetHandle;
         stdcall; external 'wininet.dll' name 'InternetOpenUrlA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/internetopenurl.asp

function InternetReadFile(hFile: TInternetHandle;
                          lpBuffer: Pointer;
                          dwNumberOfBytesToRead: Dword;
                          var lpdwNumberOfBytesRead: DWord): boolean;
         stdcall; external 'wininet.dll' name 'InternetReadFile';

// http://msdn.microsoft.com/library/en-us/wininet/wininet/internetreadfile.asp

function HttpOpenRequest(hConnect: TInternetHandle;
                         lpszVerb, lpszObjectName, lpszVersion, lpszReferer: PChar;
                         lplpszAcceptTypes: Pchar;
                         dwFlags: DWord;
                         var dwContext: DWord): TInternetHandle;
         stdcall; external 'wininet.dll' name 'HttpOpenRequestA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/httpopenrequest.asp

function HttpSendRequest(hRequest: TInternetHandle;
                         lpszHeaders: PChar;
                         dwHeadersLength: DWord;
                         lpOptional: Pointer;
                         dwOptionalLength: DWord): boolean;
         stdcall; external 'wininet.dll' name 'HttpSendRequestA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/httpsendrequest.asp

function HttpQueryInfo(hRequest: TInternetHandle;
                       dwInfoLevel: DWord;
                       var lpvBuffer;
                       var lpdwBufferLength: DWord;
                       var lpdwIndex: Dword): boolean;
         stdcall; external 'wininet.dll' name 'HttpQueryInfoA';
// http://msdn.microsoft.com/library/en-us/wininet/wininet/httpqueryinfo.asp

type

   {$IFDEF WinCE}
   {$DEFINE Unicode}
   PStringsChar = PWideChar;
   StringsString = WideString;
   {$ELSE WinCE}
   {$UNDEF Unicode}
   PStringsChar = PAnsiChar;
   StringsString = AnsiString;
   {$ENDIF WinCE}

   TInternetProgress = procedure(CurrentBytes, TotalBytes: Int64; Percentage: Byte) of object;

   { TInternet }

   TInternet = class
   private
      FErrorCode: DWord;
      FCurrentBytes: Int64;
      FTotalBytes: Int64;
      FUserAgent: string;
      FInternetHandle: TInternetHandle;
      FOnProgress: TInternetProgress;
      procedure FireProgress;
   public
      constructor Create;
      destructor Destroy; override;
   published
      property ErrorCode: DWord read FErrorCode;
      property UserAgent: string read FUserAgent write FUserAgent;
      property CurrentBytes: Int64 read FCurrentBytes;
      property TotalBytes: Int64 read FTotalBytes;
      property OnProgress: TInternetProgress read FOnProgress write FOnProgress;
   end;
   
   { TInternetHTTP }

   TInternetHTTP = class(TInternet)
   private
      FBlockSize: integer;
   public
      constructor Create;
      function Download(Server, Path: string; Stream: TStream): boolean; overload;
      function Download(URL: string; Stream: TStream): boolean; overload;
      function Download(Server, Path: string; Strings: TStrings): boolean; overload;
      function Download(URL: string; Strings: TStrings): boolean; overload;
   published
      property BlockSize: integer read FBlockSize write FBlockSize;
   end;

procedure InetSetUserAgent(UserAgent: string);
function HTTPDownload(URL: string; Stream: TStream; var ErrorCode: DWord): boolean; overload;
function HTTPDownload(URL: string; Strings: TStrings; var ErrorCode: DWord): boolean; overload;
function WinINetErrorMessage(ErrorCode: integer): StringsString;

implementation

var FUnitUserAgent: string;

function WinINetErrorMessage(ErrorCode: integer): StringsString;
var pc: PStringsChar;
begin
   case ErrorCode of
      12007: Result := 'Could not find server!';
      12029: Result := 'Could not connect to server!';
      ERROR_NO_MORE_FILES: Result := 'File not found on server!';
      else begin
         pc := nil;
         GetMem(pc, 2048);
         if FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
                          nil, ErrorCode, 0, pc, 0, nil)>0
         then begin
            Result := StringsString(IntToStr(ErrorCode))+': '+StringsString(pc);
         end else begin
            Result := 'Unknown error #'+IntToStr(ErrorCode);
         end;
         FreeMem(pc, 2048);
      end;
   end;
   // TODO : free memory here!
end;

procedure InetSetUserAgent(UserAgent: string);
begin
   FUnitUserAgent := UserAgent;
end;

function HTTPDownload(URL: string; Strings: TStrings; var ErrorCode: DWord): boolean; overload;
var ms: TMemoryStream;
begin
   ms := TMemoryStream.Create;
   Result := HTTPDownload(URL, ms, ErrorCode);
   Strings.LoadFromStream(ms);
   ms.Free;
end;

function HTTPDownload(URL: string; Stream: TStream; var ErrorCode: DWord): boolean;
var dl: TInternetHTTP;
begin
   dl := TInternetHTTP.Create;
   Result := dl.Download(URL, Stream);
   ErrorCode := dl.ErrorCode;
   dl.Free;
end;

{ TInternet }

constructor TInternet.Create;
begin
   inherited;
   FUserAgent := FUnitUserAgent;
   FCurrentBytes := 0;
   FTotalBytes := 0;
   FErrorCode := 0;
   FInternetHandle := InternetOpen(PChar(FUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
   if FInternetHandle=0
    then FErrorCode := GetLastError;
end;

destructor TInternet.Destroy;
begin
   if FInternetHandle<>0
    then InternetCloseHandle(FInternetHandle);
   inherited;
end;

procedure TInternet.FireProgress;
var perc: Byte;
begin
   if Assigned(FOnProgress) then begin
      perc := 0;
      if FTotalBytes>0 then begin
         if (FCurrentBytes=FTotalBytes)
          then perc := 100
           else perc := 100*Round(FCurrentBytes/FTotalBytes);
         if perc>100
          then perc := 100;
      end;
      FOnProgress(FCurrentBytes, FTotalBytes, perc);
   end;
end;

{ TInternetHTTP }

constructor TInternetHTTP.Create;
begin
   inherited;
   FBlockSize := 4096;
end;

function TInternetHTTP.Download(Server, Path: string; Stream: TStream): boolean;
var hSession, hRequest: TInternetHandle;
    dwConnIC, dwConnHOR, dwSize, dwIndex, dwStatus: DWord;
    iEC: integer;
    pc: PChar;
    buf: String[32];
begin
   Result := false;
   FCurrentBytes := 0;
   FTotalBytes := 0;
   // InternetConnect
   dwConnIC := 0;
   hSession := InternetConnect(FInternetHandle, PChar(Server),
                               INTERNET_DEFAULT_HTTP_PORT, nil, nil,
                               INTERNET_SERVICE_HTTP, 0, dwConnIC);
   if hSession=0 then begin
      FErrorCode := GetLastError;
      Exit;
   end;
   // HttpOpenRequest
   dwConnHOR := 0;
   hRequest := HttpOpenRequest(hSession, nil, PChar(Path), nil, nil, nil, 0, dwConnHOR);
   if hRequest=0 then begin
      FErrorCode := GetLastError;
      InternetCloseHandle(hSession);
      Exit;
   end;
   // HttpSendRequest
   dwSize := 0;
   if HttpSendRequest(hRequest, nil, 0, nil, 0) then begin
      // HttpQueryInfo - status
      SetLength(buf,32);
      dwSize := Length(buf);
      dwIndex := 0;
      if HttpQueryInfo(hRequest,HTTP_QUERY_STATUS_CODE, buf[1], dwSize, dwIndex) then begin
         Val(Copy(buf,1,dwSize), dwStatus, iEC);
         if iEC>0 then begin
            dwStatus := 0;
         end;
      end else begin
         dwStatus := 0;
      end;
      if (dwStatus = 404) then begin
         FErrorCode := ERROR_NO_MORE_FILES;
         InternetCloseHandle(hSession);
         Exit;
      end;
      // HttpQueryInfo - length
      SetLength(buf,32);
      dwSize := Length(buf);
      dwIndex := 0;
      if HttpQueryInfo(hRequest,HTTP_QUERY_CONTENT_LENGTH, buf[1], dwSize, dwIndex) then begin
         Val(Copy(buf,1,dwSize), FTotalBytes, iEC);
         if iEC>0 then begin
            FTotalBytes := 0;
         end;
      end else begin
         FTotalBytes := 0;
      end;
      // InternetReadFile
      pc := nil;
      GetMem(pc,FBlockSize+1);
      repeat
         if InternetReadFile(hRequest,pc,FBlockSize,dwSize) then begin
            Stream.WriteBuffer(pc^,dwSize);
            Inc(FCurrentBytes, dwSize);
            FireProgress;
         end else dwSize := 0;
      until dwSize = 0;
      FireProgress;
      FreeMem(pc,FBlockSize+1);
      FireProgress;
      Result := true;
   end else begin
      FErrorCode := GetLastError;
   end;
   InternetCloseHandle(hRequest);
   InternetCloseHandle(hSession);
   Stream.Seek(0,soFromBeginning);
end;

function TInternetHTTP.Download(URL: string; Stream: TStream): boolean;
var sDomain, sPath: string;
begin
   Result := false;
   if Pos('://',URL)=0 then begin
      FErrorCode := 1;
      Exit;
   end;
   Delete(URL,1,Pos('://',URL)+2);
   if Pos('/',URL)>0 then begin
      sDomain := Copy(URL,1,Pos('/',URL)-1);
      sPath := URL;
      Delete(sPath,1,Length(sDomain));
   end else begin
      sDomain := URL;
      sPath := '/';
   end;
   Result := Download(sDomain, sPath, Stream);
end;

function TInternetHTTP.Download(Server, Path: string; Strings: TStrings
   ): boolean;
var ms: TMemoryStream;
begin
   ms := TMemoryStream.Create;
   Result := Download(Server, Path, ms);
   Strings.LoadFromStream(ms);
   ms.Free;
end;

function TInternetHTTP.Download(URL: string; Strings: TStrings): boolean;
var ms: TMemoryStream;
begin
   ms := TMemoryStream.Create;
   Result := Download(URL, ms);
   Strings.LoadFromStream(ms);
   ms.Free;
end;

begin
   FUnitUserAgent := 'ceWinINet';
end.