postfile.pas

autoupdate 1.02 source code

unit postfile;
// $Header: /home/cso/jnewbigin/cvsroot/autoupdate/postfile.pas,v 1.6 2005/01/22 08:36:36 jnewbigin Exp $

interface

uses SysUtils, WinInet, JWinInet, WinBinFile, Windows, Classes, Progress;

type
   TDebugFunction = procedure(S : String) of object;

   IPostFileOptions = interface(IUnknown)
      function GetUserAgent : String;
      function GetHostName : String;
      function GetPortNumber : Integer;
      function GetHttps : Boolean;
      function GetAllowWrongProperName : Boolean;
      function GetAllowExpiredCertificate : Boolean;
      function GetAllowUnknownCA : Boolean;

      function isAlwaysConnected: Boolean;
      function hasAlwaysConnect: Boolean;
      function isUsingIESettings: Boolean;
      function GetProxyAddress: String;
      function GetProxyPort: Integer;
      function isUsingProxyLogin: Boolean;
      function isProxyPasswordNeeded: Boolean;
      function getProxyUsername: String;
      function getProxyPassword: String;

      procedure setSSLStrength(Strength : Integer);

      function GetInternetHandle : HINTERNET;
      procedure SetInternetHandle(h : HINTERNET);

   end;

   InetException = class (Exception)
   public
      Error : DWORD;

      constructor Create (const Msg: string);
      function GetErrorString : String;
   end;

   TPostFile = class
   public
      ScriptName : String;


      constructor Create(Options : IPostFileOptions; Debug : TDebugFunction; Progress : IProgress);
      destructor Destroy; override;

      procedure Connect;
      function ReceiveFile(Keys : TStringList; Values : TStringList; FileName : String; DestinationName : String; Results : TStringList) : Integer;

      procedure Post(Keys : TStringList; Values : TStringList; FileName : String; Results : TStringList);

   private
      Prog : IProgress;
      DebugFunction : TDebugFunction;
      Options : IPostFileOptions;

      HostName : String;
      PortNumber : Integer;

      UseHTTPS : Boolean;
      AllowWrongProperName : Boolean;
      AllowExpiredCertificate : Boolean;

      Internet : HINTERNET;
      Connection : HINTERNET;

      function GenerateBoundryString : String;
      procedure Debug(S : String);
   end;

implementation

constructor InetException.Create(const Msg: string);
var
   hModule : hInst;
   Buffer : String;
   Len : DWORD;
   Error2 : DWORD;
begin
   inherited Create(Msg);

   Error := GetLastError;
   SetLength(Buffer, 1024);
   hModule := GetModuleHandle(WININET_MODULE);
   Len := FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, Pointer(hModule), Error, 0, PChar(Buffer), Length(Buffer), nil);
   if Len = 0 then
   begin
      Error2 := GetLastError;
      Buffer := SysErrorMessage(Error2);
   end
   else
   begin
      SetLength(Buffer, Len);
      // remove any trailing newline
      Buffer := AdjustLineBreaks(Buffer);
      if Buffer[Length(Buffer)] = #$A then
      begin
         Buffer := copy(Buffer, 0, Length(Buffer) - 2);
      end;
   end;

   Message := Message + ' (' + Buffer + ')';
end;

function InetException.GetErrorString : String;
begin
   Result := Message;
end;

procedure TPostFile.Debug(S : String);
begin
   if Assigned(DebugFunction) then
   begin
      DebugFunction(S);
   end;
end;

constructor TPostFile.Create(Options : IPostFileOptions; Debug : TDebugFunction; Progress : IProgress);
var
   Proxy : String;
begin
   inherited Create;
   LoadWinINet;

   Prog := Progress;
   DebugFunction := Debug;

   Self.Options := Options;

   HostName := Options.GetHostName;
   PortNumber := Options.GetPortNumber;
   UseHTTPS := Options.GetHttps;
   AllowWrongProperName := Options.GetAllowWrongProperName;
   AllowExpiredCertificate := Options.GetAllowExpiredCertificate;

   if Options.GetInternetHandle <> nil then
   begin
      Internet := Options.GetInternetHandle;
   end
   else
   begin

      // get internet handle
      if Options.isUsingIESettings then
      begin
         //Debug('Postfile InternetOpen+');
         Internet := JInternetOpen(PChar(Options.GetUserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
         //Debug('Postfile InternetOpen-');
      end
      else
      begin
         Proxy := 'http=http://' + Options.GetProxyAddress + ':' + IntToStr(Options.GetProxyPort) + ' ' +
                  'https=http://' + Options.GetProxyAddress + ':' + IntToStr(Options.GetProxyPort);
         //Debug('Using http proxy ' + Proxy);
         //Debug('Postfile InternetOpen+');
         Internet := JInternetOpen(PChar(Options.GetUserAgent), INTERNET_OPEN_TYPE_PROXY, PChar(Proxy), nil, 0);
         //Debug('Postfile InternetOpen-');

         if Options.isUsingProxyLogin then
         begin
            //Debug('Postfile InternetSetOption+');
            JInternetSetOption(Internet, INTERNET_OPTION_PROXY_USERNAME, PChar(Options.getProxyUsername), Length(Options.getProxyUsername));
            //Debug('Postfile InternetSetOption-');
            //Debug('Postfile InternetSetOption+');
            JInternetSetOption(Internet, INTERNET_OPTION_PROXY_PASSWORD, PChar(Options.getProxyPassword), Length(Options.getProxyPassword));
            //Debug('Postfile InternetSetOption-');
         end;
      end;
      if Internet = nil then
      begin
         raise InetException.Create('InternetOpen failed');
      end;
      // before we do this we need to have a flag to say the proxy config has changed
      // and we should close and re-open
      //Options.SetInternetHandle(Internet);
   end;
end;

destructor TPostFile.Destroy;
begin
   if Assigned(Connection) then
   begin
      //Debug('Postfile InternetCloseHandle+');
      JInternetCloseHandle(Connection);
      //Debug('Postfile InternetCloseHandle-');
   end;

   if Assigned(Internet) then
   begin
      if Internet = Options.GetInternetHandle then
      begin
         Debug('Keeping InternetHandle open for next connection');
      end
      else
      begin
         //Debug('Postfile InternetCloseHandle+');
         JInternetCloseHandle(Internet);
         //Debug('Postfile InternetCloseHandle-');
      end;
   end;

   inherited Destroy;
end;

procedure TPostFile.Connect;
begin
   // connect to the host
   Prog.SetMessage('Connecting...');
   //Debug('Postfile InternetConnect+');
   Connection := JInternetConnect(Internet, PChar(HostName), PortNumber, nil, nil, INTERNET_SERVICE_HTTP, 0, 0);
   //Debug('Postfile InternetConnect-');
   if Connection = nil then
   begin
      raise InetException.Create('InternetConnect failed');
   end;

   // set the status callback function
   //InternetSetStatusCallback(Connection, StatusCallback);
end;

function TPostFile.ReceiveFile(Keys : TStringList; Values : TStringList; FileName : String; DestinationName : String; Results : TStringList) : Integer;
var
   Request  : HINTERNET;
   Buffer   : String;
   SendFile : TBinaryFile;
   RecvFile : TBinaryFile;

   procedure WriteString(S : String);
   var
      Actual : DWORD;
   begin
      //Debug('Postfile InternetWriteFile+');
      if not JInternetWriteFile(Request, PChar(S), Length(S), Actual) then
      begin
         Debug('Postfile InternetWriteFile*');
         raise InetException.Create('InternetWriteFile failed');
      end;
      //Debug('Postfile InternetWriteFile-');
      if Int64(Actual) < Length(S) then
      begin
         Debug('Short write.  Len = ' + IntToStr(Length(S)) + ' Actual = ' + IntToStr(Actual));
      end;
   end;

   procedure WriteLine(S : String);
   begin
      Buffer := Buffer + S + #13#10;
   end;

   procedure SendFileContents;
   var
      BytesRemaining : Int64;
      Buffer         : String;
   begin
     BytesRemaining := SendFile.FileSize;
      while BytesRemaining > 0 do
      begin
         if BytesRemaining < 1024 then
         begin
            SetLength(Buffer, BytesRemaining);
         end
         else
         begin
            SetLength(Buffer, 1024);
         end;

         SendFile.BlockRead2(PChar(Buffer), Length(Buffer));
         WriteString(Buffer);

         BytesRemaining := BytesRemaining - Length(Buffer);
      end;
   end;

   procedure ReadResult;
   var
      Actual : DWORD;
      Buffer : String;
      GotOK  : Integer;
      TempBuffer : String;
      TotalRead : DWORD;
   begin
      GotOK := 0; // we don't know yet...
      TotalRead := 0;
      // read a flag to see if we got it...
      while true do
      begin
         SetLength(Buffer, 1024);
         //Debug('Postfile InternetReadFile+');
         if not JInternetReadFile(Request, PChar(Buffer), Length(Buffer), Actual) then
         begin
            Debug('Postfile InternetReadFile*');
            raise InetException.Create('InternetReadFile failed');
            // error
            Debug('InternetReadFile error');
         end;
         //Debug('Postfile InternetReadFile-');
         if Actual = 0 then
         begin
            break;
         end;
         SetLength(Buffer, Actual);
         if GotOK = 0 then
         begin
            // the length must be at least 1 char.  Look for a '+'
            if Buffer[1] = '+' then
            begin
               GotOK := 1; // Here comes the file
               Delete(Buffer, 1, 1);
               Actual := Actual - 1;
            end
            else
            begin
               GotOK := 2; // Server Error
               Result := 1;
            end;
         end;
         if GotOK = 1 then
         begin
            RecvFile.BlockWrite2(PChar(Buffer), Actual);
         end
         else
         begin
            TempBuffer := TempBuffer + Buffer;
         end;
         TotalRead := TotalRead + Actual;
         //Debug('Read = ' + IntToStr(TotalRead));
         Prog.SetPos(TotalRead);
      end;
      if Assigned(Results) then
      begin
         Results.Text := TempBuffer;
      end;
      if GotOK = 1 then
      begin
         Results.Add('+status: Success');
      end;
   end;
var
   Header   : String;
   Boundry  : String;
   Flags    : DWORD;
   BufferIn : INTERNET_BUFFERS;
   i : Integer;
   QueryBuffer : String;
   QueryLen : DWORD;
   QueryIdx : DWORD;
begin
   Result := 0;
   Prog.setNoActions(0);

   if Connection = nil then
   begin
      Connect;
   end;
   Prog.SetMessage('Opening...');

   SendFile := nil;
   try
      if Length(FileName) > 0 then
      begin
         SendFile := TBinaryFile.Create;

         SendFile.Assign(FileName);
         SendFile.Open(OPEN_READ_ONLY);
      end;

      RecvFile := TBinaryFile.Create;
      RecvFile.Assign(DestinationName);
      RecvFile.Delete;
      RecvFile.CreateNew;

   Flags := INTERNET_FLAG_NO_CACHE_WRITE or SECURITY_FLAG_IGNORE_UNKNOWN_CA or SECURITY_FLAG_IGNORE_WRONG_USAGE;
//      Flags := INTERNET_FLAG_NO_CACHE_WRITE;

      if UseHTTPS then
      begin
         Flags := Flags or INTERNET_FLAG_SECURE;
      end;

      if AllowWrongProperName then
      begin
         Flags := Flags or INTERNET_FLAG_IGNORE_CERT_CN_INVALID;
      end;

      if AllowExpiredCertificate then
      begin
         Flags := Flags or INTERNET_FLAG_IGNORE_CERT_DATE_INVALID;
      end;

      //Debug('Postfile HttpOpenRequest+');
      Request := JHttpOpenRequest(Connection, 'POST', PChar(ScriptName), nil, nil, nil, Flags, 0);
      //Debug('Postfile HttpOpenRequest-');
      if Request = nil then
      begin
         raise InetException.Create('HttpOpenRequest failed');
      end;

      try
         Boundry := GenerateBoundryString;

         Header := 'Content-Type: multipart/form-data; boundary=' + Boundry;

         for i := 0 to Keys.Count - 1 do
         begin
            WriteLine('--'+Boundry);
            WriteLine('Content-Disposition: form-data; name="' + Keys[i] + '"');
            WriteLine('');
            WriteLine(Values[i]);
         end;

         WriteLine('--'+Boundry);
         WriteLine('Content-Disposition: form-data; name="pramcount"');
         WriteLine('');
         WriteLine(IntToStr(Keys.Count));

         if Assigned(SendFile) then
         begin
            WriteLine('--'+Boundry);