restemplate/URestemplateApp.pas

{
    This file is part of restemplate.

    Copyright (C) 2015 Andreas Schneider

    restemplate is free software: you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation, either version 3 of the License, or
    (at your option) any later version.

    restemplate 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.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with restemplate.  If not, see <http://www.gnu.org/licenses/>.
}
unit URestemplateApp;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, CustApp,
  IniFiles, jsonparser, JTemplate,
  UFilter, IdHTTP, IdMultipartFormData;

type

  { TRestHTTP }

  TRestHTTP = class(TIdHTTP)
  public
    procedure Perform(AMethod, AURL: String; ARequest, AResponse: TStream);
  end;

  { TRestRequest }

  TRestRequest = class(TIdHTTPRequest)
  public
    procedure Prepare;
  end;

  { TRestemplateApplication }

  TRestemplateApplication = class(TCustomApplication)
  protected
    FConfigDir: String;
    FTemplateDir: String;
    FSessionIni: TIniFile;
    FTemplateName: String;
    FParser: TJTemplateParser;
    FHttp: TRestHTTP;
    FRequest: TRestRequest;
    FContent: TStringList;
    FFormFields: TIdMultiPartFormDataStream;
    FFilters: TFilterList;
    FBeautify: Boolean;
    FURL: String;
    FMethod: String;
    //Main
    procedure DoRun; override;
    //Command processing
    function ProcessCommand(ALine: String): Boolean;
    procedure CmdAskUser(AName: String);
    procedure CmdHeader(AHeader: String);
    procedure CmdBasicAuth(AData: String);
    procedure CmdHighlight(AData: String);
    procedure CmdFormField(AData: String);
    procedure ProcessCall(AURL: String);
    //Helper
    procedure WriteHelp;
    procedure ListTemplates;
    procedure WriteContent;
  public
    constructor Create; overload;
    destructor Destroy; override;
  end;

implementation

uses
  strutils, crt, UCRTHelper, fpjson, DOM, XMLRead, XMLWrite, vinfo,
  IdCompressorZLib;

type
  TContentType = (ctOther, ctJSON, ctXML);

function IdentifyContentType(AString: String; out ContentType: TContentType): Boolean;
begin
  if Pos('application/json', AString) > 0 then
    ContentType := ctJSON
  else if Pos('application/xml', AString) > 0 then
    ContentType := ctXML
  else
    ContentType := ctOther;

  Result := (ContentType <> ctOther);
end;

{ TRestRequest }

procedure TRestRequest.Prepare;
begin
  //Parse RawHeaders, since they have precendence and should not be overridden!
  ProcessHeaders;
end;

{ TRestHTTP }

procedure TRestHTTP.Perform(AMethod, AURL: String; ARequest, AResponse: TStream
  );
begin
  DoRequest(AMethod, AURL, ARequest, AResponse, []);
end;

{ TRestemplateApplication }

procedure TRestemplateApplication.DoRun;
var
  templateFile: String;
  line: String;
  data: TextFile;
  commandMode: Boolean;
begin
  if HasOption('l', 'list') then
  begin
    ListTemplates;
    Terminate;
    Exit;
  end;

  if HasOption('h', 'help') or (ParamCount < 1) or
    (ParamStr(ParamCount)[1] = '-') then
  begin
    WriteHelp;
    Terminate;
    Exit;
  end;

  templateFile := FTemplateDir + ParamStr(ParamCount) + '.rest';

  if FileExists(ParamStr(ParamCount)) then
  begin
    AssignFile(data, ParamStr(1));
    FTemplateName := ExtractFileName(ParamStr(1));
    if AnsiEndsStr('.rest', FTemplateName) then
      FTemplateName := Copy(FTemplateName, 1, Length(FTemplateName) - 5);
  end else
  if FileExists(templateFile) then
  begin
    AssignFile(data, templateFile);
    FTemplateName := ParamStr(ParamCount);
  end else
  begin
    writeln('Template ', ParamStr(ParamCount), ' not found!');
    Terminate;
    Exit;
  end;
  Reset(data);

  FBeautify := False; //By default, we don't want to manipulate output.

  commandMode := True;

  try
    while not EOF(data) do
    begin
      ReadLn(data, line);
      if commandMode and (line <> '') and (line[1] <> '#') and
        not ProcessCommand(line) then
      begin
        commandMode := False;
      end;

      if not commandMode then
        FContent.Add(line);
    end;

    if FURL <> '' then
      ProcessCall(FURL);

  finally
    CloseFile(data);
  end;

  Terminate;
end;

function TRestemplateApplication.ProcessCommand(ALine: String): Boolean;
begin
  Result := False;
  //The first char after "Ask" is treated as "mode". "#" means password.
  if AnsiStartsStr('Ask', ALine) then
  begin
    Result := True;
    CmdAskUser(Copy(ALine, 4, Length(ALine)));
  end else
  if AnsiStartsStr('Header ', ALine) then
  begin
    Result := True;
    CmdHeader(Copy(ALine, 8, Length(ALine)));
  end else
  if AnsiStartsStr('Method ', ALine) then
  begin
    Result := True;
    FMethod := Copy(ALine, 8, Length(ALine));
  end else
  // We don't include the space here, since we also interpret this following
  // char as separator for username and password! (In case the username itself
  // contains a space.)
  if AnsiStartsStr('BasicAuth', ALine) then
  begin
    Result := True;
    CmdBasicAuth(Copy(ALine, 10, Length(ALine)));
  end else
  if ALine = 'Beautify' then
  begin
    Result := True;
    FBeautify := True;
  end else
  if AnsiStartsStr('Highlight ', ALine) then
  begin
    Result := True;
    CmdHighlight(Copy(ALine, 11, Length(ALine)));
  end else
  if AnsiStartsStr('FormField ', ALine) then
  begin
    Result := True;
    CmdFormField(Copy(ALine, 11, Length(ALine)));
  end else
  if AnsiStartsStr('Compress', ALine) then
  begin
    Result := True;
    FHttp.Compressor := TIdCompressorZLib.Create(FHttp);
  end else
  if AnsiStartsStr('Call ', ALine) then
  begin
    Result := True;
    FURL := Copy(ALine, 6, Length(ALine));
  end;
end;

procedure TRestemplateApplication.CmdAskUser(AName: String);
var
  mode: TPromptMode;
  value, default: String;
begin
  if Length(AName) < 2 then
    raise Exception.Create('Asking without variable!');

  if AName[1] <> ' ' then
    mode := pmPassword
  else
    mode := pmNormal;

  AName := Copy(AName, 2, Length(AName));

  if mode = pmNormal then
  begin
    default := FSessionIni.ReadString(FTemplateName, AName, '');
    value := Prompt(AName, default);
  end else
  begin
    value := Prompt(AName, mode);
  end;

  if value = '' then
    Halt(3); //Cancelled

  FParser.Fields.Add(AName, value);

  if mode = pmNormal then
    FSessionIni.WriteString(FTemplateName, AName, value);
end;

procedure TRestemplateApplication.CmdHeader(AHeader: String);
var
  i: Integer;
  varName, varValue: String;
begin
  FParser.Content := AHeader;
  FParser.Replace;
  AHeader := FParser.Content;

  i := 1;
  while (i < Length(AHeader)) and (AHeader[i] <> ':') do
    Inc(i);

  varName := Trim(Copy(AHeader, 1, i - 1));
  varValue := Trim(Copy(AHeader, i + 1, Length(AHeader)));

  //Special handling is required for Indy
  {if SameText(varName, 'Accept-Encoding') then
    FHttp.Request.AcceptEncoding := varValue
  else}
    FRequest.RawHeaders.AddValue(varName, varValue);
end;

procedure TRestemplateApplication.CmdBasicAuth(AData: String);
var
  separator: Char;
  i: Integer;
begin
  separator := AData[1];
  i := 2;
  while (i < Length(AData)) and (AData[i] <> separator) do
    Inc(i);

  FRequest.Username := Copy(AData, 2, i - 2);
  FRequest.Password := Copy(AData, i + 1, Length(AData));
  FRequest.BasicAuthentication := True;
end;

procedure TRestemplateApplication.CmdHighlight(AData: String);
begin
  FFilters.Add(THighlightFilter.Create(AData))
end;

procedure TRestemplateApplication.CmdFormField(AData: String);
var
  i: Integer;
begin
  i := 1;
  FParser.Content := AData;
  FParser.Replace;
  AData := FParser.Content;

  while (i < Length(AData)) and (AData[i] <> '=') do
    Inc(i);

  FFormFields.AddFormField(Copy(AData, 1, i - 1), Copy(AData, i + 1, Length(AData)));
end;

procedure TRestemplateApplication.ProcessCall(AURL: String);
var
  s: String;
  request, response: TStream;
  jsonParser: TJSONParser;
  jsonData: TJSONData;
  contentType: TContentType;
  xmlDoc: TXMLDocument;
begin
  FParser.Content := AURL;
  FParser.Replace;
  AURL := FParser.Content;
  writeln('Calling ', AURL);

  response := TMemoryStream.Create;
  request := nil;

  if FContent.Count > 0 then
  begin
    request := TMemoryStream.Create;
    // Variable replacement
    FParser.Content := FContent.Text;
    FParser.Replace;
    FContent.Text := FParser.Content;

    FContent.SaveToStream(request);
  end;

  try
    FRequest.Prepare;
    FHttp.Request := FRequest;
    FHttp.HTTPOptions := FHttp.HTTPOptions + [hoNoProtocolErrorException];
    if FFormFields.Size > 0 then
    begin
      FHttp.Request.ContentType := FFormFields.RequestContentType;
      FHttp.Perform(FMethod, AURL, FFormFields, response);
    end else
      FHttp.Perform(FMethod, AURL, request, response);
  except
    on E: Exception do
    begin
      writeln;
      writeln('Failed! ', E.Message);
      Halt(1);
    end;
  end;

  writeln;
  writeln('Status: ', FHttp.ResponseCode, ' (', FHttp.ResponseText, ')');
  writeln;
  writeln('Headers:');
  for s in FHttp.Response.RawHeaders do
    writeln('  ', s);
  writeln;

  response.Position := 0;

  if FBeautify and IdentifyContentType(FHttp.Response.ContentType, contentType) then
  begin
    case contentType of
      ctJSON:
        begin
          jsonParser := TJSONParser.Create(response);
          jsonData := jsonParser.Parse;
          FContent.Text := jsonData.FormatJSON;
          jsonData.Free;
          jsonParser.Free;
          WriteContent;
        end;
      ctXML:
        begin
          ReadXMLFile(xmlDoc, response);
          response.Size := 0;
          WriteXMLFile(xmlDoc, response);
          response.Position := 0;
          FContent.LoadFromStream(response);
          WriteContent;
        end;
    end;
  end else
  begin
    FContent.LoadFromStream(response);
    WriteContent;
  end;

  response.Free;
  request.Free;
end;

procedure TRestemplateApplication.WriteHelp;
begin
  NormVideo;
  TextColor(Green);
  Writeln('restemplate ', VersionInfo.GetProductVersionString);
  Writeln('Copyright (c) ', VersionInfo.GetCopyright(False));
  NormVideo;
  Writeln;
  Writeln('Usage: ', ExtractFileName(ExeName), ' [options] <template>');
  Writeln;
  Writeln('Tempate can be either a filename or a known template.');
  Writeln;
  Writeln('Options:');
  Writeln('  -l --list');
  Writeln('    Print a list of known templates.');
  Writeln('  -h --help');
  Writeln('    Print this help screen.');
end;

procedure TRestemplateApplication.ListTemplates;
var
  sr: TSearchRec;
begin
  Writeln('Known Templates:');
  if FindFirst(FTemplateDir + '*.rest', faAnyFile, sr) = 0 then
  begin
    repeat
      writeln('  ', Copy(sr.Name, 1, Length(sr.Name) - 5));
    until FindNext(sr) <> 0;
  end;
end;

procedure TRestemplateApplication.WriteContent;
var
  i: Integer;
  matchPos, offset, lastPos: Integer;
  data: String;
  highlights: THighlights;
  highlight: THighlight;
begin
  highlights := THighlights.Create;
  data := FContent.Text;

  offset := 0;
  lastPos := 1;

  for i := 0 to FFilters.Count - 1 do
  begin
    if FFilters[i].Expression.Exec(data) then
    begin
      repeat
        highlight.Start := FFilters[i].Expression.MatchPos[0];
        highlight.Length := FFilters[i].Expression.MatchLen[0];
        highlight.FGColor := FFilters[i].FGColor;
        highlight.BGColor := FFilters[i].BGColor;
        highlights.Add(highlight);
      until not FFilters[i].Expression.ExecNext;
    end;
  end;

  highlights.Sort(@CompareHighlights);

  // Sanitize highlights
  for i := 0 to highlights.Count - 2 do
  begin
    if (highlights[i].Start + highlights[i].Length) > highlights[i+1].Start then
    begin
      highlight := highlights[i];
      highlight.Length := highlights[i+1].Start - highlights[i].Start;
      highlights[i] := highlight;
    end;
  end;

  for highlight in highlights do
  begin
    matchPos := highlight.Start;
    offset := highlight.Length;
    write(Copy(data, lastPos, matchPos - lastPos));
    if highlight.FGColor < $FF then
      TextColor(highlight.FGColor);
    if highlight.BGColor < $FF then
      TextBackground(highlight.BGColor);
    write(Copy(data, matchPos, offset));
    NormVideo;
    lastPos := matchPos + offset;
  end;

  writeln(Copy(data, lastPos, Length(data)));

  highlights.Free;
end;

constructor TRestemplateApplication.Create;
begin
  inherited Create(nil);
  StopOnException := True;

  FConfigDir := GetAppConfigDir(False);
  FTemplateDir := FConfigDir + 'templates' + PathDelim;

  FSessionIni := TIniFile.Create(FConfigDir + 'session.ini');
  FContent := TStringList.Create;
  FFormFields := TIdMultiPartFormDataStream.Create;
  FHttp := TRestHTTP.Create(nil);
  FRequest := TRestRequest.Create(FHttp);
  FRequest.RawHeaders.AddValue('User-Agent', 'Mozilla/4.0 (compatible; restemplate ' + VersionInfo.GetProductVersionString + ')');
  FFilters := TFilterList.Create;
  FParser := TJTemplateParser.Create;
end;

destructor TRestemplateApplication.Destroy;
begin
  FSessionIni.Free;
  FContent.Free;
  FFormFields.Free;
  FHttp.Free;
  //TODO Owned? FRequest.Free;
  FFilters.Free;
  FParser.Free;
  inherited Destroy;
end;

end.