mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-05-01 07:33:40 +02:00
188 lines
5.9 KiB
ObjectPascal
188 lines
5.9 KiB
ObjectPascal
(* Feel free to use this example code in any way
|
|
you see fit (Public Domain) *)
|
|
|
|
// Original example: https://gnunet.org/svn/libmicrohttpd/doc/examples/largepost.c
|
|
|
|
program largepost;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
uses
|
|
libmicrohttpd, SysUtils, cutils;
|
|
|
|
type
|
|
TConnectionInfoStruct = record
|
|
ConnectionType: cint;
|
|
PostProcessor: PMHD_PostProcessor;
|
|
Fp: FILEptr;
|
|
AnswerString: Pcchar;
|
|
AnswerCode: cint;
|
|
end;
|
|
PConnectionInfoStruct = ^TConnectionInfoStruct;
|
|
|
|
const
|
|
PORT = 8888;
|
|
POSTBUFFERSIZE = 512;
|
|
MAXCLIENTS = 2;
|
|
GET = 0;
|
|
POST = 1;
|
|
|
|
var
|
|
NrOfUploadingClients: Cardinal;
|
|
AskPage: Pcchar =
|
|
'<html><body>'+#10+
|
|
'Upload a file, please!<br>'+#10+
|
|
'There are %d clients uploading at the moment.<br>'+#10+
|
|
'<form action="/filepost" method="post" enctype="multipart/form-data">'+#10+
|
|
'<input name="file" type="file">'+#10+
|
|
'<input type="submit" value="Send"></form>'+#10+
|
|
'</body></html>';
|
|
BusyPage: Pcchar = '<html><body>This server is busy, please try again later.</body></html>';
|
|
CompletePage: Pcchar = '<html><body>The upload has been completed.</body></html>';
|
|
ErrorPage: Pcchar = '<html><body>This doesn''t seem to be right.</body></html>';
|
|
ServerErrorPage: Pcchar = '<html><body>An internal server error has occurred.</body></html>';
|
|
FileExistsPage: Pcchar = '<html><body>This file already exists.</body></html>';
|
|
|
|
function SendPage(AConnection: PMHD_Connection; APage: Pcchar; AStatusCode: cint): cint;
|
|
var
|
|
VRet: cint;
|
|
VResponse: PMHD_Response;
|
|
begin
|
|
VResponse := MHD_create_response_from_buffer(Length(APage),
|
|
Pointer(APage), MHD_RESPMEM_MUST_COPY);
|
|
if not Assigned(VResponse) then
|
|
Exit(MHD_NO);
|
|
MHD_add_response_header(VResponse, MHD_HTTP_HEADER_CONTENT_TYPE, 'text/html');
|
|
VRet := MHD_queue_response(AConnection, AStatusCode, VResponse);
|
|
MHD_destroy_response(VResponse);
|
|
Result := VRet;
|
|
end;
|
|
|
|
function IteratePost(AConInfoCls: Pointer; AKind: MHD_ValueKind; AKey: Pcchar;
|
|
AFileName: Pcchar; AContentType: Pcchar; ATransferEncoding: Pcchar;
|
|
AData: Pcchar; AOff: cuint64; ASize: size_t): cint; cdecl;
|
|
var
|
|
VConInfo: PConnectionInfoStruct;
|
|
begin
|
|
VConInfo := AConInfoCls;
|
|
VConInfo^.AnswerString := ServerErrorPage;
|
|
VConInfo^.AnswerCode := MHD_HTTP_INTERNAL_SERVER_ERROR;
|
|
if StrComp(AKey, 'file') <> 0 then
|
|
Exit(MHD_NO);
|
|
if not Assigned(VConInfo^.Fp) then
|
|
begin
|
|
if FileExists(AFileName) then
|
|
begin
|
|
VConInfo^.AnswerString := FileExistsPage;
|
|
VConInfo^.AnswerCode := MHD_HTTP_FORBIDDEN;
|
|
Exit(MHD_NO);
|
|
end;
|
|
VConInfo^.Fp := fopen(AFileName, fappendwrite);
|
|
if not Assigned(VConInfo^.Fp) then
|
|
Exit(MHD_NO);
|
|
end;
|
|
if ASize > 0 then
|
|
if fwrite(AData, ASize, SizeOf(AnsiChar), VConInfo^.Fp) = 0 then
|
|
Exit(MHD_NO);
|
|
VConInfo^.AnswerString := CompletePage;
|
|
VConInfo^.AnswerCode := MHD_HTTP_OK;
|
|
Result := MHD_YES;
|
|
end;
|
|
|
|
procedure RequestCompleted(ACls: Pointer; AConnection: PMHD_Connection;
|
|
AConCls: PPointer; AToe: MHD_RequestTerminationCode); cdecl;
|
|
var
|
|
VConInfo: PConnectionInfoStruct;
|
|
begin
|
|
VConInfo := AConCls^;
|
|
if not Assigned(VConInfo) then
|
|
Exit;
|
|
if VConInfo^.ConnectionType = POST then
|
|
begin
|
|
if Assigned(VConInfo^.PostProcessor) then
|
|
begin
|
|
MHD_destroy_post_processor(VConInfo^.PostProcessor);
|
|
Dec(NrOfUploadingClients);
|
|
end;
|
|
if Assigned(VConInfo^.Fp) then
|
|
fclose(VConInfo^.Fp);
|
|
end;
|
|
FreeMem(VConInfo);
|
|
AConCls^ := nil;
|
|
end;
|
|
|
|
function AnswerToConnection(ACls: Pointer; AConnection: PMHD_Connection;
|
|
AUrl: Pcchar; AMethod: Pcchar; AVersion: Pcchar; AUploadData: Pcchar;
|
|
AUploadDataSize: Psize_t; AConCls: PPointer): cint; cdecl;
|
|
var
|
|
VBuffer: array[0..1024] of AnsiChar;
|
|
VConInfo: PConnectionInfoStruct;
|
|
begin
|
|
if not Assigned(AConCls^) then
|
|
begin
|
|
if NrOfUploadingClients >= MAXCLIENTS then
|
|
Exit(SendPage(AConnection, BusyPage, MHD_HTTP_SERVICE_UNAVAILABLE));
|
|
VConInfo := AllocMem(SizeOf(TConnectionInfoStruct));
|
|
if not Assigned(VConInfo) then
|
|
Exit(MHD_NO);
|
|
VConInfo^.Fp := nil;
|
|
if StrComp(AMethod, 'POST') = 0 then
|
|
begin
|
|
VConInfo^.PostProcessor := MHD_create_post_processor(AConnection,
|
|
POSTBUFFERSIZE, @IteratePost, VConInfo);
|
|
if not Assigned(VConInfo^.PostProcessor) then
|
|
begin
|
|
FreeMem(VConInfo);
|
|
Exit(MHD_NO);
|
|
end;
|
|
Inc(NrOfUploadingClients);
|
|
VConInfo^.ConnectionType := POST;
|
|
VConInfo^.AnswerCode := MHD_HTTP_OK;
|
|
VConInfo^.AnswerString := CompletePage;
|
|
end
|
|
else
|
|
VConInfo^.ConnectionType := GET;
|
|
AConCls^ := VConInfo;
|
|
Exit(MHD_YES);
|
|
end;
|
|
if StrComp(AMethod, 'GET') = 0 then
|
|
begin
|
|
StrLFmt(VBuffer, SizeOf(VBuffer), AskPage, [NrOfUploadingClients]);
|
|
Exit(SendPage(AConnection, VBuffer, MHD_HTTP_OK));
|
|
end;
|
|
if StrComp(AMethod, 'POST') = 0 then
|
|
begin
|
|
VConInfo := AConCls^;
|
|
if AUploadDataSize^ <> 0 then
|
|
begin
|
|
MHD_post_process(VConInfo^.PostProcessor, AUploadData, AUploadDataSize^);
|
|
AUploadDataSize^ := 0;
|
|
Exit(MHD_YES);
|
|
end
|
|
else
|
|
begin
|
|
if Assigned(VConInfo^.Fp) then
|
|
begin
|
|
fclose(VConInfo^.Fp);
|
|
VConInfo^.Fp := nil;
|
|
end;
|
|
(* Now it is safe to open and inspect the file before calling send_page with a response *)
|
|
Exit(SendPage(AConnection, VConInfo^.AnswerString, VConInfo^.AnswerCode));
|
|
end;
|
|
end;
|
|
Result := SendPage(AConnection, ErrorPage, MHD_HTTP_BAD_REQUEST);
|
|
end;
|
|
|
|
var
|
|
VDaemon: PMHD_Daemon;
|
|
begin
|
|
VDaemon := MHD_start_daemon(MHD_USE_SELECT_INTERNALLY, PORT, nil, nil,
|
|
@AnswerToConnection, nil, MHD_OPTION_NOTIFY_COMPLETED, @RequestCompleted,
|
|
nil, MHD_OPTION_END);
|
|
if not Assigned(VDaemon) then
|
|
Halt(1);
|
|
ReadLn;
|
|
MHD_stop_daemon(VDaemon);
|
|
end.
|
|
|