program IndyMultipartUploadDemo;
{$APPTYPE CONSOLE}
uses
IdHTTPServer, IdCustomHTTPServer, IdContext, IdSocketHandle, IdGlobal,
IdMessageCoder, IdGlobalProtocols, IdMessageCoderMIME, IdMultiPartFormData,
SysUtils, Classes;
type
TMimeHandler =
procedure(
var VDecoder: TIdMessageDecoder;
var VMsgEnd: Boolean;
const Response: TIdHTTPResponseInfo)
of object;
TMyServer =
class(TIdHTTPServer)
private
procedure ProcessMimePart(
var VDecoder: TIdMessageDecoder;
var VMsgEnd: Boolean;
const Response: TIdHTTPResponseInfo);
function IsHeaderMediaType(
const AHeaderLine, AMediaType:
String): Boolean;
function MediaTypeMatches(
const AValue, AMediaType:
String): Boolean;
function GetUploadFolder:
string;
procedure HandleMultipartUpload(Request: TIdHTTPRequestInfo; Response:
TIdHTTPResponseInfo; MimeHandler: TMimeHandler);
public
procedure InitComponent;
override;
procedure DoCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
override;
end;
procedure Demo;
var
Server: TMyServer;
begin
ReportMemoryLeaksOnShutdown := True;
Server := TMyServer.Create;
try
try
Server.Active := True;
except
on E:
Exception do
begin
WriteLn(E.ClassName + '
' + E.
Message);
end;
end;
WriteLn('
Hit any key to terminate.');
ReadLn;
finally
Server.Free;
end;
end;
procedure TMyServer.InitComponent;
var
Binding: TIdSocketHandle;
begin
inherited;
Bindings.Clear;
Binding := Bindings.Add;
Binding.IP := '
127.0.0.1';
Binding.Port := 8080;
KeepAlive := True;
end;
procedure TMyServer.DoCommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
begin
AResponseInfo.ContentType := '
text/html';
AResponseInfo.CharSet := '
UTF-8';
if ARequestInfo.CommandType = hcGET
then
begin
AResponseInfo.ContentText :=
'
<!DOCTYPE HTML>' + #13#10
+ '
<html>' + #13#10
+ '
<head>' + #13#10
+ '
<title>Multipart Upload Example</title>' + #13#10
+ '
</head>' + #13#10
+ '
<body> ' + #13#10
+ '
<form enctype="multipart/form-data" method="post">' + #13#10
+ '
<fieldset>' + #13#10
+ '
<legend>Standard file upload</legend>' + #13#10
+ '
<label>File input</label>' + #13#10
+ '
<input type="file" class="input-file" name="upload" />' + #13#10
+ '
<button type="submit" class="btn btn-default">Upload</button>' + #13#10
+ '
</fieldset>' + #13#10
+ '
</form>' + #13#10
+ '
</body>' + #13#10
+ '
</html>' + #13#10;
end
else
begin
if ARequestInfo.CommandType = hcPOST
then
begin
if IsHeaderMediaType(ARequestInfo.ContentType, '
multipart/form-data')
then
begin
HandleMultipartUpload(ARequestInfo, AResponseInfo, ProcessMimePart);
end;
end;
end;
end;
// based on code on the Indy and Winsock Forum articles
// http://forums2.atozed.com/viewtopic.php?f=7&t=10924
// http://embarcadero.newsgroups.archived.at/public.delphi.internet.winsock/201107/1107276163.html
procedure TMyServer.ProcessMimePart(
var VDecoder: TIdMessageDecoder;
var VMsgEnd: Boolean;
const Response: TIdHTTPResponseInfo);
var
LMStream: TMemoryStream;
LNewDecoder: TIdMessageDecoder;
UploadFile:
string;
begin
LMStream := TMemoryStream.Create;
try
LNewDecoder := VDecoder.ReadBody(LMStream, VMsgEnd);
if VDecoder.Filename <> '
'
then
begin
try
LMStream.Position := 0;
Response.ContentText := Response.ContentText
+ Format('
<p>%s %d bytes</p>' + #13#10,
[VDecoder.Filename, LMStream.Size]);
// write stream to upload folder
UploadFile := GetUploadFolder + VDecoder.Filename;
LMStream.SaveToFile(UploadFile);
Response.ContentText := Response.ContentText
+ '
<p>' + UploadFile + '
written</p>';
except
LNewDecoder.Free;
raise;
end;
end;
VDecoder.Free;
VDecoder := LNewDecoder;
finally
LMStream.Free;
end;
end;
function TMyServer.IsHeaderMediaType(
const AHeaderLine, AMediaType:
String): Boolean;
begin
Result := MediaTypeMatches(ExtractHeaderItem(AHeaderLine), AMediaType);
end;
function TMyServer.MediaTypeMatches(
const AValue, AMediaType:
String): Boolean;
begin
if Pos('
/', AMediaType) > 0
then begin
Result := TextIsSame(AValue, AMediaType);
end else begin
Result := TextStartsWith(AValue, AMediaType + '
/');
end;
end;
function TMyServer.GetUploadFolder:
string;
begin
Result := ExtractFilePath(ParamStr(0)) + '
upload\';
ForceDirectories(Result);
end;
procedure TMyServer.HandleMultipartUpload(Request: TIdHTTPRequestInfo;
Response: TIdHTTPResponseInfo; MimeHandler: TMimeHandler);
var
LBoundary, LBoundaryStart, LBoundaryEnd:
string;
LDecoder: TIdMessageDecoder;
LLine:
string;
LBoundaryFound, LIsStartBoundary, LMsgEnd: Boolean;
begin
LBoundary := ExtractHeaderSubItem(Request.ContentType, '
boundary',
QuoteHTTP);
if LBoundary = '
'
then
begin
Response.ResponseNo := 400;
Response.CloseConnection := True;
Response.WriteHeader;
Exit;
end;
LBoundaryStart := '
--' + LBoundary;
LBoundaryEnd := LBoundaryStart + '
--';
LDecoder := TIdMessageDecoderMIME.Create(
nil);
try
TIdMessageDecoderMIME(LDecoder).MIMEBoundary := LBoundary;
LDecoder.SourceStream := Request.PostStream;
LDecoder.FreeSourceStream := False;
LBoundaryFound := False;
LIsStartBoundary := False;
repeat
LLine := ReadLnFromStream(Request.PostStream, -1, True);
if LLine = LBoundaryStart
then
begin
LBoundaryFound := True;
LIsStartBoundary := True;
end
else if LLine = LBoundaryEnd
then
begin
LBoundaryFound := True;
end;
until LBoundaryFound;
if (
not LBoundaryFound)
or (
not LIsStartBoundary)
then
begin
Response.ResponseNo := 400;
Response.CloseConnection := True;
Response.WriteHeader;
Exit;
end;
LMsgEnd := False;
repeat
TIdMessageDecoderMIME(LDecoder).MIMEBoundary := LBoundary;
LDecoder.SourceStream := Request.PostStream;
LDecoder.FreeSourceStream := False;
LDecoder.ReadHeader;
case LDecoder.PartType
of
mcptText, mcptAttachment:
begin
MimeHandler(LDecoder, LMsgEnd, Response);
end;
mcptIgnore:
begin
LDecoder.Free;
LDecoder := TIdMessageDecoderMIME.Create(
nil);
end;
mcptEOF:
begin
LDecoder.Free;
LMsgEnd := True;
end;
end;
until (LDecoder =
nil)
or LMsgEnd;
finally
LDecoder.Free;
end;
end;
begin
Demo;
end.