pascal
/
fpc
mirror of https://gitlab.com/freepascal.org/fpc/source.git


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267
							(*

  @Example: `event_and_thread`.
  @Description: Use event-driven for usual requests and threads to slowly requests.
  @Authors: Silvio Clecio and Gilson Nunes

*)

program event_and_thread;

// Shows `event_and_thread` details on Linux:
//
//   $ ps axo pid,ppid,rss,vsz,nlwp,cmd | grep 'event_and_thread'
//
// But if you prefer to see only the number of thread of `event_and_thread`:
//
//   $ ps axo nlwp,cmd | grep 'event_and_thread'

{$mode objfpc}{$H+}
{$MACRO ON}
{$DEFINE DEBUG}
{.$DEFINE WAIT_CLIENTS_DISCONNECT}
{$DEFINE TIMEOUT := 10}
{.$DEFINE CONTINGENCY_CONTROL}
{$IF DEFINED(CONTINGENCY_CONTROL)}
  {$DEFINE MAX_THREAD_COUNT := 2}
{$ENDIF}

uses
{$IFDEF UNIX}
  cthreads, BaseUnix,
{$ELSE}
  Sockets,
{$ENDIF}
  Classes, SysUtils, cutils, libmicrohttpd;

  procedure MHD_socket_close(fd: cint);
  begin
{$IFDEF UNIX}
    FpClose(fd);
{$ELSE}
    CloseSocket(fd);
{$ENDIF}
  end;

const
  PORT = 8888;

var
  _threads: TFPList;
  _mutex: TRTLCriticalSection;

type

  { TConnectionHandler }

  TConnectionHandler = packed record
    Connection: PMHD_Connection;
    Url: Pcchar;
  end;

  { TSlothThread }

  TSlothThread = class(TThread)
  private
    FHandler: TConnectionHandler;
  protected
    procedure Execute; override;
  public
    constructor Create(AHandler: TConnectionHandler);
    destructor Destroy; override;
  end;

  { TSlothThread }

  constructor TSlothThread.Create(AHandler: TConnectionHandler);
  begin
    inherited Create(True);
    FreeOnTerminate := True;
    FHandler := AHandler;
  end;

  destructor TSlothThread.Destroy;
  begin
    _threads.Remove(Self);
    inherited Destroy;
  end;

  procedure TSlothThread.Execute;
  const
    page: AnsiString =
      '<html><body>I''m a sloth, and my URL is "%s". T: %s</body></html>';
  var
    i: Byte;
    s: AnsiString;
    response: PMHD_Response;
  begin
    for i := 1 to TIMEOUT do
    begin
      if Terminated then
        Break;
      Sleep(1000);
    end;
    if not Terminated then
    begin
      s := Format(page, [FHandler.Url, DateTimeToStr(Now)]);
      response := MHD_create_response_from_buffer(Length(s), Pointer(s),
        MHD_RESPMEM_MUST_COPY);
      MHD_queue_response(FHandler.Connection, MHD_HTTP_OK, response);
      MHD_resume_connection(FHandler.Connection);
      MHD_destroy_response(response);
    end;
  end;

  { daemon }

  function RequestHandler(cls: Pointer; connection: PMHD_Connection;
    url: Pcchar; method: Pcchar; version: Pcchar; upload_data: Pcchar;
    upload_data_size: Psize_t; ptr: PPointer): cint; cdecl;
  const
    page = '<html><body>Hello world! T: %s</body></html>';
{$IF DEFINED(CONTINGENCY_CONTROL)}
    busy_page: Pcchar = '<html><body>The server is busy. :-(</body></html>';
{$ENDIF}
  var
    s: string;
    ret: cint;
    thr: TThread;
    response: PMHD_Response;
    handler: TConnectionHandler;
  begin
    if method <> 'GET' then
      Exit(MHD_NO);

    { By Gilson Nunes:
      "The connection state for first call is `MHD_CONNECTION_HEADERS_PROCESSED`
       and `MHD_CONNECTION_FOOTERS_RECEIVED` for the next, so the flag below
       ensures that the response will be delivered to the client after `MHD`
       finish all the request processing." }
    if not Assigned(ptr^) then
    begin
      ptr^ := Pointer(1);
      Exit(MHD_YES);
    end;
    ptr^ := nil;

    if (strcomp(url, '/sloth1') = 0) or (strcomp(url, '/sloth2') = 0) then
    begin
{$IF DEFINED(CONTINGENCY_CONTROL)}
      if _threads.Count = MAX_THREAD_COUNT then
      begin
        response := MHD_create_response_from_buffer(Length(busy_page),
          busy_page, MHD_RESPMEM_PERSISTENT);
        ret := MHD_queue_response(connection, MHD_HTTP_OK, response);
        MHD_destroy_response(response);
        Exit(ret);
      end;
{$ENDIF}
      MHD_suspend_connection(connection);
      handler.Connection := connection;
      handler.Url := url;
      thr := TSlothThread.Create(handler);
      EnterCriticalsection(_mutex);
      try
        _threads.Add(thr);
      finally
        LeaveCriticalsection(_mutex);
      end;
      thr.Start;
      Result := MHD_YES;
    end
    else
    begin
      s := Format(page, [DateTimeToStr(Now)]);
      response := MHD_create_response_from_buffer(Length(s), Pointer(s),
        MHD_RESPMEM_MUST_COPY);
      ret := MHD_queue_response(connection, MHD_HTTP_OK, response);
      MHD_destroy_response(response);
      Result := ret;
    end;
  end;

var
  _daemon: PMHD_Daemon;

  procedure StopServer;
  var
    i: Integer;
    thr: TThread;
    sckt: MHD_socket;
    connections: PMHD_DaemonInfo;
  begin
    sckt := MHD_quiesce_daemon(_daemon);
{$IFDEF MSWINDOWS}
    if LongWord(sckt) <> MHD_INVALID_SOCKET then
{$ELSE}
    if sckt <> MHD_INVALID_SOCKET then
{$ENDIF}
      MHD_socket_close(sckt);
    EnterCriticalsection(_mutex);
    try
      WriteLn('Threads: ', _threads.Count);
      for i := Pred(_threads.Count) downto 0 do
      begin
        thr := TThread(_threads[i]);
        WriteLn('Finishing thread $', HexStr(thr), ' ...');
        if Assigned(thr) then
          thr.Terminate;
      end;
      while _threads.Count > 0 do
        Sleep(500);
    finally
      LeaveCriticalsection(_mutex);
    end;
    connections := MHD_get_daemon_info(_daemon, MHD_DAEMON_INFO_CURRENT_CONNECTIONS);
    if Assigned(connections) then
    begin
      WriteLn('Connections: ', connections^.num_connections);
{$IFDEF WAIT_CLIENTS_DISCONNECT}
      while True do
      begin
        if connections^.num_connections = 0 then
          Break;
        Sleep(500);
      end;
{$ENDIF}
    end;
    MHD_stop_daemon(_daemon);
    WriteLn('Bye!');
  end;

  procedure SigProc(sig: cint); cdecl;
  begin
    WriteLn;
    StopServer;
    FreeAndNil(_threads);
    Halt;
  end;

begin
  InitCriticalSection(_mutex);
  _threads := TFPList.Create;
  try
    _daemon := MHD_start_daemon(MHD_USE_SELECT_INTERNALLY or
      MHD_USE_SUSPEND_RESUME or MHD_USE_DEBUG,
      PORT, nil, nil, @RequestHandler, nil,
{$IF DEFINED(CONTINGENCY_CONTROL)}
      MHD_OPTION_THREAD_POOL_SIZE, cuint(MAX_THREAD_COUNT),
{$ENDIF}
      MHD_OPTION_CONNECTION_TIMEOUT, cuint(TIMEOUT + 1),
      MHD_OPTION_END);
    if not Assigned(_daemon) then
      Halt(1);
    signal(SIGINT, @SigProc);
{$IFDEF MSWINDOWS}
    signal(SIGBREAK, @SigProc);
{$ELSE}
    signal(SIGTERM, @SigProc);
{$ENDIF}
    WriteLn('HTTP server running. Press [Ctrl+C] to stop the server ...');
    while Assigned(_daemon) do
      Sleep(100);
  finally
    FreeAndNil(_threads);
    DoneCriticalsection(_mutex);
  end;
end.