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


			
				
					
						
						
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187
							(* 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.