1 // *****************************************************************************

2 // File : UServer.pas
3 // Project : MicroServer.dpr
4 // Easy example of TCP Server with indy component : TidTCPSever
5 //
6 // see indy doc: http://www.indyproject.org/sockets/docs/index.en.aspx
7 //
8 //
9 // *****************************************************************************
10 unit UServer;
11
12 interface
13
14 uses
15 Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics,
16 Vcl.Controls, Vcl.Forms, Vcl.Dialogs, IdContext, IdComponent, Vcl.StdCtrls,
17 IdBaseComponent, IdCustomTCPServer, IdThreadSafe, IdTCPConnection, IdYarn,
IdTCPServer, Vcl.ExtCtrls;
18
19
20 type
21 TFServer = class(TForm)
22
23 Title : TLabel;
24
25 btn_start : TButton;
26 btn_stop : TButton;
27 btn_clear : TButton;
28
29 clients_connected : TLabel;
30 Label1 : TLabel;
31 Panel1 : TPanel;
32 messagesLog : TMemo;
33
34 procedure FormCreate(Sender: TObject);
35 procedure FormShow(Sender: TObject);
36
37 procedure btn_startClick(Sender: TObject);
38 procedure btn_stopClick(Sender: TObject);
39 procedure btn_clearClick(Sender: TObject);
40
41 procedure IdTCPServerConnect(AContext: TIdContext);
42 procedure IdTCPServerDisconnect(AContext: TIdContext);
43 procedure IdTCPServerExecute(AContext: TIdContext);
44 procedure IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
45 const AStatusText: string);
46
47 procedure ShowNumberOfClients(p_disconnected : Boolean=False);
48
49 procedure BroadcastMessage(p_message : string);
50
51 procedure Display(p_sender, p_message : string);
52 function GetNow():String;
53
54
55 private
56 { Private declarations }
57
58 public
59 { Public declarations }
60
61 end;
62 // ...
63
64
65 // ... listening port
66 const GUEST_CLIENT_PORT = 20010;
67
68 var
69 FServer : TFServer;
70
71 // ... Id TCP Server
 72 IdTCPServer : TIdTCPServer;
73
74 implementation
75
76 {$R *.dfm}
77
78 // *****************************************************************************
79 // EVENT : onCreate()
80 // ON FORM CREATE
81 // *****************************************************************************
82 procedure TFServer.FormCreate(Sender: TObject);
83 begin
84
85 // ... create idTCPServer
86 IdTCPServer := TIdTCPServer.Create(self);
87 IdTCPServer.Active := False;
88
89 // ... set properties
90 IdTCPServer.MaxConnections := 20;
91
92 // ... etc..
93
94 // ... assign a new context class (if you need)
95 // IdTCPServer.ContextClass := TYourContext;
96
97 // ... add some callback functions
98 IdTCPServer.OnConnect := IdTCPServerConnect;
99 IdTCPServer.OnDisconnect := IdTCPServerDisconnect;
100 IdTCPServer.OnExecute := IdTCPServerExecute;
101 IdTCPServer.OnStatus := IdTCPServerStatus;
102 // ... etc..
103
104 end;
105 // .............................................................................
106
107
108 // *****************************************************************************
109 // EVENT : onShow()
110 // ON FORM SHOW
111 // *****************************************************************************
112 procedure TFServer.FormShow(Sender: TObject);
113 begin
114 // ... INITIALIZE:
115
116 // ... clear message log
117 messagesLog.Lines.Clear;
118
119 // ... zero to clients connected
120 clients_connected.Caption := inttostr(0);
121
122 // ... set buttons
123 btn_start.enabled := True;
124 btn_stop.enabled := False;
125 end;
126 // .............................................................................
127
128
129 // *****************************************************************************
130 // EVENT : btn_startClick()
131 // CLICK ON START BUTTON
132 // *****************************************************************************
133 procedure TFServer.btn_startClick(Sender: TObject);
134 begin
135 // ... START SERVER:
136
137 // ... clear the Bindings property ( ... Socket Handles )
138 IdTCPServer.Bindings.Clear;
139 // ... Bindings is a property of class: TIdSocketHandles;
140
141 // ... add listening ports:
142
143 // ... add a port for connections from guest clients.
144 IdTCPServer.Bindings.Add.Port := GUEST_CLIENT_PORT;
145 // ... etc..
146
147
148 // ... ok, Active the Server!
149 IdTCPServer.Active := True;
150
151 // ... disable start button
152 btn_start.enabled := False;
153
154 // ... enable stop button
155 btn_stop.enabled := True;
156
157 // ... message log
158 Display('SERVER', 'STARTED!');
159
160 end;
161 // .............................................................................
162
163
164 // *****************************************************************************
165 // EVENT : btn_stopClick()
166 // CLICK ON STOP BUTTON
167 // *****************************************************************************
168 procedure TFServer.btn_stopClick(Sender: TObject);
169 begin
170
171 // ... before stopping the server ... send 'good bye' to all clients connected
172 BroadcastMessage('Goodbye Client ');
173
174 // ... stop server!
175 IdTCPServer.Active := False;
176
177 // ... hide stop button
178 btn_stop.enabled := False;
179
180 // ... show start button
181 btn_start.enabled := True;
182
183 // ... message log
184 Display('SERVER', 'STOPPED!');
185
186 end;
187 // .............................................................................
188
189
190 // *****************************************************************************
191 // EVENT : btn_clearClick()
192 // CLICK ON CLEAR BUTTON
193 // *****************************************************************************
194 procedure TFServer.btn_clearClick(Sender: TObject);
195 begin
196 //... clear messages log
197 MessagesLog.Lines.Clear;
198 end;
199 // .............................................................................
200
201 // .............................................................................
202 // .............................................................................
203 // .............................................................................
204
205 // *****************************************************************************
206 // EVENT : onConnect()
207 // OCCURS ANY TIME A CLIENT IS CONNECTED
208 // *****************************************************************************
209 procedure TFServer.IdTCPServerConnect(AContext: TIdContext);
210 var
211 ip : string;
212 port : Integer;
213 peerIP : string;
214 peerPort : Integer;
215
216 nClients : Integer;
217
218 msgToClient : string;
219 typeClient : string;
220
221 begin
222 // ... OnConnect is a TIdServerThreadEvent property that represents the event
223 // handler signalled when a new client connection is connected to the server.
224
225 // ... Use OnConnect to perform actions for the client after it is connected
226 // and prior to execution in the OnExecute event handler.
227
228 // ... see indy doc:
229 // http://www.indyproject.org/sockets/docs/index.en.aspx
230
231 // ... getting IP address and Port of Client that connected
232 ip := AContext.Binding.IP;
233 port := AContext.Binding.Port;
234 peerIP := AContext.Binding.PeerIP;
235 peerPort := AContext.Binding.PeerPort;
236
237 // ... message log
238 Display('SERVER', 'Client Connected!');
239 Display('SERVER', 'Port=' + IntToStr(Port)
240 + ' ' + '(PeerIP=' + PeerIP
241 + ' - ' + 'PeerPort=' + IntToStr(PeerPort) + ')'
242 );
243
244 // ... display the number of clients connected
245 ShowNumberOfClients();
246
247 // ... CLIENT CONNECTED:
248 case Port of
249 GUEST_CLIENT_PORT : begin
250 // ... GUEST CLIENTS
251 typeClient := 'GUEST';
252 end;
253 // ...
254 end;
255
256 // ... send the Welcome message to Client connected
257 msgToClient := 'Welcome ' + typeClient + ' ' + 'Client :)';
258 AContext.Connection.IOHandler.WriteLn( msgToClient );
259
260 end;
261 // .............................................................................
262
263 // *****************************************************************************
264 // EVENT : onDisconnect()
265 // OCCURS ANY TIME A CLIENT IS DISCONNECTED
266 // *****************************************************************************
267 procedure TFServer.IdTCPServerDisconnect(AContext: TIdContext);
268 var
269 ip : string;
270 port : Integer;
271 peerIP : string;
272 peerPort : Integer;
273
274 nClients : Integer;
275 begin
276
277 // ... getting IP address and Port of Client that connected
278 ip := AContext.Binding.IP;
279 port := AContext.Binding.Port;
280 peerIP := AContext.Binding.PeerIP;
281 peerPort := AContext.Binding.PeerPort;
282
283 // ... message log
284 Display('SERVER', 'Client Disconnected! Peer=' + PeerIP + ':' +
IntToStr(PeerPort));
285
286 // ... display the number of clients connected
287 ShowNumberOfClients(true);
288 end;
289 // .............................................................................
290
291
292 // *****************************************************************************
293 // EVENT : onExecute()
294 // ON EXECUTE THREAD CLIENT
295 // *****************************************************************************
296 procedure TFServer.IdTCPServerExecute(AContext: TIdContext);
297 var
298 Port : Integer;
299 PeerPort : Integer;
300 PeerIP : string;
301
302 msgFromClient : string;
303 msgToClient : string;
304 begin
305
306 // ... OnExecute is a TIdServerThreadEvents event handler used to execute
307 // the task for a client connection to the server.
308
309 // ... here you can check connection status and buffering before reading
310 // messages from client
311
312 // ... see doc:
313 // ... AContext.Connection.IOHandler.InputBufferIsEmpty
314 // ... AContext.Connection.IOHandler.CheckForDataOnSource(<milliseconds>);
315 // (milliseconds to wait for the connection to become readable)
316 // ... AContext.Connection.IOHandler.CheckForDisconnect;
317
318 // ... received a message from the client
319
320 // ... get message from client
321 msgFromClient := AContext.Connection.IOHandler.ReadLn;
322
323 // ... getting IP address, Port and PeerPort from Client that connected
324 peerIP := AContext.Binding.PeerIP;
325 peerPort := AContext.Binding.PeerPort;
326
327 // ... message log
328 Display('CLIENT', '(Peer=' + PeerIP + ':' + IntToStr(PeerPort) + ') ' +
msgFromClient);
329 // ...
330
331 // ... process message from Client
332
333 // ...
334
335 // ... send response to Client
336
337 AContext.Connection.IOHandler.WriteLn('... message sent from server :)');
338
339 end;
340 // .............................................................................
341
342
343 // *****************************************************************************
344 // EVENT : onStatus()
345 // ON STATUS CONNECTION
346 // *****************************************************************************
347 procedure TFServer.IdTCPServerStatus(ASender: TObject; const AStatus: TIdStatus;
348 const AStatusText: string);
349 begin
350 // ... OnStatus is a TIdStatusEvent property that represents the event handler
351 // triggered when the current connection state is changed...
352
353 // ... message log
354 Display('SERVER', AStatusText);
355 end;
356 // .............................................................................
357
358
359 // *****************************************************************************
360 // FUNCTION : getNow()
361 // GET MOW DATE TIME
362 // *****************************************************************************
363 function TFServer.getNow() : String;
364 begin
365 Result := FormatDateTime('yyyy-mm-dd hh:nn:ss', Now) + ': ';
366 end;
367 // .............................................................................
368
369
370 // *****************************************************************************
371 // PROCEDURE : broadcastMessage()
372 // BROADCAST A MESSAGE TO ALL CLIENTS CONNECTED
373 // *****************************************************************************
374 procedure TFServer.broadcastMessage(p_message : string);
375 var
376 tmpList : TList;
377 contexClient : TidContext;
378 nClients : Integer;
379 i : integer;
380 begin
381
382 // ... send a message to all clients connected
383
384 // ... get context Locklist
385 tmpList := IdTCPServer.Contexts.LockList;
386
387 try
388 i := 0;
389 while ( i < tmpList.Count ) do begin
390 // ... get context (thread of i-client)
391 contexClient := tmpList[i];
392
393 // ... send message to client
394 contexClient.Connection.IOHandler.WriteLn(p_message);
395 i := i + 1;
396 end;
397
398 finally
399 // ... unlock list of clients!
400 IdTCPServer.Contexts.UnlockList;
401 end;
402 end;
403 // .............................................................................
404
405 // *****************************************************************************
406 // PROCEDURE : Display()
407 // DISPLAY MESSAGE UPON SYSOUT
408 // *****************************************************************************
409 procedure TFServer.Display(p_sender : String; p_message : string);
410 begin
411 // ... DISPLAY MESSAGE
412 TThread.Queue(nil, procedure
413 begin
414 MessagesLog.Lines.Add('[' + p_sender + '] - '
415 + getNow() + ': ' + p_message);
416 end
417 );
418
419 // ... see doc..
420 // ... TThread.Queue() causes the call specified by AMethod to
421 // be asynchronously executed using the main thread, thereby avoiding
422 // multi-thread conflicts.
423 end;
424 // .............................................................................
425
426 // *****************************************************************************
427 // PROCEDURE : ShowNumberOfClients()
428 // NUMBER OF CLIENTS CONNECTD
429 // *****************************************************************************
430 procedure TFServer.ShowNumberOfClients(p_disconnected : Boolean=False);
431 var
432 nClients : integer;
433 begin
434
435 try
436 // ... get number of clients connected
437 nClients := IdTCPServer.Contexts.LockList.Count;
438 finally
439 IdTCPServer.Contexts.UnlockList;
440 end;
441
442 // ... client disconnected?
443 if p_disconnected then dec(nClients);
444
445 // ... display
446 TThread.Queue(nil, procedure
447 begin
448 clients_connected.Caption := IntToStr(nClients);
449 end
450 );
451 end;
452 // .............................................................................
453
454
455 end.