Echo request

{ This file is part of the Free Pascal run time library. Copyright (c) 2019 by the Free Pascal development team Sample HTTP server application See the file COPYING.FPC, included in this distribution, for details about the copyright. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. **********************************************************************} {$mode objfpc} {$h+} { $DEFINE USEGNUTLS} { $DEFINE USEMICROHTTP} program simpleserver; {$IFDEF USEMICROHTTP} {$UNDEF USEGNUTLS} {$ENDIF} uses {$IFNDEF USEMICROHTTP} {$ifdef USEGNUTLS} gnutlssockets, {$else} opensslsockets, {$endif} custhttpapp, {$ELSE} {$ifdef unix} cthreads, {$endif} custmicrohttpapp, {$ENDIF} {$ifdef unix} baseunix, {$endif} sysutils,Classes, jsonparser, fpjson, strutils, inifiles, sslbase, httproute, httpdefs, fpmimetypes, fpwebfile, fpwebproxy, webutil; Type { THTTPApplication } {$IFDEF USEMICROHTTP} TParentApp = TCustomMicroHTTPApplication; {$ELSE} TParentApp = TCustomHTTPApplication; {$ENDIF} { TMySimpleFileModule } TMySimpleFileModule = class(TSimpleFileModule) Public Procedure SendFile(const AFileName: String; AResponse: TResponse); override; end; THTTPApplication = Class(TParentApp) private FCaptureFileName : String; FCaptureStream : TFileStream; FAPISecret : String; FBaseDir: string; FIndexPageName: String; FInterfaceAddress: String; FMimeFile: String; FNoIndexPage: Boolean; FQuiet: Boolean; FBackground : Boolean; FPassword : string; FEcho : Boolean; FMaxAge : Integer; FCrossOriginIsolation : Boolean; procedure AddProxy(const aProxyDef: String); procedure DoEcho(ARequest: TRequest; AResponse: TResponse); procedure DoCapture(ARequest: TRequest; AResponse: TResponse); procedure DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String); procedure DoQuit(ARequest: TRequest; AResponse: TResponse); function GetCaptureJSON(ARequest: TRequest; AResponse: TResponse; var aJSON: TJSONData): TJSONArray; procedure LoadMimeTypes; procedure ProcessOptions; procedure ReadConfigFile(const ConfigFile: string); procedure SetupCapture(const aFileName: string); procedure ShowCaptureOutput(aJSON: TJSONData); procedure Usage(Msg: String); procedure Writeinfo; Public Destructor Destroy; override; published procedure DoLog(EventType: TEventType; const Msg: String); override; Procedure DoRun; override; property Quiet : Boolean read FQuiet Write FQuiet; Property MimeFile : String Read FMimeFile Write FMimeFile; Property BaseDir : string Read FBaseDir Write FBaseDir; Property NoIndexPage : Boolean Read FNoIndexPage Write FNoIndexPage; Property IndexPageName : String Read FIndexPageName Write FIndexPageName; Property InterfaceAddress : String Read FInterfaceAddress Write FInterfaceAddress; end; Var Application : THTTPApplication; { TMySimpleFileModule } procedure TMySimpleFileModule.SendFile(const AFileName: String; AResponse: TResponse); begin AResponse.SetCustomHeader('Cross-Origin-Embedder-Policy','require-corp'); AResponse.SetCustomHeader('Cross-Origin-Opener-Policy','same-origin'); inherited SendFile(AFileName, AResponse); end; { THTTPApplication } procedure THTTPApplication.DoEcho(ARequest: TRequest; AResponse: TResponse); Var L : TStrings; begin L:=TStringList.Create; try L.AddStrings(['', '', '', 'Echo request', '', '' ]); DumpRequest(aRequest,L); L.AddStrings(['','']); AResponse.Content:=L.Text; AResponse.SendResponse; finally L.Free; end; end; function THTTPApplication.GetCaptureJSON(ARequest: TRequest; AResponse: TResponse; var aJSON: TJSONData): TJSONArray; var aJSONObj : TJSONObject absolute aJSON; Cont : String; begin Result:=Nil; aJSON:=Nil; try Cont:=aRequest.Content; aJSON:=GetJSON(Cont); if aJSON.JSONType<>jtObject then Raise EHTTP.Create('No JSON object in capture JSON'); Result:=aJSONObj.Get('lines',TJSONArray(Nil)); if Result=Nil then begin FreeAndNil(aJSON); Raise EHTTP.Create('No lines element in capture JSON'); end; except On E : Exception do begin DoLog(etError,Format('Exception %s (%s) : Invalid capture content: not valid JSON: %s',[E.ClassName,E.Message,Copy(Cont,1,255)])); aResponse.Code:=400; aResponse.CodeText:='INVALID PARAM'; aResponse.SendResponse; end; end; end; procedure THTTPApplication.ShowCaptureOutput(aJSON : TJSONData); var S : TJSONStringType; begin if aJSON.JSONType in StructuredJSONTypes then S:=aJSON.AsJSON else S:=aJSON.AsString; if Assigned(FCaptureStream) then begin S:=S+sLineBreak; FCaptureStream.WriteBuffer(S[1],Length(S)*SizeOf(TJSONCharType)); end else DoLog(etInfo,'Capture : '+S); end; procedure THTTPApplication.DoCapture(ARequest: TRequest; AResponse: TResponse); Var aJSON : TJSONData; aArray : TJSONArray; I : Integer; begin aJSON:=Nil; aArray:=Nil; try aArray:=GetCaptureJSON(aRequest,aResponse,aJSON); if aArray<>Nil then begin For I:=0 to aArray.Count-1 do ShowCaptureOutput(aArray[i]); aResponse.Code:=200; aResponse.CodeText:='OK'; aResponse.SendResponse; end; finally aJSON.Free; end; end; procedure THTTPApplication.Doquit(ARequest: TRequest; AResponse: TResponse); Var PWD : String; begin PWD:=ARequest.QueryFields.Values['password']; if PWD='' then ARequest.ContentFields.Values['password']; if PWD=FPassword then begin AResponse.Content:='OK'; AResponse.SendContent; Terminate; end else begin AResponse.Code:=403; AResponse.CodeText:='Forbidden'; AResponse.SendContent; end; end; procedure THTTPApplication.DoLog(EventType: TEventType; const Msg: String); begin if Quiet then exit; if IsConsole then Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',EventType,'] ',Msg) else inherited DoLog(EventType, Msg); end; procedure THTTPApplication.DoProxyLog(Sender: TObject; const aMethod, aLocation, aFromURL, aToURL: String); Var Msg : String; begin if Quiet then exit; Msg:=Format('(Proxy redirect) location: %s, Method: %s, From: %s, to: %s',[aLocation,aMethod,aFromURl,atoURL]); if IsConsole then Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',etInfo,'] ',Msg) else inherited DoLog(etInfo, Msg); end; procedure THTTPApplication.Usage(Msg : String); begin if (Msg<>'') then Writeln('Error: ',Msg); Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] '); Writeln('Where options is one or more of : '); Writeln('-A --api=path,secret Activate location API on path, using secret as accepted bearer token.'); Writeln('-a --max-age=age Set max-age expiry header on returned file requests.'); Writeln('-c --config=file Ini configuration file (default: simpleserver.ini)'); {$ifdef unix} Writeln('-b --background fork to background'); {$endif} Writeln('-d --directory=dir Base directory from which to serve files.'); Writeln(' Default is current working directory: ',GetCurrentDir); Writeln('-e --echo Activate /echo URL.'); Writeln('-h --help This help text'); Writeln('-H --hostname=NAME Set hostname for self-signed SSL certificate'); Writeln('-i --indexpage=name Directory index page to use (default: index.html)'); Writeln('-I --interface=IP Listen on this interface address only.'); Writeln('-m --mimetypes=file Path of mime.types. Loaded in addition to OS known types'); Writeln('-n --noindexpage Do not allow index page.'); Writeln('-o --coi Enable Cross-Origin Isolation headers'); Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)'); Writeln('-q --quiet Do not write diagnostic messages'); Writeln('-Q --quit=PWD Register /quit URL. Send request with password variable equal to PWD to stop'); Writeln('-s --ssl Use SSL'); Writeln('-u --capture[=FILE] Set up /debugcapture route to capture output sent by browser.'); Writeln(' If FILE is specified, write to file. If not specified, writes to STDOUT.'); Writeln('-x --proxy=proxydef Add proxy definition. Definition is of form:'); Writeln(' name:BaseURL'); Writeln(''); Writeln('Config file is ini file, section [Server]. Key names are long option names'); Writeln('Proxies are defined in section [Proxy], Key is name, value is URL'); Writeln('Locations are defined in section [Locations], Key is location name, value is path'); Halt(Ord(Msg<>'')); end; procedure THTTPApplication.LoadMimeTypes; begin MimeTypes.LoadKnownTypes; if MimeFile<>'' then begin MimeTypesFile:=MimeFile; if (MimeTypesFile<>'') and not FileExists(MimeTypesFile) then begin Log(etWarning,'mimetypes file not found: '+MimeTypesFile); MimeTypesFile:=''; end; end; If MimeTypesFile<>'' then MimeTypes.LoadFromFile(MimeTypesFile); end; procedure THTTPApplication.AddProxy(const aProxyDef: String); Var P : Integer; N,URL : String; begin P:=Pos(':',aProxyDef); If P=0 then Raise EHTTP.CreateFmt('Invalid proxy definition: %s',[aProxyDef]); N:=Copy(aProxyDef,1,P-1); URL:=Copy(aProxyDef,P+1,Length(aProxyDef)); ProxyManager.RegisterLocation(N,URL).AppendPathInfo:=True; end; Const SCaptureRoute = '/debugcapture'; Const SConfig = 'Server'; SProxy = 'Proxy'; SLocations = 'Locations'; KeyPort = 'Port'; KeyInterface = 'Interface'; KeyDir = 'Directory'; KeyIndexPage = 'IndexPage'; KeyHostName = 'hostname'; keyMimetypes = 'mimetypes'; KeySSL = 'SSL'; KeyQuiet = 'quiet'; KeyQuit = 'quit'; KeyEcho = 'echo'; KeyNoIndexPage = 'noindexpage'; KeyBackground = 'background'; KeyMaxAge = 'MaxAge'; KeyAPI = 'API'; KeyCOI = 'CrossOriginIsolation'; KeyCapture = 'DebugCapture'; procedure THTTPApplication.ReadConfigFile(const ConfigFile: string); Var L : TStringList; P,U : String; I : Integer; begin if (ConfigFile='') or Not FileExists(ConfigFile) then exit; L:=Nil; With TMemIniFile.Create(ConfigFile) do try BaseDir:=ReadString(SConfig,KeyDir,BaseDir); Port:=ReadInteger(SConfig,KeyPort,Port); InterfaceAddress:=ReadString(SConfig,KeyInterface,InterfaceAddress); Quiet:=ReadBool(SConfig,KeyQuiet,Quiet); MimeFile:=ReadString(SConfig,keyMimetypes,MimeFile); NoIndexPage:=ReadBool(SConfig,KeyNoIndexPage,NoIndexPage); IndexPageName:=ReadString(SConfig,KeyIndexPage,IndexPageName); HostName:=ReadString(SConfig,KeyHostName,HostName); UseSSL:=ReadBool(SConfig,KeySSL,UseSSL); FBackground:=ReadBool(SConfig,Keybackground,FBackGround); FPassword:=ReadString(SConfig,KeyQuit,FPassword); FEcho:=ReadBool(SConfig,KeyEcho,FEcho); FMaxAge:=ReadInteger(SConfig,KeyMaxAge,FMaxAge); FAPISecret:=ReadString(SConfig,keyAPI,''); FCrossOriginIsolation:=ReadBool(SConfig,KeyCOI,FCrossOriginIsolation); if ValueExists(SConfig,KeyCapture) then begin FCaptureFileName:=ReadString(SConfig,keyCapture,''); if FCaptureFileName='' then FCaptureFileName:='-'; end; L:=TstringList.Create; ReadSectionValues(SProxy,L,[]); For I:=0 to L.Count-1 do begin L.GetNameValue(I,P,U); if (P<>'') and (U<>'') then ProxyManager.RegisterLocation(P,U).AppendPathInfo:=true; end; L.Clear; ReadSectionValues(SLocations,L,[]); For I:=0 to L.Count-1 do begin L.GetNameValue(I,P,U); if (P<>'') and (U<>'') then RegisterFileLocation(P,U); end; finally L.Free; Free; end; end; procedure THTTPApplication.ProcessOptions; Var S : String; begin for S in GetOptionValues('x','proxy') do AddProxy(S); FAPISecret:=GetOptionValue('A','api'); FEcho:=HasOption('e','echo'); Quiet:=HasOption('q','quiet'); FPassword:=GetOptionValue('Q','quit'); Port:=StrToIntDef(GetOptionValue('p','port'),Port); LoadMimeTypes; if HasOption('d','directory') then BaseDir:=GetOptionValue('d','directory'); UseSSL:=HasOption('s','ssl'); if HasOption('H','hostname') then HostName:=GetOptionValue('H','hostname'); if HasOption('n','noindexpage') then NoIndexPage:=True else IndexPageName:=GetOptionValue('i','indexpage'); if HasOption('I','interface') then InterfaceAddress:=GetOptionValue('I','interface'); FMaxAge:=StrToIntDef(GetOptionValue('a','max-age'),FMaxAge); FBackground:=HasOption('b','background'); FCrossOriginIsolation:=hasOption('o','coi'); if HasOption('u','capture') then begin FCaptureFileName:=GetOptionValue('u','capture'); if FCaptureFileName='' then FCaptureFileName:='-'; end; end; procedure THTTPApplication.Writeinfo; Var I : Integer; begin Log(etInfo,'Listening on port %d, serving files from directory: %s (using SSL: %s)',[Port,BaseDir,BoolToStr(UseSSL,'true','false')]); For I:=0 to ProxyManager.LocationCount-1 do with ProxyManager.Locations[i] do Log(etInfo,'Proxy location /proxy/%s redirects to %s',[Path,URL]); if not NoIndexPage then Log(etInfo,'Using index page %s',[IndexPageName]); if (Self.FPassword<>'') then DoLog(etInfo,'/quit route set up'); if FEcho then DoLog(etInfo,'Setting up /echo route'); Log(etInfo,'Location REST API '+IfThen(FAPISecret<>'','','NOT ')+'activated.'); end; destructor THTTPApplication.Destroy; begin FreeAndNil(FCaptureStream); inherited Destroy; end; procedure THTTPApplication.SetupCapture(Const aFileName : string); Var Dest : String; begin if (aFileName<>'') and (aFileName<>'-') then begin FCaptureStream:=TFileStream.Create(aFileName,fmCreate); Dest:='file: '+aFileName end else Dest:='console'; DoLog(etInfo,Format('Setting up capture on route "%s", writing to %s',[SCaptureRoute,Dest])); HTTPRouter.RegisterRoute(SCaptureRoute,rmPost,@DoCapture,False); end; procedure THTTPApplication.DoRun; Var S,ConfigFile : String; begin FMaxAge:=31557600; S:=Checkoptions('hqd:ni:p:sH:m:x:c:beQ:a:A:ou::',['help','quiet','noindexpage','directory:','port:','indexpage:','ssl','hostname:','mimetypes:','proxy:','config:','background','echo','quit:','max-age:','api:','coi','capture']); if (S<>'') or HasOption('h','help') then usage(S); if HasOption('c','config') then ConfigFile:=GetOptionValue('c','config') else ConfigFile:='simpleserver.ini'; ReadConfigFile(ConfigFile); ProcessOptions; if FBackground then begin {$ifdef unix} if FPFork>0 then Halt(0); {$else} Log(etError,'Background option not supported'); {$endif} end; if FCaptureFileName<>'' then SetupCapture(FCaptureFileName); if FPassword<>'' then begin HTTPRouter.RegisterRoute('/quit',rmAll,@Doquit,False); end; if FEcho then HTTPRouter.RegisterRoute('/echo',rmAll,@DoEcho,False); if ProxyManager.LocationCount>0 then begin TProxyWebModule.RegisterModule('Proxy',True); ProxyManager.OnLog:=@DoProxyLog; end; DefaultCacheControlMaxAge:=FMaxAge; // one year by default if BaseDir='' then BaseDir:=GetCurrentDir; if (BaseDir<>'') then BaseDir:=IncludeTrailingPathDelimiter(BaseDir); if FAPISecret<>'' then TFPWebFileLocationAPIModule.RegisterFileLocationAPI(ExtractWord(1,FAPISecret,[',']),ExtractWord(2,FAPISecret,[','])); if FCrossOriginIsolation then TSimpleFileModule.DefaultSimpleFileModuleClass:=TMySimpleFileModule; TSimpleFileModule.RegisterDefaultRoute; TSimpleFileModule.BaseDir:=BaseDir; TSimpleFileModule.OnLog:=@Log; If not NoIndexPage then begin if (IndexPageName='') then IndexPageName:='index.html'; TSimpleFileModule.IndexPageName:=IndexPageName; end; if not Quiet then WriteInfo; if InterfaceAddress<>'' then HTTPHandler.Address:=InterfaceAddress; inherited; end; begin Application:=THTTPApplication.Create(Nil); Application.Initialize; Application.Run; Application.Free; end.