13-02-2019, Saat: 11:02
Arkadaşlar merhaba, bir projede kullanmak üzere bir örnekten yararlanarak soket programı yazdım (kodlar aşağıda), thread ile kontrol sağlamaya çalıştım, şu an için 3-4 makinada sorunsuz çalışıyor. Konu hakkında uzman arkadaşlar kodu inceleyip ileride bir sorun çıkartırmı veya kodun yazılışında bir sorun varmı, ilaveler yapılabilirmi vs.vs. gibi kafamdaki sorular hakkında yorum yapabilirlerse memnun olurum. İleride 100 civarı (yerel ve uzak bağlantı şeklinde) kullanıcı bağlanacak şekilde kullanmayı düşünüyorum.
unit http_listen; {$mode objfpc}{$H+} //{$DEFINE Debug} interface uses Classes, SysUtils, blcksock, sockets, Synautil, // synapse fpjson, jsonparser, // json StdCtrls; type TPassMessage = procedure(AMsg: string) of object; { TClientRaw } TClientRaw = class(TThread) protected FId: Integer; FClientSocket: TTCPBlockSocket; FMsg1: TPassMessage; procedure Execute; override; public constructor Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage) ; end; { TClient } TClient = class(TThread) protected FId: Integer; FClientSocket: TTCPBlockSocket; FMsg: TPassMessage; procedure Execute; override; public constructor Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage) ; end; { TLightWeb } TLightWeb = class(TThread) private _Port: word; _PassMessage: TPassMessage; procedure TriggerMessage(AMsg: string); protected procedure Execute; override; public constructor Create(APort: word); destructor Destroy; override; property OnPassMessage: TPassMessage read _PassMessage write _PassMessage; end; var Const HtmlHeader : String = 'HTTP/1.0 200' + CRLF + 'Content-type: Text/Html; charset=utf-8;' + CRLF + 'Connection: close' + CRLF + 'Server: Lazarus Synapse' + CRLF+ 'Access-Control-Allow-Origin: *' + CRLF; implementation { TClientRaw } constructor TClientRaw.Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage); begin inherited Create(False); Randomize; FId := Id; FMsg1 := OnPassMessage; FMsg1(IntToStr(FId) + ' - Create'); FClientSocket := TTCPBlockSocket.Create; FClientSocket.Socket := ASocket.accept; end; procedure TClientRaw.Execute; var timeout: integer; OutputDataString : String; MS:TMemoryStream; begin timeout := 120000; try try FClientSocket.RecvStreamRaw(MS,timeout); OutputDataString:='Veri Geldi'; FClientSocket.SendString(HtmlHeader); FClientSocket.SendString('Content-length: ' + IntTostr(Length(OutputDataString)) + CRLF); // mesaj boyutunu yaz FClientSocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF); FClientSocket.SendString('' + CRLF); FClientSocket.SendString(OutputDataString); except on E: Exception do begin FMsg1(IntToStr(FId) + ' - Hata'); end; end; finally FClientSocket.CloseSocket; FreeAndNil(FClientSocket); FMsg1(IntToStr(FId) + ' - Finally'); end; end; { TClient } constructor TClient.Create(Id: Integer; ASocket: TTCPBlockSocket; OnPassMessage: TPassMessage); begin inherited Create(False); Randomize; FId := Id; FMsg := OnPassMessage; FMsg(IntToStr(FId) + ' - Create'); FClientSocket := TTCPBlockSocket.Create; FClientSocket.Socket := ASocket.accept; end; procedure TClient.Execute; var timeout: integer; message: TStringList; OutputDataString : String; recv : string; begin timeout := 120000; message := TStringList.Create; try try message.Append(FClientSocket.RecvString(Timeout)); if (pos('komut=',message.Strings[message.Count - 1])>0) then begin recv:=copy(message.Strings[message.Count - 1], pos('komut=',message.Strings[message.Count - 1])+6, length(message.Strings[message.Count - 1])); delete(recv, pos('HTTP',recv)-1,50); FMsg('---Gelen = ' + DecodeUrl(recv)); OutputDataString:='---Gelen = ' + DecodeUrl(recv); end else Exit; FClientSocket.SendString(HtmlHeader); FClientSocket.SendString('Content-length: ' + IntTostr(Length(OutputDataString)) + CRLF); // mesaj boyutunu yaz FClientSocket.SendString('Date: ' + Rfc822DateTime(now) + CRLF); FClientSocket.SendString('' + CRLF); FClientSocket.SendString(OutputDataString); except on E: Exception do begin FMsg(IntToStr(FId) + ' - Hata'); end; end; finally FreeAndNil(message); FClientSocket.CloseSocket; FreeAndNil(FClientSocket); FMsg(IntToStr(FId) + ' - Finally'); end; end; { TLightWeb } constructor TLightWeb.Create(APort: word); begin inherited Create(False); _Port := Aport; TId:=0; end; procedure TLightWeb.Execute; var Cl : TClient; C2 : TClientRaw; ListenerSocket, BlckSocket: TTCPBlockSocket; begin try ListenerSocket := TTCPBlockSocket.Create; BlckSocket := TTCPBlockSocket.Create; ListenerSocket.CreateSocket; ListenerSocket.SetLinger(True, 100); ListenerSocket.bind('0.0.0.0', IntToStr(_Port)); ListenerSocket.listen; repeat if ListenerSocket.canread(10000) then begin // can read If _Port=5050 Then Begin Cl := TClient.Create(ClientId, ListenerSocket, _PassMessage); Cl.Start; End; If _Port=5051 Then Begin C2 := TClientRaw.Create(ClientId, ListenerSocket, _PassMessage); C2.Start; End; End; // can read until Terminated; finally FreeAndNil(ListenerSocket); end; end; procedure TLightWeb.TriggerMessage(AMsg: string); begin if Assigned(_PassMessage) then _PassMessage(AMsg); end; destructor TLightWeb.Destroy(); begin inherited Destroy; end; end.