unit SocketComponent;

interface

uses
  Windows,Classes,SysUtils,ScktComp;


type
  TSizeChangeEvent = procedure(Sender: TObject; Min:integer; Max:integer) of object;

type
  TSocketSendFileThread = class(TThread)
  private
    { Private declarations }
    FHost:String;
    FActionPage:String;
    FPort:integer;
    FFileName:String;
    FBody:String;

    FCookie:String;
    FBoundary:String;

    FSendHeader:String;
    WorkPostBodyStream : TStringStream ;

    ClientSocketUpload: TClientSocket;

    FMin,FMax:integer;
    FPosition:integer;
    FBytePerSec : Double;
    FStatusCode :integer;
    FStatusMsg  : String;
    FOnPosition : TNotifyEvent;
    FOnSize : TNotifyEvent;

    function GenerateCookie:String;
    function GenerateBoundary:String;
    function BuildHead: String;
    function BuildBody: boolean;

  protected
    procedure Execute; override;
  public
    constructor Create(Host:string; ActionPage:String; Port:integer; FileName:string; Body:string);
    destructor Destroy; override;

    property OnPosition : TNotifyEvent read FOnPosition write FOnPosition;
    property OnSize : TNotifyEvent read FOnSize write FOnSize;
  end;

  TSendFile = class(TComponent)
  private
    FFileName:String;
    FMin,FMax:integer;
    FPosition:integer;
    FBytePerSec :integer;
    FHost    :String;
    FPage    :String;
    FBody    :String;
    FPort    :integer;
    FBusy    :Boolean;
    FStatusCode :integer;
    FStatusMsg  :String;

    FSocketSendFile : TSocketSendFileThread;
    FOnSizeChange   : TSizeChangeEvent;

    procedure doOnMax(Sender: TObject);
    procedure doOnPosition(Sender: TObject);
    procedure doOnTerminate(Sender: TObject);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure  BeginUpload();
    procedure  StopUpload();
    property Position:integer Read FPosition ;
    property BytePerSec :integer Read FBytePerSec;
    property Busy    :Boolean Read FBusy ;
    property Host    :String  Read FHost Write FHost;
    property Page    :String  Read FPage Write FPage;
    property Port    :integer Read FPort Write FPort;
    property Body    :String  Read FBody Write FBody;
    property FileName:String  Read FFileName Write FFileName;
    property StatusCode :integer Read FStatusCode;
    property StatusMsg  :String  Read FStatusMsg;

    property OnSizeChange: TSizeChangeEvent Read FOnSizeChange Write FOnSizeChange;
  end;

implementation

const
  ConHeadTimeOut=10000;  //10s
  ConBufferSize=8192;

//==============================================================================
//==============================================================================

function Min(AValueOne, AValueTwo: Integer): Integer;
begin
  if AValueOne > AValueTwo then
  begin
    Result := AValueTwo
  end
  else
  begin
    Result := AValueOne;
  end;
end;

//==============================================================================
//==============================================================================
// SocketSendFile

constructor TSocketSendFileThread.Create(Host: String; ActionPage:String; Port: integer;
  FileName: string; Body : String);
begin
  FHost:=Host;
  FPort:=Port;
  FActionPage:=ActionPage;
  FFileName:=FileName;
  FBody:=Body;
  FCookie:='';
  FBoundary:='';

  WorkPostBodyStream := TStringStream.Create('');

  FMin:=0;
  FMax:=0;
  FPosition:=0;
  FBytePerSec :=0;
  FStatusCode :=0;
  FStatusMsg :='UnKnown Error';

  ClientSocketUpload:= TClientSocket.Create(nil);
  ClientSocketUpload.ClientType:=ctBlocking;
  ClientSocketUpload.Host:=FHost;
  ClientSocketUpload.Port:=FPort;

  inherited Create(False);
end;

destructor TSocketSendFileThread.Destroy;
begin
  WorkPostBodyStream.Free;
  ClientSocketUpload.Free;
  inherited;
end;

//2 total exit if Terminated
function TSocketSendFileThread.GenerateCookie:String;
var
  i,ipos:integer;
  SendHeader,tmpHead:String;
  Cookie:String;
begin
  Cookie:='';
  SendHeader:='HEAD '+'/'+' HTTP/1.1'+#13#10;
  SendHeader:=SendHeader+'Accept: */*'+#13#10;
  SendHeader:=SendHeader+'Accept-Language: zh-cn'+#13#10;
  SendHeader:=SendHeader+'Accept-Encoding: gzip, deflate'+#13#10;
  SendHeader:=SendHeader+'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0; .NET CLR 1.1.4322; .NET CLR 2.0.50727)'+#13#10;
  SendHeader:=SendHeader+'Host: '+FHost+#13#10;
  SendHeader:=SendHeader+'Connection: Keep-Alive'+#13+#10;
  SendHeader:=SendHeader+#13#10;
  try
    ClientSocketUpload.Active:=false;
    ClientSocketUpload.Host:=FHost;
    ClientSocketUpload.Port:=FPort;
    ClientSocketUpload.Active := true;
    while not ClientSocketUpload.Active do
    begin
      if Terminated then break;
      sleep(1);
    end;
    if Terminated then exit;
    ClientSocketUpload.Socket.SendText(SendHeader);
    for i:=0 to ConHeadTimeOut do
    begin
      if Terminated then break;
      sleep(1);
      if ClientSocketUpload.Socket.ReceiveLength>0 then break;
    end;
    if Terminated then exit;
    tmpHead:= ClientSocketUpload.Socket.ReceiveText;

    ipos:=pos('Set-Cookie:',tmpHead);
    if ipos>0 then
    begin
      Cookie := Trim(Copy(tmpHead, ipos+11, MAXINT));
      Cookie := Copy(Cookie, 1, Pos(';', Cookie) - 1);
    end;
  except

  end;
  Result:=Cookie;

end;

function TSocketSendFileThread.GenerateBoundary:String;
var
   ch1,ch2,ch3,ch4:string;
begin
  Randomize;
  ch1:=inttostr(Random(10));
  ch2:=inttostr(Random(10));
  ch3:=inttostr(Random(10));
  ch4:=inttostr(Random(10));
  Result:='7d'+ch1+ch2+'cf'+ch3+'500f'+ch4;
  Result:='---------------------------'+Result;
end;

function TSocketSendFileThread.BuildHead: String;
var
  SendHeader:String;
begin
  SendHeader:='POST '+FActionPage+' HTTP/1.1'+#13#10;
  SendHeader:=SendHeader+'Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, application/x-shockwave-flash, */*'+#13#10;
  SendHeader:=SendHeader+'Accept-Language: zh-cn'+#13#10;
  if FBody<>'' then
    SendHeader:=SendHeader+'Content-Type: application/x-www-form-urlencoded'+#13#10
  else
    SendHeader:=SendHeader+'Content-Type: multipart/form-data; boundary='+FBoundary+#13#10;
  SendHeader:=SendHeader+'Accept-Encoding: gzip, deflate'+#13#10;
  SendHeader:=SendHeader+'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0; .NET CLR 1.1.4322; .NET CLR 2.0.50727)'+#13#10;
  SendHeader:=SendHeader+'Host: '+FHost+#13#10;
  SendHeader:=SendHeader+'Content-Length: '+IntToStr(FMax)+#13#10;
  SendHeader:=SendHeader+'Connection: Keep-Alive'+#13+#10;
  SendHeader:=SendHeader+'Cache-Control: no-cache'+#13+#10;
  if FCookie<>'' then SendHeader:=SendHeader+'Cookie: '+FCookie+#13+#10;
  SendHeader:=SendHeader+#13#10;

  Result:=SendHeader;
end;

function TSocketSendFileThread.BuildBody: boolean;
var
  FWordFile:TMemoryStream;
begin
  if FBody<>'' then
  begin
    WorkPostBodyStream.WriteString(FBody);
    WorkPostBodyStream.WriteString(#$D#$A);
  end
  else
  begin
    FWordFile := TMemoryStream.Create;
    try
      FWordFile.LoadFromFile(FFileName);
      WorkPostBodyStream.WriteString(FBoundary);
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString('Content-Disposition: form-data; name="myimage"; filename="'+FFileName+'"');
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString('Content-Type: image/pjpeg');
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.CopyFrom(FWordFile, FWordFile.Size);
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString(FBoundary);
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString('Content-Disposition: form-data; name="button"');
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString('上传');
      WorkPostBodyStream.WriteString(#$D#$A);
      WorkPostBodyStream.WriteString(FBoundary);
      WorkPostBodyStream.WriteString(#$D#$A);
    finally
      FWordFile.Free;
    end;
  end;
  FMax:=WorkPostBodyStream.Size;
  if Assigned(OnSize) then OnSize(Self);
  Result:=true;
end;

//4 total exit if Terminated
procedure TSocketSendFileThread.Execute;
var
  LBuffer:TMemoryStream;
  LSize,FSendBufferSize:integer;
  f1,f2,frequency:int64;
  i:integer;
  mStatusCode:String;
begin
  { Place thread code here }
  FreeOnTerminate:=true;
  try
    FCookie:=GenerateCookie();
    FBoundary:=GenerateBoundary();
    BuildBody();   //WorkPostBodyStream
    FSendHeader:=BuildHead();
    if Terminated then exit;    //exit 1/4
    ClientSocketUpload.Active:=false;
    ClientSocketUpload.Active := true;
    while not ClientSocketUpload.Active do
    begin
      if Terminated then break;
      sleep(1);
    end;
    if Terminated then exit;    //exit 2/4
    queryperformancecounter(f1);
    QueryPerformanceFrequency(frequency);
    ClientSocketUpload.Socket.SendText(FSendHeader);
    queryperformancecounter(f2);
    FBytePerSec:=length(FSendHeader)/((f2-f1)/frequency);
    if Assigned(OnPosition) then OnPosition(Self);
    LBuffer := TMemoryStream.Create;
    try
      FSendBufferSize:=ConBufferSize;
      LBuffer.SetSize(FSendBufferSize);
      WorkPostBodyStream.Position:=0;
      while true and (not Terminated) do
      begin
        LSize := Min(WorkPostBodyStream.Size - WorkPostBodyStream.Position, FSendBufferSize);
        if LSize = 0 then
        begin
          Break;
        end;
        LSize := WorkPostBodyStream.Read(LBuffer.Memory^, LSize);
        if LSize = 0 then
        begin
          //raise EIdNoDataToRead.Create(RSIdNoDataToRead);
        end;
        queryperformancecounter(f1);
        QueryPerformanceFrequency(frequency);
        ClientSocketUpload.Socket.SendBuf(LBuffer.Memory^, LSize);
        queryperformancecounter(f2);
        FBytePerSec:=LSize/((f2-f1)/frequency);
        FPosition:=WorkPostBodyStream.Position;
        if Assigned(OnPosition) then OnPosition(Self);
      end;
      if Terminated then exit;    //exit 3/4
      //result code
      for i:=0 to ConHeadTimeOut do
      begin
        if Terminated then break;
        sleep(1);
        if ClientSocketUpload.Socket.ReceiveLength>0 then break;
      end;
      if Terminated then exit;    //exit 4/4
      mStatusCode:= ClientSocketUpload.Socket.ReceiveText;
      if pos('HTTP/1',mStatusCode)>0 then
      begin
        mStatusCode:=copy(mStatusCode,10,MAXINT);
        FStatusMsg :=copy(mStatusCode,1,pos(#13#10,mStatusCode)-1);
        mStatusCode:=copy(mStatusCode,1,pos(' ',mStatusCode)-1);
        FStatusCode:=StrToIntDef(mStatusCode,0);
      end;
    finally
      LBuffer.Free;
    end;

  except
  end;
end;


//==============================================================================
//==============================================================================
constructor TSendFile.Create(AOwner: TComponent);
begin
  inherited;
  FMin:=0;
  FMax:=0;
  FPosition:=0;
  FBytePerSec:=0;
  FPort    :=80;
  FBusy    :=false;
  FHost    :='';  // sample bbs.163.com
  FPage    :='';  // sample /AlbumUpload!AlbumPhotoForActiveX.jspa
  FFileName:='';  // smaple C:\My Documents\My Pictures\168927.jpg
  FBody    :='';
  FStatusCode:=0;
  FStatusMsg :='UnKnown Error';
end;

destructor TSendFile.Destroy;
begin
  inherited;
end;

procedure TSendFile.StopUpload;
begin
  if Assigned(FSocketSendFile) then
  begin
    FSocketSendFile.ClientSocketUpload.Close;
    FSocketSendFile.Terminate;
  end;
end;

procedure TSendFile.BeginUpload;
begin
  if FBusy then
    StopUpload;
  FBusy:=true;
  FSocketSendFile := TSocketSendFileThread.Create(FHost, FPage, FPort, FFileName, FBody);
  FSocketSendFile.OnPosition:=doOnPosition;
  FSocketSendFile.OnSize:=doOnMax;
  FSocketSendFile.OnTerminate:=doOnTerminate;
end;

procedure TSendFile.doOnMax(Sender: TObject);
begin
  FMin:=FSocketSendFile.FMin;
  FMax:=FSocketSendFile.FMax;
  FOnSizeChange(self,FMin,FMax);
end;

procedure TSendFile.doOnPosition(Sender: TObject);
begin
  FPosition:=FSocketSendFile.FPosition;
  FBytePerSec:=Trunc(FSocketSendFile.FBytePerSec);
end;

procedure TSendFile.doOnTerminate(Sender: TObject);
begin
  FStatusCode:=FSocketSendFile.FStatusCode;
  FStatusMsg:=FSocketSendFile.FStatusMsg;
  FBusy:=false;
  FSocketSendFile:=nil;
  FFileName:='';  // smaple C:\My Documents\My Pictures\168927.jpg
  FBody    :='';
end;

end.