mORMot and Open Source friends
Check-in [6934f79766]
Not logged in

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:{5957} refactored THttpServer internal execution flag
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 6934f7976645e0ed4dbd80df56d0c38a3a9e61ab
User & Date: ab 2020-04-16 18:40:10
Context
2020-04-19
11:36
{5958} introducing TSynLogFamily.ExceptionIgnorePerThread property check-in: 07e21d977f user: ab tags: trunk
2020-04-16
18:40
{5957} refactored THttpServer internal execution flag check-in: 6934f79766 user: ab tags: trunk
17:32
{5956} Socket.Bind should throw in case of fatal error during bind - from https://github.com/synopse/mORMot/pull/309 check-in: d511e65f58 user: ab tags: trunk
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to SynCrtSock.pas.

1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
....
6104
6105
6106
6107
6108
6109
6110
6111
6112
6113
6114
6115
6116
6117
6118
....
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
....
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
6273
....
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
6324
    fServerKeepAliveTimeOut: cardinal;
    fTCPPrefix: SockString;
    fSock: TCrtSocket;
    fThreadRespClass: THttpServerRespClass;
    fOnSendFile: TOnHttpServerSendFile;
    fNginxSendFileFrom: array of TFileName;
    fHTTPQueueLength: cardinal;
    fExecuteFinished: boolean;
    fStats: array[THttpServerSocketGetRequestResult] of integer;
    fSocketClass: THttpServerSocketClass;
    fHeadersNotFiltered: boolean;
    function GetStat(one: THttpServerSocketGetRequestResult): integer;
    function GetHTTPQueueLength: Cardinal; override;
    procedure SetHTTPQueueLength(aValue: Cardinal); override;
    procedure InternalHttpServerRespListAdd(resp: THttpServerResp);
................................................................................
constructor THttpServer.Create(const aPort: SockString; OnStart,
  OnStop: TNotifyThreadEvent; const ProcessName: SockString;
  ServerThreadPoolCount: integer; KeepAliveTimeOut: integer;
  HeadersUnFiltered: boolean);
begin
  fInternalHttpServerRespList := {$ifdef FPC}TFPList{$else}TList{$endif}.Create;
  InitializeCriticalSection(fProcessCS);
  fExecuteFinished := true; // prevent hangs in case of Bind error
  fSock := TCrtSocket.Bind(aPort); // BIND + LISTEN
  fServerKeepAliveTimeOut := KeepAliveTimeOut; // 30 seconds by default
  if fThreadPool<>nil then
    fThreadPool.ContentionAbortDelay := 5000; // 5 seconds default
  // event handlers set before inherited Create to be visible in childs
  fOnHttpThreadStart := OnStart;
  SetOnTerminate(OnStop);
................................................................................
var endtix: Int64;
    i: integer;
    resp: THttpServerResp;
begin
  Terminate; // set Terminated := true for THttpServerResp.Execute
  if fThreadPool<>nil then
    fThreadPool.fTerminated := true; // notify background process
  if not fExecuteFinished and (Sock<>nil) then begin
    Sock.Close; // shutdown the socket to unlock Accept() in Execute
    DirectShutdown(CallServer('127.0.0.1',Sock.Port,false,cslTCP,1));
  end;
  endtix := GetTick64+20000;
  EnterCriticalSection(fProcessCS);
  try
    if fInternalHttpServerRespList<>nil then begin
      for i := 0 to fInternalHttpServerRespList.Count-1 do begin
        resp := fInternalHttpServerRespList.List[i];
        resp.Terminate;
        DirectShutdown(resp.fServerSock.Sock,{rdwr=}true);
      end;
      repeat // wait for all THttpServerResp.Execute to be finished
        if (fInternalHttpServerRespList.Count=0) and fExecuteFinished then
          break;
        LeaveCriticalSection(fProcessCS);
        SleepHiRes(100);
        EnterCriticalSection(fProcessCS);
      until GetTick64>endtix;
      FreeAndNil(fInternalHttpServerRespList);
    end;
................................................................................
    ClientSin: TVarSin;
    ClientCrtSock: THttpServerSocket;
    {$ifdef MONOTHREAD}
    endtix: Int64;
    {$endif}
begin
  // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event
  fExecuteFinished := false;
  NotifyThreadStart(self);
  // main server process loop
  if Sock.Sock>0 then
  try
    while not Terminated do begin
      ClientSock := Accept(Sock.Sock,ClientSin);
      if ClientSock<=0 then
................................................................................
      {$endif MONOTHREAD}
      end;
  except
    on Exception do
      ; // any exception would break and release the thread
  end;
  EnterCriticalSection(fProcessCS);
  fExecuteFinished := true;
  LeaveCriticalSection(fProcessCS);
end;

procedure THttpServer.OnConnect;
begin
  InterLockedIncrement(fServerConnectionCount);
  InterLockedIncrement(fServerConnectionActive);






|







 







<







 







|













|







 







|







 







|







1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
1856
1857
....
6104
6105
6106
6107
6108
6109
6110

6111
6112
6113
6114
6115
6116
6117
....
6136
6137
6138
6139
6140
6141
6142
6143
6144
6145
6146
6147
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
....
6258
6259
6260
6261
6262
6263
6264
6265
6266
6267
6268
6269
6270
6271
6272
....
6309
6310
6311
6312
6313
6314
6315
6316
6317
6318
6319
6320
6321
6322
6323
    fServerKeepAliveTimeOut: cardinal;
    fTCPPrefix: SockString;
    fSock: TCrtSocket;
    fThreadRespClass: THttpServerRespClass;
    fOnSendFile: TOnHttpServerSendFile;
    fNginxSendFileFrom: array of TFileName;
    fHTTPQueueLength: cardinal;
    fExecuteState: (esNotStarted, esRunning, esFinished);
    fStats: array[THttpServerSocketGetRequestResult] of integer;
    fSocketClass: THttpServerSocketClass;
    fHeadersNotFiltered: boolean;
    function GetStat(one: THttpServerSocketGetRequestResult): integer;
    function GetHTTPQueueLength: Cardinal; override;
    procedure SetHTTPQueueLength(aValue: Cardinal); override;
    procedure InternalHttpServerRespListAdd(resp: THttpServerResp);
................................................................................
constructor THttpServer.Create(const aPort: SockString; OnStart,
  OnStop: TNotifyThreadEvent; const ProcessName: SockString;
  ServerThreadPoolCount: integer; KeepAliveTimeOut: integer;
  HeadersUnFiltered: boolean);
begin
  fInternalHttpServerRespList := {$ifdef FPC}TFPList{$else}TList{$endif}.Create;
  InitializeCriticalSection(fProcessCS);

  fSock := TCrtSocket.Bind(aPort); // BIND + LISTEN
  fServerKeepAliveTimeOut := KeepAliveTimeOut; // 30 seconds by default
  if fThreadPool<>nil then
    fThreadPool.ContentionAbortDelay := 5000; // 5 seconds default
  // event handlers set before inherited Create to be visible in childs
  fOnHttpThreadStart := OnStart;
  SetOnTerminate(OnStop);
................................................................................
var endtix: Int64;
    i: integer;
    resp: THttpServerResp;
begin
  Terminate; // set Terminated := true for THttpServerResp.Execute
  if fThreadPool<>nil then
    fThreadPool.fTerminated := true; // notify background process
  if (fExecuteState=esRunning) and (Sock<>nil) then begin
    Sock.Close; // shutdown the socket to unlock Accept() in Execute
    DirectShutdown(CallServer('127.0.0.1',Sock.Port,false,cslTCP,1));
  end;
  endtix := GetTick64+20000;
  EnterCriticalSection(fProcessCS);
  try
    if fInternalHttpServerRespList<>nil then begin
      for i := 0 to fInternalHttpServerRespList.Count-1 do begin
        resp := fInternalHttpServerRespList.List[i];
        resp.Terminate;
        DirectShutdown(resp.fServerSock.Sock,{rdwr=}true);
      end;
      repeat // wait for all THttpServerResp.Execute to be finished
        if (fInternalHttpServerRespList.Count=0) and (fExecuteState<>esRunning) then
          break;
        LeaveCriticalSection(fProcessCS);
        SleepHiRes(100);
        EnterCriticalSection(fProcessCS);
      until GetTick64>endtix;
      FreeAndNil(fInternalHttpServerRespList);
    end;
................................................................................
    ClientSin: TVarSin;
    ClientCrtSock: THttpServerSocket;
    {$ifdef MONOTHREAD}
    endtix: Int64;
    {$endif}
begin
  // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event
  fExecuteState := esRunning;
  NotifyThreadStart(self);
  // main server process loop
  if Sock.Sock>0 then
  try
    while not Terminated do begin
      ClientSock := Accept(Sock.Sock,ClientSin);
      if ClientSock<=0 then
................................................................................
      {$endif MONOTHREAD}
      end;
  except
    on Exception do
      ; // any exception would break and release the thread
  end;
  EnterCriticalSection(fProcessCS);
  fExecuteState := esFinished;
  LeaveCriticalSection(fProcessCS);
end;

procedure THttpServer.OnConnect;
begin
  InterLockedIncrement(fServerConnectionCount);
  InterLockedIncrement(fServerConnectionActive);

Changes to SynopseCommit.inc.

1
'1.18.5956'
|
1
'1.18.5957'