1 | unit UCommTCPServer;
|
---|
2 |
|
---|
3 | {$mode Delphi}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | Classes, SysUtils, blcksock, synsock, UCommPin, UCommon, UThreading,
|
---|
9 | DateUtils, SpecializedList;
|
---|
10 |
|
---|
11 | type
|
---|
12 | TCommTCPServer = class;
|
---|
13 |
|
---|
14 | TReceiveDataEvent = procedure(Stream: TMemoryStream) of object;
|
---|
15 |
|
---|
16 | { TCommSocketReceiveThread }
|
---|
17 |
|
---|
18 | TCommSocketReceiveThread = class(TListedThread)
|
---|
19 | public
|
---|
20 | Parent: TCommTCPServer;
|
---|
21 | Stream: TListByte;
|
---|
22 | procedure Execute; override;
|
---|
23 | constructor Create(CreateSuspended: Boolean;
|
---|
24 | const StackSize: SizeUInt = DefaultStackSize);
|
---|
25 | destructor Destroy; override;
|
---|
26 | end;
|
---|
27 |
|
---|
28 | TSocketConnectEvent = procedure(Sender: TCommTCPServer; Pin: TCommPin) of object;
|
---|
29 |
|
---|
30 | { TCommTCPServerSession }
|
---|
31 |
|
---|
32 | TCommTCPServerSession = class
|
---|
33 | private
|
---|
34 | procedure ReceiveData(Sender: TCommPin; Stream: TListByte);
|
---|
35 | public
|
---|
36 | Server: TCommTCPServer;
|
---|
37 | Socket: TTCPBlockSocket;
|
---|
38 | Pin: TCommPin;
|
---|
39 | constructor Create;
|
---|
40 | destructor Destroy; override;
|
---|
41 | end;
|
---|
42 |
|
---|
43 | { TCommTCPServer }
|
---|
44 |
|
---|
45 | TCommTCPServer = class(TCommNode)
|
---|
46 | private
|
---|
47 | FActive: Boolean;
|
---|
48 | FOnConnect: TSocketConnectEvent;
|
---|
49 | FOnDisconnect: TSocketConnectEvent;
|
---|
50 | //FOnReceiveData: TReceiveDataEvent;
|
---|
51 | FReceiveThread: TCommSocketReceiveThread;
|
---|
52 | protected
|
---|
53 | procedure SetActive(const AValue: Boolean); override;
|
---|
54 | public
|
---|
55 | Sessions: TListObject; // TListObject<TCommTCPServerSession>
|
---|
56 | Socket: TTCPBlockSocket;
|
---|
57 | Address: string;
|
---|
58 | Port: Word;
|
---|
59 | property Active: Boolean read FActive write SetActive;
|
---|
60 | property OnConnect: TSocketConnectEvent read FOnConnect write FOnConnect;
|
---|
61 | property OnDisconnect: TSocketConnectEvent read FOnDisconnect write FOnDisconnect;
|
---|
62 | constructor Create(AOwner: TComponent); override;
|
---|
63 | destructor Destroy; override;
|
---|
64 | end;
|
---|
65 |
|
---|
66 | implementation
|
---|
67 |
|
---|
68 | { TCommTCPServerSession }
|
---|
69 |
|
---|
70 | procedure TCommTCPServerSession.ReceiveData(Sender: TCommPin; Stream: TListByte);
|
---|
71 | var
|
---|
72 | Mem: TMemoryStream;
|
---|
73 | begin
|
---|
74 | try
|
---|
75 | Mem := TMemoryStream.Create;
|
---|
76 | Stream.WriteToStream(Mem);
|
---|
77 | Mem.Position := 0;
|
---|
78 | Socket.SendStreamRaw(Mem);
|
---|
79 | finally
|
---|
80 | Mem.Free;
|
---|
81 | end;
|
---|
82 | end;
|
---|
83 |
|
---|
84 | constructor TCommTCPServerSession.Create;
|
---|
85 | begin
|
---|
86 | Socket := TTCPBlockSocket.Create;
|
---|
87 | Pin := TCommPin.Create;
|
---|
88 | Pin.OnReceive := ReceiveData;
|
---|
89 | Pin.Node := Server;
|
---|
90 | end;
|
---|
91 |
|
---|
92 | destructor TCommTCPServerSession.Destroy;
|
---|
93 | begin
|
---|
94 | Pin.Free;
|
---|
95 | Socket.Free;
|
---|
96 | inherited Destroy;
|
---|
97 | end;
|
---|
98 |
|
---|
99 | { TCommSocketReceiveThread }
|
---|
100 |
|
---|
101 | procedure TCommSocketReceiveThread.Execute;
|
---|
102 | var
|
---|
103 | InBufferUsed: Integer;
|
---|
104 | Buffer: array of Byte;
|
---|
105 | NewSocket: TSocket;
|
---|
106 | NewSession: TCommTCPServerSession;
|
---|
107 | I: Integer;
|
---|
108 | DoSleep: Boolean;
|
---|
109 | begin
|
---|
110 | with Parent do begin
|
---|
111 | repeat
|
---|
112 | DoSleep := True;
|
---|
113 |
|
---|
114 | // Check if new connection is available
|
---|
115 | if Assigned(Socket) then
|
---|
116 | with Socket do
|
---|
117 | if CanRead(0) then begin
|
---|
118 | NewSocket := Accept;
|
---|
119 | if Assigned(FOnConnect) then begin
|
---|
120 | NewSession := TCommTCPServerSession.Create;
|
---|
121 | NewSession.Server := Parent;
|
---|
122 | NewSession.Socket.Socket := NewSocket;
|
---|
123 | if Assigned(FOnConnect) then FOnConnect(Parent, NewSession.Pin);
|
---|
124 | Parent.Sessions.Add(NewSession);
|
---|
125 | DoSleep := False;
|
---|
126 | end;
|
---|
127 | end;
|
---|
128 |
|
---|
129 | // Check available data on all opened sockets
|
---|
130 | for I := 0 to Sessions.Count - 1 do
|
---|
131 | with TCommTCPServerSession(Sessions[I]) do begin
|
---|
132 | InBufferUsed := Socket.WaitingData;
|
---|
133 | if (not Pin.Connected) or (Socket.Socket = INVALID_SOCKET) or
|
---|
134 | (Socket.LastError <> 0) then begin
|
---|
135 | if Assigned(FOnDisconnect) then FOnDisconnect(Self.Parent, Pin);
|
---|
136 | end;
|
---|
137 |
|
---|
138 | if InBufferUsed > 0 then begin
|
---|
139 | SetLength(Buffer, InBufferUsed);
|
---|
140 | Socket.RecvBuffer(Buffer, Length(Buffer));
|
---|
141 | //if Socket.Socket = INVALID_SOCKET then Break;
|
---|
142 |
|
---|
143 | Stream.Count := Length(Buffer);
|
---|
144 | Stream.ReplaceBuffer(0, PByte(Buffer)^, Length(Buffer));
|
---|
145 | Pin.Send(Stream);
|
---|
146 | DoSleep := False;
|
---|
147 | end;
|
---|
148 | end;
|
---|
149 | if DoSleep and not Terminated then Sleep(1);
|
---|
150 | until Terminated;
|
---|
151 | end;
|
---|
152 | end;
|
---|
153 |
|
---|
154 | constructor TCommSocketReceiveThread.Create(CreateSuspended: Boolean;
|
---|
155 | const StackSize: SizeUInt);
|
---|
156 | begin
|
---|
157 | inherited;
|
---|
158 | Stream := TListByte.Create;
|
---|
159 | end;
|
---|
160 |
|
---|
161 | destructor TCommSocketReceiveThread.Destroy;
|
---|
162 | begin
|
---|
163 | Stream.Free;
|
---|
164 | inherited Destroy;
|
---|
165 | end;
|
---|
166 |
|
---|
167 | { TCommTCPServer }
|
---|
168 |
|
---|
169 | procedure TCommTCPServer.SetActive(const AValue: Boolean);
|
---|
170 | begin
|
---|
171 | if FActive = AValue then Exit;
|
---|
172 | FActive := AValue;
|
---|
173 |
|
---|
174 | if AValue then begin
|
---|
175 | Socket.Bind(Address, IntToStr(Port));
|
---|
176 | if Socket.LastError <> 0 then raise Exception.Create('Bind error' + Socket.GetErrorDesc(Socket.LastError));
|
---|
177 | Socket.Listen;
|
---|
178 | if Socket.LastError <> 0 then raise Exception.Create('Listen error');
|
---|
179 | FReceiveThread := TCommSocketReceiveThread.Create(True);
|
---|
180 |
|
---|
181 | FReceiveThread.FreeOnTerminate := False;
|
---|
182 | FReceiveThread.Parent := Self;
|
---|
183 | FReceiveThread.Start;
|
---|
184 | end else begin
|
---|
185 | Socket.CloseSocket;
|
---|
186 | FReceiveThread.Terminate;
|
---|
187 | FReceiveThread.WaitFor;
|
---|
188 | FreeAndNil(FReceiveThread);
|
---|
189 | end;
|
---|
190 | end;
|
---|
191 |
|
---|
192 | constructor TCommTCPServer.Create(AOwner: TComponent);
|
---|
193 | begin
|
---|
194 | inherited;
|
---|
195 | Sessions := TListObject.Create;
|
---|
196 | Socket := TTCPBlockSocket.Create;
|
---|
197 | end;
|
---|
198 |
|
---|
199 | destructor TCommTCPServer.Destroy;
|
---|
200 | begin
|
---|
201 | Active := False;
|
---|
202 | Socket.Free;
|
---|
203 | Sessions.Free;
|
---|
204 | inherited Destroy;
|
---|
205 | end;
|
---|
206 |
|
---|
207 | end.
|
---|
208 |
|
---|