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


			
							123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591
							{
    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;

Const
  ServerVersion = '1.0';

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(['<!doctype html>',
      '<html>',
      '<head>',
      '<title>Echo request</title>',
      '</head>',
      '<body>'
    ]);
    DumpRequest(aRequest,L);
    L.AddStrings(['</body>','</html>']);
    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('Version : ',ServerVersion);
  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('-V --version          Display server version and exit');         
  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;

  procedure HasGetOptionValue(var aValue: string; Const C: Char; Const S : String);
  begin
    if HasOption(C,S) then
      aValue:=GetOptionValue(C,S);
  end;

Var
  S : String;

begin
  for S in GetOptionValues('x','proxy') do
    AddProxy(S);
  HasGetOptionValue(FAPISecret,'A','api');
  if HasOption('e','echo') then
    FEcho:=true;
  if HasOption('q','quiet') then
    Quiet:=true;
  HasGetOptionValue(FPassword,'Q','quit');
  if HasOption('p','port') then
    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');
  if HasOption('a','max-age') then
    FMaxAge:=StrToIntDef(GetOptionValue('a','max-age'),FMaxAge);
  if HasOption('b','background') then
    FBackground:=true;
  if hasOption('o','coi') then
    FCrossOriginIsolation:=true;
  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::VI',['help','quiet','noindexpage','directory:','port:','indexpage:','ssl','hostname:','mimetypes:','proxy:','config:','background','echo','quit:','max-age:','api:','coi','capture','version','interface']);
  if (S<>'') or HasOption('h','help') then
    usage(S);
  if HasOption('V','version') then
    begin
    Terminate;
    Writeln(ServerVersion);
    Exit;
    end;
  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.