lazarus/tools/jsonviewer/frarest.pp

unit frarest;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils, Forms, Controls, StdCtrls, Buttons, ActnList, ComCtrls, frmAuthentication, fphttpclient, SynEdit,
  SynHighlighterJScript;

type

  { TRestFrame }
  TRestRequest = Procedure (Sender : TObject; Stream : TStream) of object;

  { TRequestData }

  TRequestData = Class(TCollectionItem)
  private
    FContent: UTF8String;
    FHeaders: TStrings;
    FMethod: String;
    FName: UTF8String;
    FURL: String;
    procedure SetHeaders(AValue: TStrings);
  Public
    Constructor Create(aCollection : TCollection); override;
    Destructor Destroy; override;
    Procedure Assign(Source : TPersistent); override;
    Property Name : UTF8String Read FName Write FName;
    Property Method : String Read FMethod Write FMethod;
    Property URL : String Read FURL Write FURL;
    Property Headers : TStrings Read FHeaders Write SetHeaders;
    Property Content : UTF8String Read FContent Write FContent;
  end;

  { TRequestDataList }

  TRequestDataList = Class(TCollection)
  private
    FOnChanged : TNotifyEvent;
    function GetD(aIndex : Integer): TRequestData;
    procedure SetD(aIndex : Integer; AValue: TRequestData);
  Protected
    procedure Update(Item: TCollectionItem); override;
  Public
    Function AddRequest(aName : UTF8String) : TRequestData;
    Property Requests[aIndex : Integer] : TRequestData Read GetD Write SetD; default;
  end;

  TRestFrame = class(TFrame)
    AAddHeader: TAction;
    AAuthentication: TAction;
    AAddToFavourites: TAction;
    ASend: TAction;
    ADeleteHeader: TAction;
    AEditHeader: TAction;
    ALRest: TActionList;
    Button1: TButton;
    CBMethod: TComboBox;
    CBURL: TComboBox;
    CBUseCurrentTabContent: TCheckBox;
    ILRest: TImageList;
    LHTTPStatus: TLabel;
    LBHeaders: TListBox;
    LBResponseHeaders: TListBox;
    PCRest: TPageControl;
    SBAdd: TSpeedButton;
    SBDelete: TSpeedButton;
    SBEdit: TSpeedButton;
    SERequestContent: TSynEdit;
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    SynContent: TSynJScriptSyn;
    TSResult: TTabSheet;
    TSRequestContent: TTabSheet;
    TSHeaders: TTabSheet;
    procedure AAddHeaderExecute(Sender: TObject);
    procedure AAddToFavouritesExecute(Sender: TObject);
    procedure AAddToFavouritesUpdate(Sender: TObject);
    procedure AAuthenticationExecute(Sender: TObject);
    procedure ADeleteHeaderExecute(Sender: TObject);
    procedure ADeleteHeaderUpdate(Sender: TObject);
    procedure AEditHeaderExecute(Sender: TObject);
    procedure AEditHeaderUpdate(Sender: TObject);
    procedure ASendExecute(Sender: TObject);
    procedure ASendUpdate(Sender: TObject);
    procedure CBURLKeyPress(Sender: TObject; var Key: char);
  private
    FFavourites: TRequestDataList;
    FOnContentReceived: TRestRequest;
    FOnSendContent: TRestRequest;
    function GetOnFavouritesChanged: TNotifyEvent;
    function GetRequestData: TStream;
    function GetURL: String;
    procedure GetUserNamePassword(out aUserName, aPassword: String);
    procedure SetFavourites(AValue: TRequestDataList);
    procedure SetOnFavouritesChanged(AValue: TNotifyEvent);
    procedure SetUserNamePassword(const aUserName, aPassword: String);
    procedure ShowResult(H: TFPHTTPClient; Resp: TStream);
  public
    Constructor Create(aOwner : TComponent); override;
    Destructor Destroy; override;
    Procedure ExecuteRequest;
    Function HaveFavouriteData: Boolean;
    Function AddToFavourites(Const AName : String; AddContent : Boolean) : TRequestData;
    Function AddToFavourites : TRequestData;
    Procedure ApplyFavourite(aFavourite : TRequestData);
    Procedure LoadFavourites(Const FileName : String);
    Procedure SaveFavourites(Const FileName : String);
    Property OnFavouritesChanged : TNotifyEvent Read GetOnFavouritesChanged Write SetOnFavouritesChanged;
    Property Favourites : TRequestDataList Read FFavourites Write SetFavourites;
    Property OnSendContent: TRestRequest Read FOnSendContent Write FOnSendContent;
    Property OnContentReceived: TRestRequest Read FOnContentReceived Write FOnContentReceived;
  end;

implementation

uses base64,dialogs, uriparser, frmheader, strutils, frmaddtofavourite, jsonconf;

Const
  SAuthorization = 'Authorization';
  SBasic = 'Basic';
{$R *.lfm}

{ TRequestData }

procedure TRequestData.SetHeaders(AValue: TStrings);
begin
  if FHeaders=AValue then Exit;
  FHeaders.Assign(aValue);
end;

constructor TRequestData.Create(aCollection: TCollection);
begin
  inherited Create(aCollection);
  FHeaders:=TStringList.Create;
  FHeaders.NameValueSeparator:=':';
end;

destructor TRequestData.Destroy;
begin
  FreeAndNil(Fheaders);
  inherited Destroy;
end;

procedure TRequestData.Assign(Source: TPersistent);

Var
  RD : TRequestData;

begin
  if (Source is TRequestData) then
    begin
    RD:=Source as TRequestData;
    FName:=RD.Name;
    FContent:=RD.Content;
    FHeaders:=RD.Headers;
    FMethod:=RD.Method;
    FURL:=RD.URL;
    end
  else
    inherited Assign(Source);
end;

{ TRequestDataList }

function TRequestDataList.GetD(aIndex : Integer): TRequestData;
begin
  Result:=Items[aIndex] as TRequestData;
end;

procedure TRequestDataList.SetD(aIndex : Integer; AValue: TRequestData);
begin
  Items[aIndex]:=AValue;
end;

procedure TRequestDataList.Update(Item: TCollectionItem);
begin
  inherited Update(Item);
  If Assigned(FOnChanged) then
    FOnChanged(Self);
end;

function TRequestDataList.AddRequest(aName: UTF8String): TRequestData;
begin
  Result:=Add as TRequestData;
  Result.Name:=AName;
end;

{ TRestFrame }

procedure TRestFrame.ASendUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled:=(CBURL.Text<>'') and (CBMethod.Text<>'');
end;

procedure TRestFrame.CBURLKeyPress(Sender: TObject; var Key: char);
begin
  if Key=#13 then
    ExecuteRequest;
end;

Function TRestFrame.GetURL : String;

Var
  URI : TURI;

begin
  URI:=ParseURI(CBURL.Text,'http',80,False);
  if URI.Port=80 then
    URI.Port:=0;
  Result:=EncodeURI(URI);
end;

Function TRestFrame.GetRequestData : TStream;

var
  Req : TStream;
begin
  Req:=Nil;
  if CBUseCurrentTabContent.Checked then
    begin
    Req:=TMemoryStream.Create;
    if Assigned(OnSendContent) then
      OnSendContent(Self,Req);
    end
  else if (Trim(SERequestContent.Text)<>'') then
    begin
    Req:=TMemoryStream.Create;
    SERequestContent.Lines.SaveToStream(Req);
    end;
  if Assigned(Req) then
    Req.Position:=0;
  Result:=Req;
end;

function TRestFrame.GetOnFavouritesChanged: TNotifyEvent;
begin
  Result:=FFavourites.FOnChanged;
end;

procedure TRestFrame.ShowResult(H : TFPHTTPClient; Resp : TStream);

begin
  TSResult.TabVisible:=True;
  PCRest.ActivePage:=TSResult;
  LBResponseHeaders.Items:=H.ResponseHeaders;
  With H do
    if ResponseStatusCode=0 then
      LHTTPStatus.Caption:='HTTP request failed'
    else
      LHTTPStatus.Caption:=Format('HTTP %s %d %s',[ServerHTTPVersion,ResponseStatusCode,ResponseStatusText]);
  if Assigned(OnContentReceived) and (Resp.Size>0) then
    OnContentReceived(Self,Resp);
end;

constructor TRestFrame.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  // For some reason this is not kept ?
  LBHeaders.Items.NameValueSeparator:=':';
  FFavourites:=TRequestDataList.Create(TRequestData);
end;

destructor TRestFrame.Destroy;
begin
  FreeAndNil(FFavourites);
  inherited Destroy;
end;

procedure TRestFrame.ExecuteRequest;

Var
  H : TFPHTTPClient;
  S : String;
  Req,Resp : TStream;

begin
  Resp:=nil;
  Req:=nil;
  H:=TFPHTTPClient.Create(Self);
  try
    For S in LBHeaders.Items do
      H.RequestHeaders.Add(S);
    if Not SameText(CBMethod.Text,'GET') then
      Req:=GetRequestData;
    H.RequestBody:=Req;
    Resp:=TMemoryStream.Create;
    try
      H.HTTPMethod(CBMethod.Text,GetURL,Resp,[]);
    except
      on E : Exception do
        ShowMessage(Format('Request failed with error %s : %s',[E.ClassName,E.Message]));
    end;
    ShowResult(H,Resp);
  finally
    Req.Free;
    Resp.Free;
    H.Free;
  end;
end;

function TRestFrame.AddToFavourites(const AName: String; AddContent: Boolean): TRequestData;

Var
  R : TRequestData;
  S : TStringStream;

begin
  FFavourites.BeginUpdate;
  try
    R:=FFavourites.AddRequest(aName);
    R.Method:=CBMethod.Text;
    R.Headers:=LBHeaders.Items;
    R.URL:=CBURL.Text;
    if AddContent then
      if Not (CBUseCurrentTabContent.Checked and Assigned(OnSendContent)) then
        R.Content:=SERequestContent.Text
      else
        begin
        S:=TStringStream.Create('',CP_UTF8);
        try
          OnSendContent(Self,S);
          R.Content:=S.DataString;
        finally
          S.Free;
        end;
        end;
    Result:=R;
  finally
    FFavourites.EndUpdate;
  end;
end;

procedure TRestFrame.ApplyFavourite(aFavourite: TRequestData);

begin
  CBMethod.Text:=aFavourite.Method;
  LBHeaders.Items:=aFavourite.Headers;
  CBURL.Text:=aFavourite.URL;
  if aFavourite.Content<>'' then
    begin
    CBUseCurrentTabContent.Checked:=False;
    SERequestContent.Text:=aFavourite.Content;
    end;
end;

procedure TRestFrame.LoadFavourites(const FileName: String);
Var
  C : TJSONConfig;
  I,aCount : Integer;
  N : UTF8String;

begin
  C:=Nil;
  FFavourites.BeginUpdate;
  try
    FFavourites.Clear;
    C:=TJSONConfig.Create(Self);
    C.Filename:=FileName;
    C.OpenKey('/Favourites',True);
    aCount:=C.GetValue('Count',0);
    For I:=1 to aCount do
      begin
      C.OpenKey(Format('/Favourites/Favourite%d',[I]),True);
      N:=C.GetValue('Name','');
      With FFavourites.AddRequest(N) do
        begin
        Method:=C.GetValue('Method','GET');
        URL:=C.GetValue('Url','');
        C.GetValue('Headers',Headers,'');
        end;
      end;
  finally
    FFavourites.EndUpdate;
    C.Free;
  end;
end;

procedure TRestFrame.SaveFavourites(const FileName: String);

Var
  C : TJSONConfig;
  I : Integer;

begin
  C:=TJSONConfig.Create(Self);
  try
    C.Filename:=FileName;
    C.OpenKey('/Favourites',True);
    C.SetValue('Count',FFavourites.Count);
    For I:=0 to FFavourites.Count-1 do
      begin
      C.OpenKey(Format('/Favourites/Favourite%d',[I+1]),True);
      With FFavourites[i] do
        begin
        C.SetValue('Name',FFavourites[i].Name);
        C.SetValue('Method',FFavourites[i].Method);
        C.SetValue('Url',FFavourites[i].URL);
        C.SetValue('Headers',FFavourites[i].Headers);
        end;
      end;
    C.Flush;
  finally
    C.Free;
  end;
end;

procedure TRestFrame.ASendExecute(Sender: TObject);
begin
  ExecuteRequest;
end;

procedure TRestFrame.AAddHeaderExecute(Sender: TObject);

begin
  LBHeaders.Items.NameValueSeparator:=':';
  With THeaderForm.Create(Self) do
    try
      if ShowModal=mrOK then
        if (HeaderValue<>'') then
          LBHeaders.Items.Values[HeaderName]:=' '+HeaderValue
        else
          LBHeaders.Items.Add(HeaderName+': ');
    finally
      Free;
    end;
end;

function TRestFrame.AddToFavourites: TRequestData;

begin
  Result:=nil;
  With TSaveRequestDataForm.Create(Self) do
    try
      if ShowModal=mrOK then
        Result:=AddToFavourites(RequestName,SaveContent);
    Finally
      Free;
    end;
end;


procedure TRestFrame.AAddToFavouritesExecute(Sender: TObject);
begin
  AddToFavourites;
end;

Function TRestFrame.HaveFavouriteData : Boolean;

begin
  Result:=(CBURL.Text<>'') and (CBMethod.Text<>'');
end;

procedure TRestFrame.AAddToFavouritesUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled:=HaveFavouriteData;
end;

procedure TRestFrame.GetUserNamePassword(Out aUserName,aPassword : String);

Var
  A : String;

begin
  aUserName:='';
  aPassword:='';
  A:=Trim(LBHeaders.Items.Values[SAuthorization]);
  if Not SameText(ExtractWord(1,A,[' ']),SBasic) then exit;
  A:=ExtractWord(2,A,[' ']);
  if A='' then exit;
  A:=DecodeStringBase64(A);
  aUserName:=ExtractWord(1,A,[':']);
  aPassword:=ExtractWord(2,A,[':']);
end;

procedure TRestFrame.SetFavourites(AValue: TRequestDataList);
begin
  if FFavourites=AValue then Exit;
  FFavourites.Assign(AValue);
end;

procedure TRestFrame.SetOnFavouritesChanged(AValue: TNotifyEvent);
begin
  if GetOnFavouritesChanged=AValue then Exit;
  FFavourites.FOnChanged:=AValue;
end;

procedure TRestFrame.SetUserNamePassword(Const aUserName,aPassword : String);

Var
  A : String;

begin
  A:=EncodeStringBase64(aUserName+':'+aPassword);
  LBHeaders.Items.Values[SAuthorization]:=SBasic+' '+A;
end;

procedure TRestFrame.AAuthenticationExecute(Sender: TObject);

Var
  UN, PW : String;

begin
  LBHeaders.Items.NameValueSeparator:=':';
  GetUserNamePassword(UN,PW);
  With TAuthenticationForm.Create(Self) do
    try
      Username:=UN;
      Password:=PW;
      If ShowModal=mrOK then
        SetUserNamePassword(UserName,Password);
    finally
      Free;
    end;
end;

procedure TRestFrame.ADeleteHeaderExecute(Sender: TObject);
begin
  With LBHeaders do
    if (ItemIndex<>-1) then
      Items.Delete(ItemIndex);
end;

procedure TRestFrame.ADeleteHeaderUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled:=(LBHeaders.ItemIndex<>-1);
end;

procedure TRestFrame.AEditHeaderExecute(Sender: TObject);

Var
  idx : Integer;

begin
  LBHeaders.Items.NameValueSeparator:=':';
  idx:=LBHeaders.ItemIndex;
  With THeaderForm.Create(Self) do
    try
      HeaderName:=LBHeaders.Items.Names[idx];
      HeaderValue:=LBHeaders.Items.ValueFromIndex[idx];
      if (ShowModal=mrOK) then
        if (HeaderValue<>'') then
          LBHeaders.Items[idx]:=HeaderName+': '+HeaderValue
        else
          LBHeaders.Items[idx]:=HeaderName+':';
    finally
      Free;
    end;
end;

procedure TRestFrame.AEditHeaderUpdate(Sender: TObject);
begin
  (Sender as TAction).Enabled:=(LBHeaders.ItemIndex<>-1);
end;

end.