1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:
226:
227:
228:
229:
230:
231:
232:
233:
234:
235:
236:
237:
238:
239:
240:
241:
242:
243:
244:
245:
246:
247:
248:
249:
250:
251:
252:
253:
254:
255:
256:
257:
258:
259:
260:
261:
262:
263:
264:
265:
266:
267:
268:
269:
270:
271:
272:
273:
274:
275:
276:
277:
278:
279:
280:
281:
282:
283:
284:
285:
286:
287:
288:
289:
290:
291:
292:
293:
294:
295:
296:
297:
298:
299:
300:
301:
302:
303:
304:
305:
306:
307:
308:
309:
310:
311:
312:
313:
314:
315:
316:
317:
318:
319:
320:
321:
322:
323:
324:
325:
326:
327:
328:
329:
330:
331:
332:
333:
334:
335:
336:
337:
338:
339:
340:
341:
342:
343:
344:
345:
346:
347:
348:
349:
350:
351:
352:
353:
354:
355:
356:
357:
358:
359:
360:
361:
362:
363:
364:
365:
366:
367:
368:
369:
370:
371:
372:
373:
374:
375:
376:
377:
378:
379:
380:
381:
382:
383:
384:
385:
386:
387:
388:
389:
390:
391:
392:
393:
394:
395:
396:
397:
398:
399:
400:
401:
402:
403:
404:
405:
406:
407:
408:
409:
410:
411:
412:
413:
414:
415:
416:
417:
418:
419:
420:
421:
422:
423:
424:
425:
426:
427:
428:
429:
430:
431:
432:
433:
434:
435:
436:
437:
438:
439:
440:
441:
442:
443:
444:
445:
446:
447:
448:
449:
450:
451:
452:
453:
454:
455:
456:
457:
458:
459:
460:
461:
462:
463:
464:
465:
466:
467:
468:
469:
470:
471:
472:
473:
474:
475:
476:
477:
478:
479:
480:
481:
482:
483:
484:
485:
486:
487:
488:
489:
490:
491:
492:
493:
494:
495:
496:
497:
498:
499:
500:
501:
502:
503:
504:
505:
506:
507:
508:
509:
510:
511:
512:
513:
514:
515:
516:
517:
518:
519:
520:
521:
522:
523:
524:
525:
526:
527:
528:
529:
530:
531:
532:
533:
534:
535:
536:
537:
538:
539:
540:
541:
542:
543:
544:
545:
546:
547:
548:
549:
550:
551:
552:
553:
554:
555:
556:
557:
558:
559:
560:
561:
562:
563:
564:
565:
566:
567:
568:
569:
570:
571:
572:
573:
574:
575:
576:
577:
578:
579:
580:
581:
582:
583:
584:
585:
586:
587:
588:
589:
590:
591:
592:
593:
594:
595:
596:
597:
598:
599:
600:
601:
602:
603:
604:
605:
606:
607:
608:
609:
610:
611:
612:
613:
614:
615:
616:
617:
618:
619:
620:
621:
622:
623:
624:
625:
626:
627:
628:
629:
630:
631:
632:
633:
634:
635:
636:
637:
638:
639:
640:
641:
642:
643:
644:
645:
646:
647:
648:
649:
650:
651:
652:
653:
654:
655:
656:
657:
658:
659:
660:
661:
662:
663:
664:
665:
666:
667:
668:
669:
670:
671:
672:
673:
674:
675:
676:
677:
678:
679:
680:
681:
682:
683:
684:
685:
686:
687:
688:
689:
690:
691:
692:
693:
694:
695:
696:
697:
698:
699:
700:
701:
702:
703:
704:
705:
706:
707:
708:
709:
710:
711:
712:
713:
714:
715:
716:
717:
718:
719:
720:
721:
722:
723:
724:
725:
726:
727:
728:
729:
730:
731:
732:
733:
734:
735:
736:
737:
738:
739:
740:
741:
742:
743:
744:
745:
746:
747:
748:
749:
750:
751:
752:
753:
754:
755:
756:
757:
758:
759:
760:
761:
762:
763:
764:
765:
766:
767:
768:
769:
770:
771:
772:
773:
774:
775:
776:
777:
778:
779:
780:
781:
782:
783:
784:
785:
786:
787:
788:
789:
790:
791:
792:
793:
794:
795:
796:
797:
798:
799:
800:
801:
802:
803:
804:
805:
806:
807:
808:
809:
810:
811:
812:
813:
814:
815:
816:
817:
818:
819:
820:
821:
822:
823:
824:
825:
826:
827:
828:
829:
830:
831:
832:
833:
834:
835:
836:
837:
838:
839:
840:
841:
842:
843:
844:
845:
846:
847:
848:
849:
850:
851:
852:
853:
854:
855:
856:
857:
858:
859:
860:
861:
862:
863:
864:
865:
866:
867:
868:
869:
870:
871:
872:
873:
874:
875:
876:
877:
878:
879:
880:
881:
882:
883:
884:
885:
886:
887:
888:
889:
890:
891:
892:
893:
894:
895:
896:
897:
898:
899:
900:
901:
902:
903:
904:
905:
906:
907:
908:
909:
910:
911:
912:
913:
914:
915:
916:
917:
918:
919:
920:
921:
922:
923:
924:
925:
926:
927:
928:
929:
930:
931:
932:
933:
934:
935:
936:
937:
938:
939:
940:
941:
942:
943:
944:
945:
946:
947:
948:
949:
950:
951:
952:
953:
954:
955:
956:
957:
958:
959:
960:
961:
962:
963:
964:
965:
966:
967:
968:
969:
970:
971:
972:
973:
974:
975:
976:
977:
978:
979:
980:
981:
982:
983:
984:
985:
986:
987:
988:
989:
990:
991:
992:
993:
994:
995:
996:
997:
998:
999:
1000:
1001:
1002:
1003:
1004:
1005:
1006:
1007:
1008:
1009:
1010:
1011:
1012:
1013:
1014:
1015:
1016:
1017:
1018:
1019:
1020:
1021:
1022:
1023:
1024:
1025:
1026:
1027:
1028:
1029:
1030:
1031:
1032:
1033:
1034:
1035:
1036:
1037:
1038:
1039:
1040:
1041:
1042:
1043:
1044:
1045:

unit SimpleTCP;

{*******************************************************************************
 Project       : SimpleTCP
 Filename      : SimpleTCP
 Date          : 2004-07-29
 Version       : 1.0.0.5
 Last modified : 2004-10-14
 Author        : Andreas Kreul a.k.a Udontknow
 URL           : www.xnebula.net
 Copyright     : Copyright (c) 2004 Andreas Kreul
 History       :

*******************************************************************************}


{*******************************************************************************

 Copyright (c) 2004, Andreas Kreul ["copyright holder(s)"]
 Partcopyright : Popov (function "GetTempFile", thx!)
 All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*******************************************************************************}


{*******************************************************************************

 The two classes TSimpleTCPClient and TSimpleTCPServer simplify the use of the
 Indy-components TidTCPClient and TidTCPServer, synchronising all events and
 implementing extra "OnInput" and "OnProgress" events.

 *** Changes in Version 1.0.0.5 ***
 - implemented "Interceptor" property for interceptor components
   (could be use for example for onthefly data compression)

 *** Changes in Version 1.0.0.4 ***
 - Boolean var "DisposeStream" implemented to hold stream from
   Input/ProcessCommand for further use (e.g. in other threads)

 *** Changes in Version 1.0.0.3 ***
 - again one bug using filestreams fixed

 *** Changes in Version 1.0.0.2 ***
 - some bugs making trouble using a filestream fixed

 *** Changes in Version 1.0.0.1 ***

 - Changed type for "BytesToRead"/"BytesToWrite" from integer to Int64
 - added property "SizeForFileStream" indicating when to use a file stream for
   data buffer instead of a memory stream. It will be created a file in the
   temp folder of windows (thx to popov for his open source unit!)

*******************************************************************************}



interface

uses Classes, Windows, SysUtils, SyncObjs, idGlobal, IdTCPClient, IdTCPServer;

type TCommand=integer;

//bidirectional commands
const coData:TCommand=0;

//Server2Client commands
const coDisconnect:TCommand=-1;

type
  TSimpleTCPConnection=class;
  TSimpleTCPClient=class;
  TSimpleTCPServer=class;
  THandleInputEvent=procedure(Sender:TObject;Stream:TStream; var DisposeStream:Boolean) of object;
  THandleServerInputEvent=procedure(Connection:TSimpleTCPConnection;Stream:TStream; var DisposeStream:Boolean) of object;
  TProgressEvent=procedure(Sender:TObject; BytesTransferred:Int64;BytesToTransfer:Int64) of object;
  TServerEvent=procedure(Connection:TSimpleTCPConnection) of object;
  TServerProcessCommandEvent=procedure(Connection:TSimpleTCPConnection;Command:Integer; Stream:TStream) of object;
  TServerProgressEvent=procedure(Connection:TSimpleTCPConnection; BytesTransferred:Int64;BytesToTransfer:Int64) of object;
  TProcessCommandEvent=procedure(Command:Integer; Stream:TStream; var DisposeStream:Boolean) of object;

  TSimpleTCPInterceptor=class(TComponent)
    public
      procedure BeforeSendCommand(const Stream:TStream); virtual; abstract;
      procedure BeforeProcessCommand(const Stream:TStream); virtual; abstract;
  end;

  TClientThread=class(TThread)
  private
    function GetOnProcessCommand: TProcessCommandEvent;
    procedure SetOnProcessCommand(const Value: TProcessCommandEvent);
    function GetClient: TidTCPClient;
    procedure SetClient(const Value: TidTCPClient);
  protected
    FBytesForProgress:Integer;
    FBytesTransferred,FBytesToTransfer:Int64;
    FCommand:Integer;
    FActive:Boolean;
    FStream:TStream;
    FClient:TidTCPClient;
    FOnProcessCommand:TProcessCommandEvent;
    FOnProgress:TProgressEvent;
    procedure HandleProcessCommand;
    procedure HandleProgress;
  public
    procedure Execute; override;
  published
    property BytesForProgress:Integer read FBytesForProgress write FBytesForProgress;
    property OnProgress:TProgressEvent read FOnProgress write FOnProgress;
    property OnProcessCommand:TProcessCommandEvent read GetOnProcessCommand Write SetOnProcessCommand;
    property Client:TidTCPClient read GetClient write SetClient;
end;

  TSimpleTCPComponent=class(TComponent)
  protected
    FSizeForFileStream:Int64;
    FBytesForProgress:Integer;
    FInterceptor:TSimpleTCPInterceptor;
  published
    property SizeForFileStream:Int64 read FSizeForFileStream write FSizeForFileStream;
    property BytesForProgress:Integer read FBytesForProgress write FBytesForProgress;
    property Interceptor:TSimpleTCPInterceptor read FInterceptor write FInterceptor;
end;

  TSimpleTCPClient=class(TSimpleTCPComponent)
  private
    FThread:TClientThread;
    FOnInput:THandleInputEvent;
    FOnProgress:TProgressEvent;
    function GetConnected: Boolean;
    function GetHost: String;
    function GetOnConnected: TNotifyEvent;
    function GetOnDisconnected: TNotifyEvent;
    function GetPort: Integer;
    procedure SetConnected(const Value: Boolean);
    procedure SetHost(const Value: String);
    procedure SetOnConnected(const Value: TNotifyEvent);
    procedure SetOnDisconnected(const Value: TNotifyEvent);
    procedure SetPort(const Value: Integer);
    function GetOnInput: THandleInputEvent;
    procedure SetOnInput(const Value: THandleInputEvent);
    function GetOnProgress: TProgressEvent;
    procedure SetOnProgress(const Value: TProgressEvent);
  protected
    FClient:TIdTCPClient;
    procedure ProcessCommand(Command:Integer; Stream:TStream; var DisposeStream:Boolean); virtual;
    procedure SendCommand(Command:Integer; Stream:TStream); overload; virtual;
    procedure SendCommand(Command:Integer; Streams:Array of TStream); overload; virtual;
  public
    constructor Create(Aowner:TComponent); override;
    destructor Destroy; override;
    property Connected:Boolean read GetConnected write SetConnected;
    procedure SendStream(AStream:TStream);
    procedure SendStreams(AStreams: Array of TStream);    
  published
    property OnProgress:TProgressEvent read GetOnProgress write SetOnProgress;

    property Host:String read GetHost write SetHost;
    property Port:Integer read GetPort write SetPort;
    property OnConnected:TNotifyEvent read GetOnConnected write SetOnConnected;
    property OnDisconnected:TNotifyEvent read GetOnDisconnected write SetOnDisconnected;
    property OnInput:THandleInputEvent read GetOnInput write SetOnInput;

    property SizeForFileStream;
    property BytesForProgress;
  end;

  TSimpleTCPConnection=class(TObject)
  private
    FServer:TSimpleTCPServer;
    FThread: TIDPeerThread;
    FPeerIP:String;
    FPeerPort:Integer;
    FData:TObject;
    function GetPeerIP: String;
    function GetPeerPort: Integer;
  public
    procedure SendStream(AStream:TStream);
    procedure SendStreams(AStreams: Array of TStream);

    procedure Disconnect;
    constructor Create(AThread:TIDPeerThread); reintroduce; virtual;

    property PeerIP:String read GetPeerIP;
    property PeerPort:Integer read GetPeerPort;
    property Data:TObject read FData write FData;
  end;

  TSimpleTCPConnections=class(TObject)
    private
      FServer:TSimpleTCPServer;    
      FItems:TList;
      function Add(AThread:TIDPeerThread):TSimpleTCPConnection;
      function ByThread(AThread:TIDPeerThread):TSimpleTCPConnection;
      procedure Delete(Connection:TSimpleTCPConnection);
      procedure Clear;
      function GetCount: Integer;
      function GetItems(Index: Integer): TSimpleTCPConnection;
    public
      constructor Create; virtual;
      destructor Destroy; override;

      function ByIPAndPort(PeerIP:String;PeerPort:Integer):TSimpleTCPConnection;

      property Count:Integer read GetCount;
      property Items[Index:Integer]:TSimpleTCPConnection read GetItems; default;
  end;

  TSimpleTCPServer=class(TSimpleTCPComponent)
  private
    FActive:Boolean;
    FOnProgress:TServerProgressEvent;
    FBytesTransferred,FBytesToTransfer:Int64;
    FCS:TCriticalSection;
    FOnInput:THandleServerInputEvent;
    FConnections:TSimpleTCPConnections;
    FServer:TIDTCPServer;
    FOnConnect:TServerEvent;
    FOnDisconnect:TServerEvent;
    procedure ServerExecute(AThread: TIdPeerThread);
    procedure InternalOnconnect(AThread:TIDPeerThread);
    procedure InternalOnDisconnect(AThread:TIDPeerThread);
    function GetActive: Boolean;
    function GetPort: Integer;
    procedure SetActive(const Value: Boolean);
    procedure SetPort(const Value: Integer);
    function GetOnConnect: TServerEvent;
    function GetOnDisconnect: TServerEvent;
    procedure SetOnConnect(const Value: TServerEvent);
    procedure SetOnDisconnect(const Value: TServerEvent);
    procedure HandleOnConnect;
    procedure HandleOnDisconnect;
    procedure HandleProcessCommand;
    procedure HandleProgress;
  protected
    //Fields to be used in synched proc HandleProcessCommand
    FCommand:Integer;
    FConnection:TSimpleTCPConnection;
    FStream:TStream;

    //procs can be overriden to implement more commands
    procedure ProcessCommand(Command:Integer; Connection:TSimpleTCPConnection; Stream:TStream; var DisposeStream:Boolean); virtual;
    procedure SendCommand(Command:Integer; Connection:TSimpleTCPConnection; Stream:TStream); overload; virtual;
    procedure SendCommand(Command:Integer; Connection:TSimpleTCPConnection; Streams:Array of TStream); overload; virtual;
  public
    constructor Create(Aowner:TComponent); override;
    destructor Destroy; override;

    property Connections:TSimpleTCPConnections read FConnections;
    procedure SendStream(Connection:TSimpleTCPConnection;Stream:TStream); virtual;
  published
    property Port:Integer read GetPort write SetPort;
    property OnInput:THandleServerInputEvent read FOnInput Write FOnInput;
    property OnConnect:TServerEvent read GetOnConnect write SetOnConnect;
    property OnDisconnect:TServerEvent read GetOnDisconnect write SetOnDisconnect;
    property OnProgress:TServerProgressEvent read FOnProgress write FOnProgress;
    property Active:Boolean read GetActive write SetActive;

    property SizeForFileStream;
    property BytesForProgress;

  end;

function GetTempFile: String;

procedure Register;

const Max_Path=512;

implementation

uses IdSocketHandle;

procedure Register;
begin
  RegisterComponents('Simple Network',[TSimpleTCPClient,TSimpleTCPServer]);
end;

function GetTempFile: String;
var
  TempPath: array[0..MAX_PATH+1] of Char;
  Buffer: array[0..MAX_PATH+1] of Char;  
begin
  Result := #0;  

  if GetTempPath(MAX_PATH, TempPath) <> 0 then
    if GetTempFileName(TempPath, '~tm', 0, Buffer) <> 0 then
      Result := Buffer;
end; {Popov}

{ TClientThread }

procedure TClientThread.Execute;
var BytesToRead:Int64;
var TempFile:String;
begin
  while not Terminated and (FClient<>NIL) and (FClient.Connected) do
  try
    //set nonstopping breakpoint to ignore following exceptions
    //read command
    FClient.ReadBuffer(FCommand, SizeOf (FCommand));

    if FCommand=coDisconnect then
    begin
      FClient.Disconnect;
      exit;
    end;

    //set nonstopping breakpoint to handle following exceptions

    //read bytes that follow
    FClient.ReadBuffer(BytesToRead, SizeOf (BytesToRead));

    //if datasize is large, create a file stream,
    // else create faster memory stream
    if BytesToRead>=TSimpleTCPClient(FClient.Owner).SizeForFileStream then
    begin
      TempFile:=GetTempFile;
      FStream:=TFileStream.Create(TempFile,fmCreate);
    end
    else
      FStream:=TMemoryStream.Create;

    //pump data to stream, then call synched proc
    try
      FStream.Size:=BytesToRead;
      FStream.Position:=0;

      FBytesTransferred:=0;
      FBytesToTransfer:=BytesToRead;

      if Assigned(FOnProgress) then
        Synchronize(HandleProgress);

      While BytesToRead>=FBytesForProgress do
      begin
        FClient.ReadStream(FStream,FBytesForProgress);
        BytesToRead:=BytesToRead-FBytesForProgress;
        FBytesTransferred:=FBytesTransferred+FBytesForProgress;
        if Assigned(FOnProgress) then
          Synchronize(HandleProgress);
      end;

      if BytesToRead>0 then
        FClient.ReadStream(FStream,BytesToRead);

      FStream.Position:=0;

      //Closing writestream, reopening as readstream
      if FStream is TFileStream then
      begin
        FStream.Free;
        FStream:=TFileStream.Create(TempFile,fmOpenRead);
      end;

      if Assigned(FOnProcessCommand) then
        Synchronize(HandleProcessCommand);
    finally
      //FStream.Free;
    end;
  except
    //FClient.Disconnect;
  end;
end;

function TClientThread.GetClient: TidTCPClient;
begin
  Result:=FClient;
end;

function TClientThread.GetOnProcessCommand: TProcessCommandEvent;
begin
  Result:=FOnProcessCommand;
end;

procedure TClientThread.HandleProcessCommand;
var DisposeStream:Boolean;
begin
  DisposeStream:=True;
  try
    if Assigned(FOnProcessCommand) then
      FOnProcessCommand(FCommand,FStream, DisposeStream);
  finally
    if DisposeStream then
      FStream.Free;
  end;    
end;

procedure TClientThread.HandleProgress;
begin
  if Assigned(FOnProgress) then
    FOnProgress(FClient,FBytesTransferred,FBytesToTransfer);
end;

procedure TClientThread.SetClient(const Value: TidTCPClient);
begin
  FClient:=Value;
end;

procedure TClientThread.SetOnProcessCommand(const Value: TProcessCommandEvent);
begin
  FOnProcessCommand:=Value;
end;

{ TSimpleTCPServer }

constructor TSimpleTCPServer.Create(Aowner: TComponent);
begin
  inherited;
  FBytesForProgress:=8192;
  FSizeForFileStream:=1024*1024*8;
  FCS:=TCriticalSection.Create;
  FConnections:=TSimpleTCPConnections.Create;
  FConnections.FServer:=Self;
  FServer:=TIDTCPServer.Create(Self);
  FServer.OnConnect:=InternalOnConnect;
  FServer.OnDisconnect:=InternalOnDisconnect;
  FServer.OnExecute:=ServerExecute;
end;

destructor TSimpleTCPServer.Destroy;
var i:integer;
begin
  for i:=FConnections.Count-1 downto 0 do
    FConnections[i].Disconnect;
  Sleep(500);

  FServer.Free;
  FConnections.Free;
  FCS.Free;
  inherited;
end;

function TSimpleTCPServer.GetActive: Boolean;
begin
  if (csDesigning in ComponentState) then
    Result:=FActive
  else
    Result:=FServer.Active;
end;

function TSimpleTCPServer.GetOnConnect: TServerEvent;
begin
  Result:=FOnConnect;
end;

function TSimpleTCPServer.GetOnDisconnect: TServerEvent;
begin
  Result:=FOnDisconnect;
end;

function TSimpleTCPServer.GetPort: Integer;
begin
  Result:=FServer.DefaultPort;
end;

procedure TSimpleTCPServer.HandleProcessCommand;
var DisposeStream:Boolean;
begin
  DisposeStream:=True;
  try
    ProcessCommand(FCommand, FConnection, FStream, DisposeStream);
  finally
    if DisposeStream then
      FStream.Free;
  end;
end;

procedure TSimpleTCPServer.ProcessCommand(Command: Integer; Connection:TSimpleTCPConnection;  Stream: TStream; var DisposeStream:Boolean);
begin
  if Assigned(FInterceptor) then
    FInterceptor.BeforeProcessCommand(Stream);

  if (Command=coData) and Assigned(FOnInput) then
    FOnInput(FConnection,Stream,DisposeStream);
end;

procedure TSimpleTCPServer.HandleOnConnect;
begin
  if Assigned(FOnConnect) then
    FOnConnect(FConnection);
end;

procedure TSimpleTCPServer.HandleOnDisconnect;
begin
  if Assigned(FOnDisconnect) then
    FOnDisconnect(FConnection);
end;

procedure TSimpleTCPServer.InternalOnconnect(AThread: TIDPeerThread);
begin
  FCS.Enter;
  try
    FConnection:=FConnections.Add(AThread);
    AThread.Synchronize(HandleOnConnect);
  finally
    FCS.Leave;
  end;
end;

procedure TSimpleTCPServer.InternalOnDisconnect(AThread: TIDPeerThread);
begin
  FCS.Enter;
  try
    FConnection:=FConnections.ByThread(AThread);
    FConnections.Delete(FConnection);
    AThread.Synchronize(HandleOnDisconnect);
    FConnection.Free;    

  finally
    FCS.Leave;
  end;
end;

procedure TSimpleTCPServer.ServerExecute(AThread: TIdPeerThread);
var Command:Integer;
var Stream:TStream;
var TempFile:String;
var BytesToTransfer,BytesTransferred,BytesToRead:Int64;
begin
  if (not AThread.Terminated) and (AThread.Connection.Connected) then
  try
    //set nonstopping breakpoint to ignore following exceptions
    AThread.Connection.ReadBuffer(Command, SizeOf(Command));
    //set nonstopping breakpoint to handle following exceptions

    //bytes to read?
    AThread.Connection.ReadBuffer(BytesToRead, SizeOf(BytesToRead));

    //if datasize is large, create a file stream,
    // else create faster memory stream
    if BytesToRead>=FSizeForFileStream then
    begin
      TempFile:=GetTempFile;
      Stream:=TFileStream.Create(TempFile,fmCreate)
    end
    else
      Stream:=TMemoryStream.Create;

    try
      Stream.Size:=BytesToRead;
      Stream.Position:=0;

      //triggering initial OnProgress event
      BytesTransferred:=0;
      BytesToTransfer:=BytesToRead;
      FCS.Enter;
      try
        FConnection:=FConnections.ByThread(AThread);
        FBytesTransferred:=BytesTransferred;
        FBytesToTransfer:=BytesToTransfer;

        if Assigned(FOnProgress) then
        AThread.Synchronize(HandleProgress);
      finally
        FCS.Leave;
      end;


      While BytesToRead>=FBytesForProgress do
      begin
        AThread.Connection.ReadStream(Stream,FBytesForProgress);
        BytesToRead:=BytesToRead-FBytesForProgress;
        BytesTransferred:=BytesTransferred+FBytesForProgress;

        //triggering OnProgress event
        FCS.Enter;
        try
          FConnection:=FConnections.ByThread(AThread);
          FBytesTransferred:=BytesTransferred;
          FBytesToTransfer:=BytesToTransfer;

          if Assigned(FOnProgress) then
            AThread.Synchronize(HandleProgress);
        finally
          FCS.Leave;
        end;
      end;

      if BytesToRead>0 then
        AThread.Connection.ReadStream(Stream,BytesToRead);
      Stream.Position:=0;

      //Closing writestream, reopening as readstream
      if Stream is TFileStream then
      begin
        Stream.Free;
        Stream:=TFileStream.Create(TempFile,fmOpenRead);
      end;

      //commandprocessing
      FCS.Enter;
      try
        FCommand:=Command;
        FConnection:=FConnections.ByThread(AThread);
        FStream:=Stream;
        AThread.Synchronize(HandleProcessCommand);
      finally
        FCS.Leave;
      end;
    finally
      //FStream.Free;
    end;
  except
    AThread.Connection.Disconnect;
    AThread.Terminate;
  end;
end;

procedure TSimpleTCPServer.SetActive(const Value: Boolean);
begin
  if (csDesigning in ComponentState) then
    FActive:=Value
  else
    FServer.Active:=Value;
end;

procedure TSimpleTCPServer.SetOnConnect(const Value: TServerEvent);
begin
  FOnConnect:=Value;
end;

procedure TSimpleTCPServer.SetOnDisconnect(const Value: TServerEvent);
begin
  FOnDisconnect:=Value;
end;

procedure TSimpleTCPServer.SetPort(const Value: Integer);
begin
  FServer.DefaultPort:=Value;
end;

procedure TSimpleTCPServer.SendCommand(Command: Integer;
  Connection: TSimpleTCPConnection; Stream: TStream);
var BytesToWrite:Int64;
begin
  if Assigned(FInterceptor) then
    FInterceptor.BeforeSendCommand(Stream);
  Stream.Position:=0;

  //send command
  Connection.FThread.Connection.WriteBuffer(Command,SizeOf(Command));

  //send size of following content
  BytesToWrite:=Stream.Size;
  Connection.FThread.Connection.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));

  //send content
  Connection.FThread.Connection.WriteStream(Stream);
end;

procedure TSimpleTCPServer.SendStream(Connection: TSimpleTCPConnection;
  Stream: TStream);
begin
  SendCommand(coData,Connection,Stream);
end;

procedure TSimpleTCPServer.HandleProgress;
begin
  if Assigned(FOnProgress) then
    FOnProgress(FConnection,FBytesTransferred,FBytesToTransfer);
end;

procedure TSimpleTCPServer.SendCommand(Command: Integer;
  Connection: TSimpleTCPConnection; Streams: array of TStream);
var BytesToWrite:Int64;
var i:integer;
begin
  if Assigned(Interceptor) then
    raise Exception.Create('Sending multiple streams not allowed with interceptor!');
  //calculate size
  BytesToWrite:=0;
  for i:=0 to Length(Streams)-1 do
    if Streams[i]<>NIL then
      BytesToWrite:=BytesToWrite+Streams[i].Size;

  //Sending data command
  Connection.FThread.Connection.WriteBuffer(Command,SizeOf(Command));

  //Sending size
  Connection.FThread.Connection.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));

  for i:=0 to Length(Streams)-1 do
  begin
    //write stream
    Streams[i].Position:=0;
    Connection.FThread.Connection.WriteStream(Streams[i]);
  end;
end;

{ TSimpleTCPClient }

constructor TSimpleTCPClient.Create(Aowner: TComponent);
begin
  inherited;
  FBytesForProgress:=8192;
  FSizeForFileStream:=1024*1024*8;  
  FClient:=TidTCPClient.Create(Self);
end;

destructor TSimpleTCPClient.Destroy;
begin
  FOnProgress:=NIL;
  FOnInput:=NIL;
  FClient.OnConnected:=NIL;
  FClient.OnDisconnected:=NIL;    
  Connected:=False;
  FClient.Free;
  inherited;
end;

function TSimpleTCPClient.GetConnected: Boolean;
begin
  Result:=FClient.Connected;
end;

function TSimpleTCPClient.GetHost: String;
begin
  Result:=FClient.Host;
end;

function TSimpleTCPClient.GetOnConnected: TNotifyEvent;
begin
  Result:=FClient.OnConnected;
end;

function TSimpleTCPClient.GetOnDisconnected: TNotifyEvent;
begin
  Result:=FClient.OnDisconnected;
end;

function TSimpleTCPClient.GetOnInput: THandleInputEvent;
begin
  Result:=FOnInput;
end;

function TSimpleTCPClient.GetOnProgress: TProgressEvent;
begin
  Result:=FOnProgress;
end;

function TSimpleTCPClient.GetPort: Integer;
begin
  Result:=FClient.Port;
end;

procedure TSimpleTCPClient.ProcessCommand(Command: Integer; Stream:TStream; var DisposeStream:Boolean);
begin
  if Assigned(FInterceptor) then
    FInterceptor.BeforeProcessCommand(Stream);

  if (Command=coData) and (Assigned(FOnInput)) then
    FOnInput(Self,Stream,DisposeStream);
end;

procedure TSimpleTCPClient.SendCommand(Command: Integer;
  Stream: TStream);
var BytesToWrite:Int64;
begin
  //Sending data command
  FClient.WriteBuffer(Command,SizeOf(Command));

  if Assigned(FInterceptor) then
    FInterceptor.BeforeSendCommand(Stream);

  if Stream=NIL then
  begin
    BytesToWrite:=0;
    FClient.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));
  end
  else
  begin
    //Write byte-Count
    BytesToWrite:=Stream.Size;
    FClient.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));
    //write stream
    Stream.Position:=0;
    FClient.WriteStream(Stream);
  end;
end;

procedure TSimpleTCPClient.SendCommand(Command: Integer;
  Streams: array of TStream);
var BytesToWrite:Int64;
var i:integer;
begin
  if Assigned(Interceptor) then
    raise Exception.Create('Sending multiple streams not allowed with interceptor!');

  //calculate size
  BytesToWrite:=0;
  for i:=0 to Length(Streams)-1 do
    if Streams[i]<>NIL then
      BytesToWrite:=BytesToWrite+Streams[i].Size;

  //Sending data command
  FClient.WriteBuffer(Command,SizeOf(Command));

  //Sending size
  FClient.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));

  for i:=0 to Length(Streams)-1 do
  begin
    //write stream
    Streams[i].Position:=0;
    FClient.WriteStream(Streams[i]);
  end;
end;

procedure TSimpleTCPClient.SendStream(AStream: TStream);
begin
  SendCommand(coData,AStream);
end;

procedure TSimpleTCPClient.SendStreams(AStreams: array of TStream);
begin
  SendCommand(CoData,AStreams);
end;

procedure TSimpleTCPClient.SetConnected(const Value: Boolean);
begin
  if (FClient.Connected) and not (Value) then
  begin
    FClient.Disconnect;
    FThread.Free;
  end;
  if not (FClient.Connected) and (Value) then
  begin
    FClient.Connect;
    FThread:=TClientThread.Create(True);
    FThread.OnProcessCommand:=ProcessCommand;
    FThread.OnProgress:=FOnProgress;
    FThread.Client:=FClient;
    FThread.BytesForProgress:=BytesForProgress;
    FThread.Resume;
  end;
end;

procedure TSimpleTCPClient.SetHost(const Value: String);
begin
  FClient.Host:=Value;
end;

procedure TSimpleTCPClient.SetOnConnected(const Value: TNotifyEvent);
begin
  FClient.OnConnected:=Value;
end;

procedure TSimpleTCPClient.SetOnDisconnected(const Value: TNotifyEvent);
begin
  FClient.OnDisconnected:=Value;
end;

procedure TSimpleTCPClient.SetOnInput(const Value: THandleInputEvent);
begin
  FOnInput:=Value;
end;

procedure TSimpleTCPClient.SetOnProgress(const Value: TProgressEvent);
begin
  FonProgress:=Value;
end;

procedure TSimpleTCPClient.SetPort(const Value: Integer);
begin
  FClient.Port:=Value;
end;

{ TSimpleTCPConnections }

function TSimpleTCPConnections.Add(
  AThread: TIDPeerThread): TSimpleTCPConnection;
begin
  Result:=TSimpleTCPConnection.Create(AThread);
  Result.FServer:=FServer;  
  FItems.Add(Result);
end;

function TSimpleTCPConnections.ByIPAndPort(PeerIP: String;
  PeerPort: Integer): TSimpleTCPConnection;
var i:integer;
begin
  Result:=NIL;
  for i:=0 to Count-1 do
    if (Items[i].FPeerIP=PeerIP) and (Items[i].FPeerPort=PeerPort) then
    begin
      Result:=Items[i];
      exit;
    end;
end;

function TSimpleTCPConnections.ByThread(
  AThread: TIDPeerThread): TSimpleTCPConnection;
var i:integer;
begin
  Result:=NIL;
  for i:=0 to Count-1 do
    if Items[i].FThread=AThread then
    begin
      Result:=Items[i];
      exit;
    end;
end;

procedure TSimpleTCPConnections.Clear;
var i:integer;
begin
  for i:=Count-1 downto 0 do
  begin
    Items[i].Disconnect;
    Items[i].Free;
    FItems.Delete(i);
  end;
end;

constructor TSimpleTCPConnections.Create;
begin
  FItems:=TList.Create;
end;

procedure TSimpleTCPConnections.Delete(Connection: TSimpleTCPConnection);
var i:integer;
begin
  for i:=0 to Count-1 do
    if Items[i]=Connection then
    begin
      FItems.Delete(i);
      exit;
    end;
end;

destructor TSimpleTCPConnections.Destroy;
begin
  Clear;
  FItems.Free;
  inherited;
end;

function TSimpleTCPConnections.GetCount: Integer;
begin
  Result:=FItems.Count;
end;

function TSimpleTCPConnections.GetItems(
  Index: Integer): TSimpleTCPConnection;
begin
  Result:=TSimpleTCPConnection(FItems[Index]);
end;

{ TSimpleTCPConnection }

constructor TSimpleTCPConnection.Create(AThread: TIDPeerThread);
begin
  FThread:=AThread;
  FPeerIP:=FThread.Connection.Socket.Binding.PeerIP;
  FPeerPort:=FThread.Connection.Socket.Binding.PeerPort;
end;

procedure TSimpleTCPConnection.Disconnect;
var Command:integer;
begin
  Command:=coDisconnect;
  if FThread.Connection.Connected then
    FThread.Connection.WriteBuffer(Command,SizeOf(Command));
  FThread.Connection.Disconnect;
end;

function TSimpleTCPConnection.GetPeerIP: String;
begin
  Result:=FPeerIP;
end;

function TSimpleTCPConnection.GetPeerPort: Integer;
begin
  Result:=FPeerPort;
end;

procedure TSimpleTCPConnection.SendStream(AStream: TStream);
var BytesToWrite:Int64;
var Command:Integer;
begin
  if Assigned(FServer.Interceptor) then
    FServer.Interceptor.BeforeSendCommand(AStream);

  //send data command
  Command:=coData;
  FThread.Connection.WriteBuffer(Command,SizeOf(Command));

  //send size of following content
  BytesToWrite:=AStream.Size;
  FThread.Connection.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));

  //send content
  FThread.Connection.WriteStream(AStream);
end;

procedure TSimpleTCPConnection.SendStreams(AStreams: array of TStream);
var BytesToWrite:Int64;
var i:integer;
begin
  if Assigned(FServer.Interceptor) then
    raise Exception.Create('Sending multiple streams not allowed with interceptor!');

  //calculate size
  BytesToWrite:=0;
  for i:=0 to Length(AStreams)-1 do
    if AStreams[i]<>NIL then
      BytesToWrite:=BytesToWrite+AStreams[i].Size;

  //Sending data command
  FThread.Connection.WriteBuffer(CoData,SizeOf(coData));

  //Sending size
  FThread.Connection.WriteBuffer(BytesToWrite,SizeOf(BytesToWrite));

  for i:=0 to Length(AStreams)-1 do
  begin
    //write stream
    AStreams[i].Position:=0;
    FThread.Connection.WriteStream(AStreams[i]);
  end;
end;
end.					

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:

unit SimpleTCPCompressor;

{*******************************************************************************
 Project       : SimpleTCP
 Filename      : SimpleTCPCompressor
 Date          : 2004-10-14
 Version       : 1.0.0.0
 Last modified : 2004-10-14
 Author        : Andreas Kreul a.k.a Udontknow
 URL           : www.xnebula.net
 Copyright     : Copyright (c) 2004 Andreas Kreul
 History       :

*******************************************************************************}


{*******************************************************************************

 Copyright (c) 2004, Andreas Kreul ["copyright holder(s)"]
 Partcopyright : Popov (function "GetTempFile", thx!)
 All rights reserved.

 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

 1. Redistributions of source code must retain the above copyright notice, this
    list of conditions and the following disclaimer.
 2. Redistributions in binary form must reproduce the above copyright notice,
    this list of conditions and the following disclaimer in the documentation
    and/or other materials provided with the distribution.
 3. The name(s) of the copyright holder(s) may not be used to endorse or
    promote products derived from this software without specific prior written
    permission.

 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
 AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
 DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY
 DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
 ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*******************************************************************************}


{*******************************************************************************

 This class implements onthefly data compression for the SimpleTCP-Components.
 If using data this data compression component, be sure to have the interceptor
 installed on both client and server, even if your are not using compression
 (CompressionLevel = clNone).

*******************************************************************************}


interface

uses SysUtils, Classes, ZLib, SimpleTCP;

type TSimpleTCPCompressor=class(TSimpleTCPInterceptor)
  private
    FCompressionLevel:TCompressionLevel;
  public
    procedure BeforeSendCommand(const Stream:TStream); override;
    procedure BeforeProcessCommand(const Stream:TStream); override;
  published
    constructor Create(AOwner:TComponent); override;
    property CompressionLevel:TCompressionLevel read FCompressionLevel write FCompressionLevel;
end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Simple Network',[TSimpleTCPCompressor]);
end;

{ TSimpleTCPCompressor }

procedure TSimpleTCPCompressor.BeforeProcessCommand(const Stream: TStream);
var SourceStream:TStream;
var DecompressStream:TStream;
var L:Cardinal;
begin
  if Stream=NIL then
    exit;
  try
    //create temporary stream
    if Stream.Size<=8*1024*1024 then
      SourceStream:=TMemoryStream.Create
    else
      SourceStream:=TFileStream.Create(GetTempFile,fmCreate);
    try
      //copy stream content to temporary stream
      Stream.Position:=0;
      SourceStream.CopyFrom(Stream,0);
      SourceStream.Position:=0;
      Stream.Position:=0;
      Stream.Size:=0;

      //decompress it to original stream
      SourceStream.ReadBuffer(L,SizeOf(L));
      DecompressStream:=TDeCompressionStream.Create(SourceStream);
      try
        Stream.CopyFrom(DecompressStream,L);
      finally
        DecompressStream.Free;
      end;
      Stream.Position:=0;

    finally
      SourceStream.Free;
    end;
  except
    On E:Exception do
      raise Exception.Create(Classname+': Could not decompress data! '+E.Message);
  end;
end;

procedure TSimpleTCPCompressor.BeforeSendCommand(const Stream: TStream);
var SourceStream:TStream;
var CompressStream:TStream;
var L:Cardinal;
begin
  if Stream=NIL then
    exit;

  L:=Stream.Size;

  //create temporary stream
  if Stream.Size<=8*1024*1024 then
    SourceStream:=TMemoryStream.Create
  else
    SourceStream:=TFileStream.Create(GetTempFile,fmCreate);
  try
    //copy content
    Stream.Position:=0;
    SourceStream.CopyFrom(Stream,0);
    SourceStream.Position:=0;
    Stream.Position:=0;
    Stream.Size:=0;

    //write compressed data to original stream
    Stream.WriteBuffer(L,SizeOf(L));
    compressStream:=TCompressionStream.Create(clMax,Stream);
    try
      CompressStream.CopyFrom(SourceStream,L);
    finally
      CompressStream.Free;
    end;
    Stream.Position:=0;

  finally
    SourceStream.Free;
  end;
end;

constructor TSimpleTCPCompressor.Create(AOwner:TComponent);
begin
  inherited;
  FCompressionLevel:=clDefault;
end;

end.					

1:
2:
3:
4:
5:

procedure TForm3.Button1Click(Sender: TObject);
begin
client.Host:='localhost';
client.Connected:=true;
end;					

1:
2:
3:
4:

procedure TForm2.ServerConnect(Connection: TSimpleTCPConnection);
begin
Listbox1.Items.Add(Connection.PeerIP);
end;