program HttpApiServer;
{$APPTYPE CONSOLE}
{$I Synopse.inc}
//['{FDC3C336-D4AF-4EA8-BAA2-15536FDE8799}']
//netsh http add sslcert ipport=0.0.0.0:443 certhash=3a0a8fa7cbcab141e102eaab457b1299af8f82cc appid={FDC3C336-D4AF-4EA8-BAA2-15536FDE8799}
//netsh http delete sslcert ipport=0.0.0.0:443
uses
{$I SynDprUses.inc} // use FastMM4 on older Delphi, or set FPC threads
SysUtils,
SynCommons,
SynZip,
SynCrtSock;
type
TTestServer = class
protected
fPath: TFileName;
fPort, fRoot: string ;
fServer: THttpApiServer;
fHttps: Boolean ;
function Process(Ctxt: THttpServerRequest): cardinal ;
function ShowDirectory(Ctxt: THttpServerRequest;
const FileName: TFileName; FN: RawUTF8): cardinal ;
public
constructor Create( const Path: TFileName);
destructor Destroy; override;
end ;
{ TTestServer }
constructor TTestServer . Create( const Path: TFileName);
begin
fPath := IncludeTrailingPathDelimiter(Path);
fPort := '443' ;
fRoot := '/test' ;
fHttps := True ;
fServer := THttpApiServer . Create( false );
fServer . AddUrl(fRoot, fPort, fHttps, '+' , true );
fServer . RegisterCompress(CompressDeflate); // our server will deflate html :)
fServer . OnRequest := Process;
fServer . Clone( 31 ); // will use a thread pool of 32 threads in total
end ;
destructor TTestServer . Destroy;
begin
fServer . RemoveUrl(fRoot, fPort, fHttps, '+' );
fServer . Free;
inherited ;
end ;
{$WARN SYMBOL_PLATFORM OFF}
function TTestServer . Process(Ctxt: THttpServerRequest): cardinal ;
var
FileName: TFileName;
FN: RawUTF8;
begin
write (Ctxt . Method, ' ' , Ctxt . URL);
if not IdemPChar( pointer (Ctxt . URL), PAnsiChar (UpperCase(fRoot))) then begin
WriteLn ( ' End with 404' );
result := 404 ;
exit;
end ;
FN := StringReplaceChars(UrlDecode(copy(Ctxt . URL, Length(fRoot) + 1 , maxInt)),
'/' , '\');
if PosEx( '..' , FN) > 0 then begin
WriteLn ( ' .. End with 404' );
result := 404 ; // circumvent obvious potential security leak
exit;
end ;
while (FN <> '' ) and (FN[ 1 ] = '\') do
delete(FN, 1 , 1 );
while (FN <> '' ) and (FN[length(FN)] = '\') do
delete(FN, length(FN), 1 );
FileName := fPath + UTF8ToString(FN);
writeLn ( ' => ' + FileName); //c5soft
if DirectoryExists(FileName) then begin
Result := ShowDirectory(ctxt, FileName, FN);
end else begin
// http.sys will send the specified file from kernel mode
Ctxt . OutContent := StringToUTF8(FileName);
Ctxt . OutContentType := HTTP_RESP_STATICFILE;
result := 200 ; // THttpApiServer.Execute will return 404 if not found
end ;
end ;
var
Msg: string ;
function TTestServer . ShowDirectory(Ctxt: THttpServerRequest;
const FileName: TFileName; FN: RawUTF8): cardinal ;
var
W: TTextWriter;
SRName, href: RawUTF8;
i: integer ;
SR: TSearchRec;
cRoot: string ;
procedure hrefCompute;
begin
SRName := StringToUTF8(SR . Name);
href := FN + StringReplaceChars(SRName, '\', ' /');
end ;
begin
if fRoot <> '/' then cRoot := fRoot + '/' else cRoot := fRoot;
// reply directory listing as html
W := TTextWriter . CreateOwnedStream;
try
W . Add( '<html><body style="font-family: Arial">' +
'<h3>%</h3><p><table>' , [FN]);
FN := StringReplaceChars(FN, '\', ' /');
if FN <> '' then
FN := FN + '/' ;
if FindFirst(FileName + '\*.*' , faDirectory, SR) = 0 then begin
repeat
if (SR . Attr and faDirectory <> 0 ) and (SR . Name <> '.' ) then begin
hrefCompute;
if SRName = '..' then begin
i := length(FN);
while (i > 0 ) and (FN[i] = '/' ) do dec(i);
while (i > 0 ) and (FN[i] <> '/' ) do dec(i);
href := copy(FN, 1 , i);
end ;
W . Add( '<tr><td><b><a href="' + cRoot + '%">[%]</a></b></td></tr>' , [href,
SRName]);
end ;
until FindNext(SR) <> 0 ;
FindClose(SR);
end ;
if FindFirst(FileName + '\*.*' , faAnyFile - faDirectory - faHidden, SR) = 0 then begin
repeat
hrefCompute;
if SR . Attr and faDirectory = 0 then
W . Add( '<tr><td><b><a href="' + cRoot +
'%">%</a></b></td><td>%</td><td>%</td></td></tr>' ,
[href, SRName, KB(SR . Size), DateTimeToStr(
{$IFDEF ISDELPHIXE2}SR.TimeStamp{$ELSE}FileDateToDateTime(SR.Time){$ENDIF} )]);
until FindNext(SR) <> 0 ;
FindClose(SR);
end ;
W . AddShort( '</table></p><p><i>Powered by mORMot' 's <strong>' );
W . AddClassName(Ctxt . Server . ClassType);
W . AddShort( '</strong></i> - ' +
'see <a href=https://synopse.info>https://synopse.info</a></p></body></html>' );
Ctxt . OutContent := W . Text;
Ctxt . OutContentType := HTML_CONTENT_TYPE;
result := 200 ;
finally
W . Free;
end ;
end ;
begin
with TTestServer . Create('D:\Programs\Nginx\wwwroot\') do try
Msg := 'Server is now running on http' ;
if fHttps then Msg := Msg + 's' ;
msg := msg + '://localhost' ;
if fPort <> '80' then
Msg := Msg + ':' + fPort;
Msg := Msg + fRoot + # 13 # 10 # 13 # 10 'Press [Enter] to quit' ;
WriteLn (Msg);
readln;
finally
Free;
end ;
end .
|