restemplate/restemplate.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.

    sqlvision 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/>.
}

program restemplate;

{$mode objfpc}
{$modeswitch advancedrecords}

{.$define use_synapse}
{$define use_fclweb}

uses
  SysUtils, Classes, strutils, IniFiles, fgl,
  {$ifdef use_synapse}httpsend, ssl_openssl,{$endif}
  {$ifdef use_fclweb}fphttpclient,{$endif}
  JTemplate,
  fpjson, jsonparser,
  DOM, XMLRead, XMLWrite,
  RegExpr, crt;

type
  TContentType = (ctOther, ctJSON, ctXML);

  { THighlightFilter }

  THighlightFilter = class
    Expression: TRegExpr;
    FGColor: Byte;
    BGColor: Byte;
    constructor Create(AString: String);
    destructor Destroy; override;
  class var
    FilterExpression: TRegExpr;
    ParamExpression: TRegExpr;
  end;
  TFilterList = specialize TFPGObjectList<THighlightFilter>;

  { THighlight }

  THighlight = record
    FGColor: Byte;
    BGColor: Byte;
    Start: Integer;
    Length: Integer;
    class operator =(A, B: THighlight): Boolean;
  end;
  THighlights = specialize TFPGList<THighlight>;

var
  data: TextFile;
  line: String;
  parser: TJTemplateParser;
  {$ifdef use_synapse}http: THTTPSend;{$endif}
  {$ifdef use_fclweb}http: TFPHTTPClient;{$endif}
  method, url: String;
  content: TStringList;
  commandMode: Boolean;
  configDir, templateDir: String;
  templateFile, templateName: String;
  sessionIni: TIniFile;
  beautify: Boolean;
  filters: TFilterList;

{ THighlight }

class operator THighlight. = (A, B: THighlight): Boolean;
begin
  Result := (A.Start = B.Start) and (A.Length = B.Length);
end;


{ THighlightFilter }

constructor THighlightFilter.Create(AString: String);
begin
  FGColor := $FF;
  BGColor := $FF;
  if FilterExpression.Exec(AString) then
  begin
    Expression := TRegExpr.Create(Copy(AString, 1, FilterExpression.MatchPos[0] - 1));
    if ParamExpression.Exec(FilterExpression.Match[0]) then
      repeat
        if ParamExpression.Match[1] = 'FG' then
          FGColor := StrToInt(ParamExpression.Match[2])
        else if ParamExpression.Match[1] = 'BG' then
          BGColor := StrToInt(ParamExpression.Match[2]);
      until not ParamExpression.ExecNext;
  end else
    Expression := TRegExpr.Create(AString);
end;

destructor THighlightFilter.Destroy;
begin
  Expression.Free;
  inherited Destroy;
end;

{ Main }

procedure CmdAskUser(AName: String);
var
  value, default: String;
begin
  Write(AName);
  default := sessionIni.ReadString(templateName, AName, '');
  if default <> '' then
    Write(' [', default, ']: ')
  else
    Write(': ');

  ReadLn(value);

  if value = '' then
    value := default;

  parser.Fields.Add(AName, value);

  sessionIni.WriteString(templateName, AName, value);
end;

procedure CmdHeader(AHeader: String);
var
  i: Integer;
  name, value: String;
begin
  parser.Content := AHeader;
  parser.Replace;
  AHeader := parser.Content;

  {$ifdef use_synapse}
  http.Headers.Add(AHeader);
  {$endif}

  {$ifdef use_fclweb}
  i := 1;
  while (i < Length(AHeader)) and (AHeader[i] <> ':') do
    Inc(i);

  name := Trim(Copy(AHeader, 1, i - 1));
  value := Trim(Copy(AHeader, i + 1, Length(AHeader)));

  http.AddHeader(name, value);
  {$endif}
end;

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;

function CompareHighlights(const AHL1: THighlight; const AHL2: THighlight): Integer;
begin
  if AHL1.Start = AHL2.Start then
  begin
    Result := AHL1.Length - AHL2.Length;
  end else
    Result := AHL1.Start - AHL2.Start;
end;

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

  offset := 0;
  lastPos := 1;

  for i := 0 to filters.Count - 1 do
  begin
    if filters[i].Expression.Exec(data) then
    begin
      repeat
        highlight.Start := filters[i].Expression.MatchPos[0];
        highlight.Length := filters[i].Expression.MatchLen[0];
        highlight.FGColor := filters[i].FGColor;
        highlight.BGColor := filters[i].BGColor;
        highlights.Add(highlight);
      until not filters[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;

procedure ProcessCall(AURL: String);
var
  s: String;
  {$ifdef use_fclweb}
  request, response: TStream;
  {$endif}
  jsonParser: TJSONParser;
  jsonData: TJSONData;
  contentType: TContentType;
  xmlDoc: TXMLDocument;
begin
  parser.Content := AURL;
  parser.Replace;
  AURL := parser.Content;
  writeln('Calling ', AURL);

  {$ifdef use_synapse}
  if content.Count > 0 then
  begin
    // Variable replacement
    parser.Content := content.Text;
    parser.Replace;
    content.Text .= parser.Content;

    content.SaveToStream(http.Document);
  end;

  if http.HTTPMethod(method, AURL) then
  begin
    writeln;
    writeln('Status: ', http.ResultCode);
    writeln;
    writeln('Headers:');
    for s in http.Headers do
      writeln('  ', s);
    writeln;
    content.LoadFromStream(http.Document);
    writeln(content.Text);
  end else
  begin
    ExitCode := 2;
    writeln;
    writeln('FAILED! Last Socket Error: ', http.Sock.SocksLastError);
  end;
  {$endif}

  {$ifdef use_fclweb}
  response := TMemoryStream.Create;
  request := nil;

  if content.Count > 0 then
  begin
    request := TMemoryStream.Create;

    // Variable replacement
    parser.Content := content.Text;
    parser.Replace;
    content.Text := parser.Content;

    content.SaveToStream(request);
    request.Position := 0;
    http.RequestBody := request;
  end;

  try
    http.HTTPMethod(method, AURL, response, []);
  except
    on E: Exception do
    begin
      writeln;
      writeln('Failed! ', E.Message);
      Halt(1);
    end;
  end;

  writeln;
  writeln('Status: ', http.ResponseStatusCode, ' (', http.ResponseStatusText, ')');
  writeln;
  writeln('Headers:');
  for s in http.ResponseHeaders do
    writeln('  ', s);
  writeln;

  response.Position := 0;

  if beautify and IdentifyContentType(http.GetHeader(http.ResponseHeaders, 'Content-Type'), contentType) then
  begin
    case contentType of
      ctJSON:
        begin
          jsonParser := TJSONParser.Create(response);
          jsonData := jsonParser.Parse;
          content.Text := jsonData.FormatJSON;
          jsonData.Free;
          jsonParser.Free;
          WriteContent;
        end;
      ctXML:
        begin
          ReadXMLFile(xmlDoc, response);
          response.Size := 0;
          WriteXMLFile(xmlDoc, response);
          response.Position := 0;
          content.LoadFromStream(response);
          WriteContent;
        end;
    end;
  end else
  begin
    content.LoadFromStream(response);
    WriteContent;
  end;

  response.Free;
  request.Free;
  {$endif}
end;

procedure 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);

  http.UserName := Copy(AData, 2, i - 2);
  http.Password := Copy(AData, i + 1, Length(AData));
end;

procedure CmdHighlight(AData: String);
begin
  writeln('Adding expression: ', AData);
  filters.Add(THighlightFilter.Create(AData));
end;

function ProcessCommand(ALine: String): Boolean;
begin
  Result := False;
  if AnsiStartsStr('Ask ', ALine) then
  begin
    Result := True;
    CmdAskUser(Copy(ALine, 5, 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;
    method := 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;
    beautify := True;
  end else
  if AnsiStartsStr('Highlight ', ALine) then
  begin
    Result := True;
    CmdHighlight(Copy(ALine, 11, Length(ALine)));
  end else
  if AnsiStartsStr('Call ', ALine) then
  begin
    Result := True;
    url := Copy(ALine, 6, Length(ALine));
  end;
end;

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

begin
  configDir := GetAppConfigDir(False);
  templateDir := configDir + 'templates' + PathDelim;

  templateFile := templateDir + ParamStr(1) + '.rest';

  if ParamCount <> 1 then
  begin
    Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' <profile or file>');
    Writeln;
    ListProfiles;
    Halt(0);
  end;

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

  sessionIni := TIniFile.Create(configDir + 'session.ini');

  parser := TJTemplateParser.Create;
  content := TStringList.Create;
  beautify := False; //By default, we don't want to manipulate output.
  filters := TFilterList.Create;
  THighlightFilter.FilterExpression := TRegExpr.Create('( (FG|BG)(\d+))*$');
  THighlightFilter.ParamExpression := TRegExpr.Create('(FG|BG)(\d+)');

  {$ifdef use_synapse}
  http := THTTPSend.Create;
  {$endif}

  {$ifdef use_fclweb}
  http := TFPHttpClient.Create(nil);
  {$endif}

  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
        content.Add(line);
    end;

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

  finally
    sessionIni.Free;
    parser.Free;
    http.Free;
    content.Free;
    filters.Free;
    THighlightFilter.FilterExpression.Free;
    THighlightFilter.ParamExpression.Free;

    CloseFile(data);
  end;
end.