program restfulhttpserverthreadsafe;
{$mode objfpc}{$H+}
{$define THREADPOOL}
{
This code has been dedicated to the public domain.
You may use, modify, copy, or distribute this code freely,
for any purpose, without any conditions or warranties.
Author: nomorelogic (Basso Marcello)
Date: 13/05/2025
Special thanks to (https://forum.lazarus.freepascal.org/index.php/topic,71031.0.html):
- Thaddy
- Fibonacci
Abstract:
this code is an intentionally simple version of a microservice for a restful json server
is intended to be a basis for creating better servers
}
uses
cthreads,
Classes,
SysUtils,
cmem,
libmicrohttpd,
fpjson,
jsonparser,
syncobjs;
const
PORT = 8888;
type
TRestResponse = record
StatusCode: cuint;
ResText: string;
end;
TClientContextInfo = record
Playload_AsText: string;
PlayLoadIsJson: boolean;
PlayLoad_AsJson: TJSONObject;
Response: TRestResponse;
end;
PClientContextInfo = ^TClientContextInfo;
var
ShouldStop: boolean = False;
Daemon: PMHD_Daemon;
StopLock: TCriticalSection;
function HandleRestfulRequest(cls: Pointer; connection: PMHD_Connection;
url, method, version: pchar; upload_data: pchar; upload_data_size: pSize_t;
con_cls: PPointer): cint; cdecl;
var
response: PMHD_Response;
jsonObj: TJSONObject;
con_info: PClientContextInfo;
begin
Result := 0;
// - - - - - - - - - - - - - - - - - - - - - - -
// first call
// the first invocation is used to initialize the
// context of the request; generally a data structure is created
// - - - - - - - - - - - - - - - - - - - - - - -
if con_cls^ = nil then
begin
// init client context
New(con_info);
con_info^.Playload_AsText := '';
con_info^.PlayLoadIsJson := False;
con_info^.PlayLoad_AsJson := nil;
con_info^.Response.StatusCode := MHD_HTTP_OK;
con_info^.Response.ResText := '';
con_cls^ := con_info;
Exit(MHD_YES);
end; // else begin
con_info := PClientContextInfo(con_cls^);
// - - - - - - - - - - - - - - - - - - - - - - -
// Handle POST data
// in the case of POST data: an additional callback
// is executed to allow the input data to be handled
// - - - - - - - - - - - - - - - - - - - - - - -
if (method = MHD_HTTP_METHOD_POST) and (upload_data_size^ <> 0) then
begin
SetString(con_info^.Playload_AsText, upload_data, upload_data_size^);
// Try to parse as JSON if content-type is application/json
if Assigned(MHD_lookup_connection_value(connection, MHD_HEADER_KIND,
MHD_HTTP_HEADER_CONTENT_TYPE)) then
if (Pos('application/json',
MHD_lookup_connection_value(connection, MHD_HEADER_KIND,
MHD_HTTP_HEADER_CONTENT_TYPE)) > 0) then
begin
if con_info^.Playload_AsText <> '' then
try
con_info^.PlayLoadIsJson := True;
con_info^.PlayLoad_AsJson :=
GetJSON(con_info^.Playload_AsText) as TJSONObject;
except
// on exception: return error
con_info^.Response.StatusCode := MHD_HTTP_INTERNAL_SERVER_ERROR;
con_info^.Response.ResText := '{"error": "Invalid JSON format"}';
end;
end;
upload_data_size^ := 0;
Exit(MHD_YES);
end; // <-- handle post data
// - - - - - - - - - - - - - - - - - - - - - - -
// last call
// response handler
// - - - - - - - - - - - - - - - - - - - - - - -
if con_info^.Response.StatusCode = MHD_HTTP_OK then
begin
if url = '/shutdown' then
begin
jsonObj := TJSONObject.Create;
jsonObj.Add('status', 'shutting down');
con_info^.Response.ResText := jsonObj.AsJSON;
jsonObj.Free;
// try gracefully stop
StopLock.Enter;
try
ShouldStop := True;
finally
StopLock.Leave;
end;
end
else if (url = '/api/status') and (method = 'GET') then
begin
jsonObj := TJSONObject.Create;
jsonObj.Add('status', 'ok');
jsonObj.Add('uptime', FormatDateTime('hh:nn:ss', Now));
con_info^.Response.ResText := jsonObj.AsJSON;
jsonObj.Free;
end
else if url = '/api/echo' then
begin
if method = 'GET' then
begin
con_info^.Response.ResText := '{"method": "GET", "data": "echo"}';
end
else if method = 'POST' then
begin
// do we have a playload?
if con_info^.PlayLoadIsJson then
begin
if Assigned(con_info^.PlayLoad_AsJson) then
con_info^.Response.ResText := con_info^.PlayLoad_AsJson.AsJSON;
end
else
begin
con_info^.Response.ResText := con_info^.Playload_AsText;
end;
// playload is empty?
if con_info^.Response.ResText = '' then
begin
con_info^.Response.StatusCode := MHD_HTTP_NO_CONTENT;
con_info^.Response.ResText := '{"error": "No data received"}';
end;
end;
end; // POST /api/echo
end; // <-- second call
// - - - - - - - - - - - - - - - - - - - - -
// response
// send respnse and free resources
// - - - - - - - - - - - - - - - - - - - - -
response := MHD_create_response_from_buffer(Length(con_info^.Response.ResText),
PChar(con_info^.Response.ResText), MHD_RESPMEM_MUST_COPY);
MHD_add_response_header(response, 'Content-Type', 'application/json');
Result := MHD_queue_response(connection, con_info^.Response.StatusCode, response);
// Free response
MHD_destroy_response(response);
// Free client context
if Assigned(con_info^.PlayLoad_AsJson) then
con_info^.PlayLoad_AsJson.Free;
Dispose(con_info);
con_cls^ := nil;
end; // function HandleRestfulRequest
begin
// critical section
StopLock := TCriticalSection.Create;
try
// Create the MHD daemon with either thread pool OR thread-per-connection
// Choose one of these options:
// Option 1: Thread pool (fixed number of threads)
{$if Defined(THREADPOOL)}
Daemon := MHD_start_daemon(MHD_USE_INTERNAL_POLLING_THREAD or
MHD_USE_DEBUG, PORT, nil, nil, @HandleRestfulRequest,
nil, MHD_OPTION_THREAD_POOL_SIZE, 4, MHD_OPTION_END);
{$else thread_per_connection}
// Option 2: Thread-per-connection (one thread per request)
Daemon := MHD_start_daemon(
MHD_USE_THREAD_PER_CONNECTION or MHD_USE_DEBUG or MHD_USE_INTERNAL_POLLING_THREAD,
PORT,
nil,
nil,
@HandleRestfulRequest,
nil,
MHD_OPTION_END
);
{$ifend}
if Daemon = nil then
begin
WriteLn('Error starting HTTP server!');
Halt(1);
end;
WriteLn('rest server started at: http://localhost:', PORT);
WriteLn('Endpoints: /api/status (GET), /api/echo (POST), /shutdown');
// Loop server
while not ShouldStop do
Sleep(100);
MHD_stop_daemon(Daemon);
WriteLn('Server stopped.');
finally
StopLock.Free;
end;
end.
WIKI Timeout issues
