{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       Angus Robertson, Magenta Systems Ltd
Description:  HTTPS REST functions, descends from THttpCli, and publishes all
              it's properties and events with additional methods and properties
              for making REST (REpresentional State Transfer) client requests.
              The TSslHttpRest component is a high level version of THttpCli
              that bundles all the extra components for extra functionality,
              including SSL configuration and certificate validation with a
              root bundle, SSL session caching, content compression, content
              code page decoding, persistent cookies, Json handling, logging,
              client SSL certificate.
              Includes functions for OAuth2 authentication.
Creation:     Apr 2018
Updated:      Nov 2018
Version:      8.58
EMail:        francois.piette@overbyte.be  http://www.overbyte.be
Support:      Use the mailing list twsocket@elists.org
Legal issues: Copyright (C) 2018 by Angus Robertson, Magenta Systems Ltd,
              Croydon, England. delphi@magsys.co.uk, https://www.magsys.co.uk/delphi/

              This software is provided 'as-is', without any express or
              implied warranty.  In no event will the author be held liable
              for any  damages arising from the use of this software.

              Permission is granted to anyone to use this software for any
              purpose, including commercial applications, and to alter it
              and redistribute it freely, subject to the following
              restrictions:

              1. The origin of this software must not be misrepresented,
                 you must not claim that you wrote the original software.
                 If you use this software in a product, an acknowledgment
                 in the product documentation would be appreciated but is
                 not required.

              2. Altered source versions must be plainly marked as such, and
                 must not be misrepresented as being the original software.

              3. This notice may not be removed or altered from any source
                 distribution.

              4. You must register this software by sending a picture postcard
                 to the author. Use a nice stamp and mention your name, street
                 address, EMail address and any comment you like to say.


Overview
--------

TRestParams
-----------

Defines a collection of  REST parameters and allows them to be saved as
URL encoded or Json. Note only supports Json strings with key/pair values,
not arrays or nested objects.


TSslHttpRest
------------

This descends from THttpCli, and publishes all it's properties and events with
additional methods and properties for making REST (REpresentional State Transfer)
client requests.


TSimpleWebSrv
-------------
This is a simple web server primarily designed for accepting HTTP requests from
REST servers which don't expect real pages to be sent, but also for .well-known
responses generated by applications.  Note this web server does not support SSL
since that would require certificates.


TRestOAuth
----------
This for handling 0Auth authorization to web apps, by several means.  Beware
OAuth is really a concept with differing implementations, so that implementation
may not always be straight forward.  OAuth1 and 1A were originally developed for
Twitter and use cryptography, OAuth2 is a simpler and easier to implement version
now widely used by most cloud services without any cryptography (other than SSL).

The conceptual issue about OAuth is that applications should not know any login
details.  The login need to be entered through a browser, which then redirects to
a fixed URL which includes an Authorization Code that is subsequently exchanged
for an Access Token that can used by the REST client.  This is really all designed
for interactive applications, on mobile platforms in particular.

Originally it was considered allowable for native applications to display an
embedded browser window in the application to capture the Authorization Code
during redirect.  But that potentially means the application can also capture the
login as well so is no longer best practice, see RFC8252, and some apps will
block the embedded window.

The preferred authorization method is for the native application to launch the
standard browser and redirect to localhost where a small web server runs to
capture the Authorization Code.  That is how TRestOAuth works, transparently
to the user, capturing the Authorization Code and using it for a token grant to
get an Access Token.  Note that Authorization Codes expire in a few minutes and
immediately they are exchanged for a token.

The Access Token is then sent with all HTTPS REST requests as an 'Authorization:
Bearer' header.

Access Tokens have a limited life and usually expire within three to 24 hours.
To avoid user interaction, the token exchange process sometimes offers a Refresh
Token with the same expiry, but which can be used to get another Access Token,
and this is automatically handled by TRestOAuth, while it still runs.

So the trick for native applications is to keep refreshing the Access Token before
it expires, allowing your application to keep running.  Store the Refresh Token
securely, since it's a potential security risk.

Setting up OAuth is complex and requires a lot more information than just a site
user name and password.  You normally need to access the desired site and create
an app or client (terminology varies) but will always involve creating a client
ID and client secret, and a redirect URL which will be the local web server.  The
default redirect used by TRestOAuth is http:/localhost:8080/.  There are also
two API URLs, one for the authorization endpoint (displayed in the browser) and
then the token exchange endpoint for REST requests.  Some sites may provide OAuth2
details with the URL (host)/.well-known/openid-configuration as Json, ie:
https://accounts.google.com/.well-known/openid-configuration .   Finally, OAuth
may require the token Scope to be specified, it's purpose or access rights
depending on the server.

Note that in addition to granting tokens using an Authorization Code from a
browser login, some OAuth implementations may support grants for client
credentials alone (ID and secret, without a login) or directly for login and
password (and client ID and secret) which is by far the easiest to use, but not
often available, both are supported by TRestOAuth.


Updates:
May 21, 2018  - V8.54 - baseline
Jul  2, 2018  - V8.55 - Improved Json error handling
                       Builds with NO_DEBUG_LOG
Oct 2, 2018   - V8.57 - Need OAuth local web server for all auth methods.
                        Builds with FMX
Nov 2, 2018   - V8.58 - Bug fixes, call RequestDone event if it fails
                        Descend components from TIcsWndControl not TComponent



Pending - Simple web server now less simple to supports SSL and ALPN
Pending - more documentation
Pending - better SSL error handling when connections fail, due to too high security in particular.
Pending - OAuth don't spawn browser from Windows service
Pending - OAuth1 (need Twitter account).
Pending - REST response for DelphiXE Json Objects Framework
}

{$IFNDEF ICS_INCLUDE_MODE}
unit OverbyteIcsSslHttpRest;
{$ENDIF}

{$I Include\OverbyteIcsDefs.inc}

{$IFDEF COMPILER14_UP}
  {$IFDEF NO_EXTENDED_RTTI}
    {$RTTI EXPLICIT METHODS([]) FIELDS([]) PROPERTIES([])}
  {$ENDIF}
{$ENDIF}
{$B-}             { Enable partial boolean evaluation   }
{$T-}             { Untyped pointers                    }
{$X+}             { Enable extended syntax              }
{$H+}             { Use long strings                    }
{$IFDEF BCB}
    {$ObjExportAll On}
{$ENDIF}

interface

uses
{$IFDEF MSWINDOWS}
    {$IFDEF RTL_NAMESPACES}Winapi.Messages{$ELSE}Messages{$ENDIF},
    {$IFDEF RTL_NAMESPACES}Winapi.Windows{$ELSE}Windows{$ENDIF},
    {$IFDEF RTL_NAMESPACES}Winapi.ShellAPI{$ELSE} ShellAPI{$ENDIF},
{$ENDIF}
{$IFDEF POSIX}
    Posix.Time,
    Ics.Posix.WinTypes,
    Ics.Posix.Messages,
{$ENDIF}
    {$IFDEF RTL_NAMESPACES}System.Classes{$ELSE}Classes{$ENDIF},
    {$IFDEF RTL_NAMESPACES}System.Sysutils{$ELSE}Sysutils{$ENDIF},
    {$IFDEF RTL_NAMESPACES}System.TypInfo{$ELSE}TypInfo{$ENDIF},
    OverbyteIcsSsleay, OverbyteIcsLibeay,
    OverbyteIcsTypes,
    OverbyteIcsUtils,
    OverbyteIcsUrl,
{$IFDEF FMX}
    Ics.Fmx.OverbyteIcsWndControl,
    Ics.Fmx.OverbyteIcsWSocket,
    Ics.Fmx.OverbyteIcsWSocketS,
    Ics.Fmx.OverbyteIcsHttpProt,
    Ics.Fmx.OverbyteIcsSslSessionCache,
    Ics.Fmx.OverbyteIcsSslX509Utils,
    Ics.Fmx.OverbyteIcsMsSslUtils,
    Ics.Fmx.OverbyteIcsSslJose,
{$ELSE}
    OverbyteIcsWndControl,
    OverbyteIcsWSocket,
    OverbyteIcsWSocketS,
    OverbyteIcsHttpProt,
    OverbyteIcsSslSessionCache,
    OverbyteIcsSslX509Utils,
    OverbyteIcsMsSslUtils,
    OverbyteIcsSslJose,
{$ENDIF FMX}
{$IFDEF MSWINDOWS}
    OverbyteIcsWinCrypt,
{$ENDIF MSWINDOWS}
    OverbyteIcsHttpCCodZLib,
    OverbyteIcsHttpContCod,
    OverbyteIcsLogger,
    OverbyteIcsCookies,
    OverbyteIcsMimeUtils,
    OverbyteIcsFormDataDecoder,
    OverbyteIcsCharsetUtils,
    OverbyteIcsSuperObject;

{ NOTE - these components only build with SSL, there is no non-SSL option }

{$IFDEF USE_SSL}

const
    THttpRestVersion = 858;
    CopyRight : String = ' TSslHttpRest (c) 2018 F. Piette V8.58 ';
    DefMaxBodySize = 100*100*100; { max memory/string size 100Mbyte }
    TestState = 'Testing-Redirect';

    OAuthErrBase                     = {$IFDEF MSWINDOWS} 1 {$ELSE} 1061 {$ENDIF};
    OAuthErrNoError                  = 0;
    OAuthErrParams                   = OAuthErrBase;
    OAuthErrBadGrant                 = OAuthErrBase+1;
    OAuthErrWebSrv                   = OAuthErrBase+2;
    OAuthErrBrowser                  = OAuthErrBase+3;


type

{ event handlers }
  THttpRestProgEvent  = procedure (Sender: TObject; LogOption: TLogOption; const Msg: string) of object;
  TSimpleWebSrvReqEvent  = procedure (Sender: TObject; const Host, Path, Params: string; var RespCode, Body: string) of object;
  TOAuthAuthUrlEvent = procedure (Sender: TObject; const URL: string) of object;

{ property and state types }
  TPContent = (PContUrlencoded, PContJson);
  TOAuthProto = (OAuthv1, OAuthv1A, OAuthv2);
  TOAuthType = (OAuthTypeWeb, OAuthTypeMan, OAuthTypeEmbed);
  TOAuthOption = (OAopAuthNoRedir,    { OAuth Auth Request do not send redirect_url }
                  OAopAuthNoScope,    { OAuth Auth Request do not send scope }
                  OAopAuthNoState);   { OAuth Auth Request do not send state }
  TOAuthOptions = set of TOAuthOption;

{ forware declarations }
  TSimpleWebSrv = class;


{ TRestParam is one REST parameter }
  TRestParam = class(TCollectionItem)
  private
    FPName: String;
    FPValue: String;
    FPRaw: Boolean;
  protected
    function GetDisplayName: string; override;
  published
    constructor Create (Collection: TCollection); Override ;
    property PName: String                read  FPName
                                          write FPName;
    property PValue : String              read  FPValue
                                          write FPValue;
    property PRaw : boolean               read  FPRaw
                                          write FPRaw;
  end;

{ TRestParams defines a collection of  REST parameters }
  TRestParams = class(TCollection)
  private
    FOwner: TPersistent;
    FPContent: TPContent;
    function GetItem(Index: Integer): TRestParam;
    procedure SetItem(Index: Integer; Value: TRestParam);
  protected
    function GetOwner: TPersistent; override;
  public
    constructor Create(Owner: TPersistent); 
    function GetParameters: AnsiString;
    function IndexOf(const aName: string): Integer;
    procedure AddItem(const aName, aValue: string; aRaw: Boolean = False);
    property Items[Index: Integer]: TRestParam      read GetItem
                                                    write SetItem; default;
  published
    property PContent: TPContent                    read FPContent
                                                    write FPContent;
  end;

{ TSslHttpRest descends from THttpCli, and publishes all it's properties
   and events with additional methods and properties for making REST
   (REpresentional State Transfer) client requests. }

  TSslHttpRest = class(TSslHttpCli)
  private
    { Private declarations }
    FRestParams: TRestParams;
    FDebugLevel: THttpDebugLevel;
    FPostStream: TMemoryStream;
    FResponseJson: ISuperObject;
    FResponseStream: TMemoryStream;
    FResponseRaw: UnicodeString;
    FResponseSize: Integer;
    FMaxBodySize: Int64;
    FInitSsl: Boolean;
    FRespReq: Boolean;
    FSslSessCache: boolean;
    FExternalSslSessionCache: TSslAvlSessionCache;
    FCertVerMethod: TCertVerMethod;
    FSslRootFile: string;
    FSslRevocation: boolean;
    FSslReportChain: boolean;
    FSslCliCert: TX509Base;
    FSslCliSecurity:  TSslCliSecurity;
{$IFDEF MSWINDOWS}
    FMsCertChainEngine: TMsCertChainEngine;
{$ENDIF}
    FOnHttpRestProg: THttpRestProgEvent;
    FOnRestRequestDone: THttpRequestDone;
    FOnRestLocChange: TNotifyEvent;
  protected
    { Protected declarations }

    procedure LogEvent(const Msg : String);
    procedure SetRestParams(Value: TRestParams);
    procedure SetSslCliCert(Value: TX509Base);
    procedure SetSslCliSecurity(Value: TSslCliSecurity);
    function  GetResponseJson: ISuperObject;
    function  GetResponseOctet: AnsiString;
    procedure IcsLogEvent (Sender: TObject; LogOption: TLogOption; const Msg : String);
    procedure onHttpDocBegin(Sender : TObject);
    procedure onHttpCommand(Sender: TObject; var S: String);
    procedure onHttpHeaderData(Sender : TObject);
    procedure onHttpSessionConnected(Sender : TObject);
    procedure onHttpSessionClosed(Sender : TObject);
    procedure onHttpLocationChange(Sender : TObject);
    procedure onHttpRequestDone(Sender: TObject; RqType : THttpRequest; ErrCode : Word);
    procedure OnHttpSslVerifyPeer(Sender: TObject; var Ok: Integer; Cert : TX509Base);
    procedure OnHttpSslCliNewSession(Sender: TObject; SslSession: Pointer;
                                    WasReused: Boolean; var IncRefCount : Boolean);
    procedure OnHttpSslCliGetSession(Sender: TObject; var SslSession: Pointer;
                                                            var FreeSession : Boolean);
    procedure OnHttpSslHandshakeDone(Sender: TObject; ErrCode: Word;
                                      PeerCert: TX509Base; var Disconnect: Boolean);
    procedure OnHttpSslCliCertRequest(Sender: TObject; var Cert: TX509Base);
    procedure onHttpCookie(Sender : TObject; const Data : String; var Accept : Boolean);
    procedure onCookiesNewCookie(Sender : TObject; ACookie : TCookie; var Save : Boolean);

  public
    { Public declarations }
    RestCookies: TIcsCookies;
{$IFNDEF NO_DEBUG_LOG}
    RestLogger:  TIcsLogger;
{$ENDIF}
    RestSslCtx:  TSslContext;
    constructor  Create (Aowner: TComponent); override;
    destructor   Destroy; override;
    procedure    InitSsl;
    procedure    ResetSsl;
    procedure    ClearResp;
    function     GetParams(HttpRequest: THttpRequest): AnsiString;
    function     RestRequest(HttpRequest: THttpRequest; const RestURL: String;
                    AsyncReq: Boolean = False; const RawParams: String = ''): Integer;

  published
    { Published declarations }
    property RestParams: TRestParams                    read  FRestParams
                                                        write SetRestParams;
    property DebugLevel:THttpDebugLevel                 read  FDebugLevel
                                                        write FDebugLevel;
    property ResponseRaw: UnicodeString                 read  FResponseRaw;
    property ResponseJson: ISuperObject                 read  GetResponseJson;
    property ResponseOctet: AnsiString                  read  GetResponseOctet;
    property ResponseStream: TMemoryStream              read  FResponseStream;
    property ResponseSize: Integer                      read  FResponseSize;
    property MaxBodySize: Int64                         read  FMaxBodySize
                                                        write FMaxBodySize;
    property SslCliSecurity: TSslCliSecurity            read  FSslCliSecurity
                                                        write SetSslCliSecurity;
    property SslCliCert: TX509Base                      read  FSslCliCert
                                                        write SetSslCliCert;
    property SslSessCache: boolean                      read  FSslSessCache
                                                        write FSslSessCache;
    property CertVerMethod: TCertVerMethod              read  FCertVerMethod
                                                        write FCertVerMethod;
    property SslRootFile: string                        read  FSslRootFile
                                                        write FSslRootFile;
    property SslRevocation: boolean                     read  FSslRevocation
                                                        write FSslRevocation;
    property SslReportChain: boolean                    read  FSslReportChain
                                                        write FSslReportChain;
    property OnBgException;
    property OnHttpRestProg: THttpRestProgEvent         read  FOnHttpRestProg
                                                        write FOnHttpRestProg;
    property OnRestRequestDone: THttpRequestDone        read  FOnRestRequestDone
                                                        write FOnRestRequestDone;
    property OnRestLocChange: TNotifyEvent              read  FOnRestLocChange
                                                        write FOnRestLocChange;
  end;

{ TSimpleWebSrv is a simple web server primarily designed for accepting
   requests from REST servers which don't expect real pages to be sent }

  TSimpleClientSocket = class(TSslWSocketClient)
  private
    { Private declarations }
  public
    { Public declarations }
    WebSrv: TSimpleWebSrv;
    RecvBuffer: TBytes;
    RecvWaitTot: Integer; // current data in RecvBuffer
    RecvBufMax: Integer;  // buffer size
    HttpReqHdr: String;
    OnSimpWebSrvReq: TSimpleWebSrvReqEvent;
{ following are parsed from HTTP request header }
    RequestMethod: THttpRequest;        // HTTP request header field
    RequestContentLength: Int64;        // HTTP request header field
    RequestHost: String;                // HTTP request header field
    RequestHostName: String;            // HTTP request header field
    RequestHostPort: String;            // HTTP request header field
    RequestPath: String;                // HTTP request header field
    RequestParams: String;              // HTTP request header field
    RequestReferer: String;             // HTTP request header field
    RequestUserAgent: String;           // HTTP request header field
    procedure CliSendPage(const Status, ContentType, ExtraHdr, BodyStr: String);
    procedure CliErrorResponse(const RespStatus, Msg: string);
    procedure CliDataAvailable(Sender: TObject; Error: Word);
    procedure ParseReqHdr;
  end;

  TSimpleWebSrv = class(TIcsWndControl)
  private
    { Private declarations }
    FDebugLevel: THttpDebugLevel;
    FWebSrvIP: string;
    FWebSrvPort: string;
    FWebSrvPortSsl: string;
    FWebServer: TSslWSocketServer;
    FOnServerProg: THttpRestProgEvent;
    FOnSimpWebSrvReq: TSimpleWebSrvReqEvent;
  protected
    { Protected declarations }
    procedure LogEvent(const Msg : String);
    procedure SocketBgException(Sender: TObject;
                          E: Exception; var CanClose: Boolean);
    procedure ServerClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word); virtual;
    procedure ServerClientDisconnect(Sender: TObject;
                                 Client: TWSocketClient; Error: Word);
  public
    { Public declarations }
    constructor  Create (Aowner: TComponent); override;
    destructor   Destroy; override;
    function  StartSrv: boolean ;
    function  StopSrv: boolean ;
    function  IsRunning: Boolean;
  published
    { Published declarations }
    property DebugLevel: THttpDebugLevel            read  FDebugLevel
                                                    write FDebugLevel;
    property WebSrvIP: string                       read  FWebSrvIP
                                                    write FWebSrvIP;
    property WebSrvPort: string                     read  FWebSrvPort
                                                    write FWebSrvPort;
    property WebSrvPortSsl: string                  read  FWebSrvPortSsl
                                                    write FWebSrvPortSsl;
    property OnSimpWebSrvReq: TSimpleWebSrvReqEvent read  FOnSimpWebSrvReq
                                                    write FOnSimpWebSrvReq;
    property OnServerProg: THttpRestProgEvent       read  FOnServerProg
                                                    write FOnServerProg;

  end;

{ TRestOAuth is for handling 0Auth authorization to web apps. Beware OAuth
  does not normally allow applications to specify the actual login to the
  app, this is done via a browser web page }

  TRestOAuth = class(TIcsWndControl)
  private
    { Private declarations }
    FDebugLevel: THttpDebugLevel;
    FAccToken: string;
    FAppUrl: string;
    FAuthCode: string;
    FAuthType: TOAuthType;
    FClientId: string;
    FClientSecret: string;
    FScope: string;
    FExpireDT: TDateTime;
    FLastErrCode: Integer;
    FLastError: String;
    FLastWebTick: Longword;
    FOAOptions: TOAuthOptions;
    FProtoType: TOAuthProto;
    FRedirectMsg: string;
    FRedirectUrl: string;
    FRefreshAuto: Boolean;
    FRefreshTimer: TIcsTimer;
    FRefrMinsPrior: Integer;
    FRefreshDT: TDateTime;
    FRefreshToken: string;
    FTokenUrl: string;
    FWebSrvIP: string;
    FWebSrvPort: string;
    FWebServer: TSimpleWebSrv;
    FRedirState: string;
    FOnOAuthProg: THttpRestProgEvent;
    FOnOAuthAuthUrl: TOAuthAuthUrlEvent;
    FOnOAuthNewCode: TNotifyEvent;
    FOnOAuthNewToken: TNotifyEvent;
  protected
    { Protected declarations }
    procedure RestProg(Sender: TObject; LogOption: TLogOption; const Msg: string);
    procedure LogEvent(const Msg: String);
    procedure SetError(ErrCode: Integer; const Msg: String);
    procedure SetRefreshDT;
    procedure SetRefreshAuto(Value: Boolean);
    procedure SetRefreshToken(Value: String);
    procedure SetExpireDT(Value: TDateTime);
    procedure WebSrvReq(Sender: TObject; const Host, Path, Params: string; var RespCode, Body: string);
    function  GetToken: boolean;
    procedure RefreshOnTimer(Sender: TObject);
  public
    { Public declarations }
    HttpRest:    TSslHttpRest;
    constructor  Create (Aowner: TComponent); override;
    destructor   Destroy; override;
    function     StartSrv: boolean ;
    function     StopSrv: boolean ;
    function     SrvIsRunning: Boolean;
    function     StartAuthorization: boolean;
    function     GrantAuthToken(const Code: String = ''): boolean;
    function     GrantRefresh: boolean;
    function     GrantPasswordToken(const User, Pass: String): boolean;
    function     GrantAppToken: boolean;
    function     TestRedirect: boolean;
    property     AccToken: string                   read  FAccToken;
    property     LastErrCode: Integer               read  FLastErrCode;
    property     LastError: String                  read  FLastError;
    property     RefreshDT: TDateTime               read  FRefreshDT;
  published
    { Published declarations }
    property DebugLevel: THttpDebugLevel            read  FDebugLevel
                                                    write FDebugLevel;
    property AppUrl: string                         read  FAppUrl
                                                    write FAppUrl;
    property AuthCode: string                       read  FAuthCode
                                                    write FAuthCode;
    property AuthType: TOAuthType                   read  FAuthType
                                                    write FAuthType;
    property ClientId: string                       read  FClientId
                                                    write FClientId;
    property ClientSecret: string                   read  FClientSecret
                                                    write FClientSecret;
    property ExpireDT: TDateTime                    read  FExpireDT
                                                    write SetExpireDT;
    property OAOptions: TOAuthOptions               read  FOAOptions
                                                    write FOAOptions;
    property ProtoType: TOAuthProto                 read  FProtoType
                                                    write FProtoType;
    property RedirectMsg: string                    read  FRedirectMsg
                                                    write FRedirectMsg;
    property RedirectUrl: string                    read  FRedirectUrl
                                                    write FRedirectUrl;
    property RefreshAuto: Boolean                   read  FRefreshAuto
                                                    write SetRefreshAuto;
    property RefrMinsPrior: Integer                 read  FRefrMinsPrior
                                                    write FRefrMinsPrior;
    property RefreshToken: string                   read  FRefreshToken
                                                    write SetRefreshToken;
    property Scope: string                          read  FScope
                                                    write FScope;
    property TokenUrl: string                       read  FTokenUrl
                                                    write FTokenUrl;
    property WebSrvIP: string                       read  FWebSrvIP
                                                    write FWebSrvIP;
    property WebSrvPort: string                     read  FWebSrvPort
                                                    write FWebSrvPort;
    property OnOAuthAuthUrl: TOAuthAuthUrlEvent     read  FOnOAuthAuthUrl
                                                    write FOnOAuthAuthUrl;
    property OnOAuthProg: THttpRestProgEvent        read  FOnOAuthProg
                                                    write FOnOAuthProg;
    property OnOAuthNewCode: TNotifyEvent           read  FOnOAuthNewCode
                                                    write FOnOAuthNewCode;
    property OnOAuthNewToken: TNotifyEvent          read  FOnOAuthNewToken
                                                    write FOnOAuthNewToken;
  end;

{ Retrieve a single value by name out of an URL encoded data stream.        }
function IcsExtractURLEncodedValue(
    Msg         : PChar;            { URL Encoded stream                    }
    Name        : String;           { Variable name to look for             }
    var Value   : String;           { Where to put variable value           }
    SrcCodePage : LongWord = CP_ACP;{ D2006 and older CP_UTF8 only          }
    DetectUtf8  : Boolean  = TRUE)
    : Boolean; overload;

function IcsExtractURLEncodedValue(
    const Msg   : String;           { URL Encoded stream                     }
    Name        : String;           { Variable name to look for              }
    var Value   : String;           { Where to put variable value            }
    SrcCodePage : LongWord = CP_ACP;{ D2006 and older CP_UTF8 only          }
    DetectUtf8  : Boolean  = TRUE)
    : Boolean; overload;

function IcsShellExec(aFile: String; var PID: LongWord): Boolean; overload;
function IcsShellExec(aFile: String): Boolean; overload;


implementation


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ borrowed from OverbyteIcsHttpSrv and renamed to avoid conflicts }
{ Retrieve a single value by name out of an URL encoded data stream         }
{ In the stream, every space is replaced by a '+'. The '%' character is     }
{ an escape character. The next two are 2 digits hexadecimal codes ascii    }
{ code value. The stream is constitued by name=value couples separated      }
{ by a single '&' character. The special characters are coded by the '%'    }
{ followed by hex-ascii character code.                                     }
function IcsExtractURLEncodedValue(
    Msg         : PChar;    { URL Encoded stream                     }
    Name        : String;   { Variable name to look for              }
    var Value   : String;   { Where to put variable value            }
    SrcCodePage : LongWord; { D2006 and older CP_UTF8 only           }
    DetectUtf8  : Boolean)
    : Boolean;              { Found or not found that's the question }
var
    NameLen  : Integer;
    FoundLen : Integer; {tps}
    Ch       : AnsiChar;
    P, Q     : PChar;
    U8Str    : AnsiString;
begin
    Result  := FALSE;
    Value   := '';
    if Msg = nil then         { Empty source }
        Exit;

    NameLen := Length(Name);
    U8Str := '';
    P := Msg;
    while P^ <> #0 do begin
        Q := P;
        while (P^ <> #0) and (P^ <> '=') do
            Inc(P);
        FoundLen := P - Q; {tps}
        if P^ = '=' then
            Inc(P);
        if (StrLIComp(Q, @Name[1], NameLen) = 0) and
           (NameLen = FoundLen) then begin  {tps}
            while (P^ <> #0) and (P^ <> '&') do begin
                Ch := AnsiChar(Ord(P^)); // should contain nothing but < ord 128
                if Ch = '%' then begin
                    if P[1] <> #0 then    // V1.35 Added test
                        Ch := AnsiChar(htoi2(P + 1));
                    Inc(P, 2);
                end
                else if Ch = '+' then
                    Ch := ' ';
                U8Str := U8Str + Ch;
                Inc(P);
            end;
            Result := TRUE;
            break;
         end;
         while (P^ <> #0) and (P^ <> '&') do
             Inc(P);
        if P^ = '&' then
            Inc(P);
    end;
    if (SrcCodePage = CP_UTF8) or (DetectUtf8 and IsUtf8Valid(U8Str)) then
{$IFDEF COMPILER12_UP}
        Value := Utf8ToStringW(U8Str)
    else
        Value := AnsiToUnicode(U8Str, SrcCodePage);
{$ELSE}
        Value := Utf8ToStringA(U8Str)
    else
        Value := U8Str;
{$ENDIF}
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function IcsExtractURLEncodedValue(
    const Msg   : String;           { URL Encoded stream                    }
    Name        : String;           { Variable name to look for             }
    var Value   : String;           { Where to put variable value           }
    SrcCodePage : LongWord = CP_ACP;{ D2006 and older CP_UTF8 only          }
    DetectUtf8  : Boolean  = TRUE)
    : Boolean; overload;
begin
    Result := IcsExtractURLEncodedValue(PChar(Msg), Name, Value,
                                     SrcCodePage, DetectUtf8);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ run a program, URL or document, returning process handle }
{ beware CoInitializeEx may be needed for some sheel extensions }
function IcsShellExec(aFile: String; var PID: LongWord): Boolean;
var
    ShellInfo: TShellExecuteInfoW;
    WideFileName: WideString;
begin
    WideFileName := aFile;
    FillChar(Shellinfo, SizeOf(Shellinfo), 0);
    PID := 0;
    with ShellInfo do begin
        cbSize := SizeOf(TShellExecuteInfo);
        fmask := SEE_MASK_NOCLOSEPROCESS OR
                         SEE_MASK_FLAG_DDEWAIT OR  SEE_MASK_FLAG_NO_UI ;
        Wnd := hInstance;
        lpVerb := 'open';
        lpFile := PWideChar(WideFileName);
        nShow :=  SW_NORMAL;
    end ;
    Result := ShellExecuteExW(@shellinfo);
    if Result then PID := ShellInfo.hProcess;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ run a program, URL or document }
function IcsShellExec(aFile: String): Boolean;
var
    PID: LongWord;
begin
    Result := IcsShellExec(aFile, PID);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TRestParam }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TRestParam.Create(Collection: TCollection);
begin
    inherited;
    FPRaw := False;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestParam.GetDisplayName: string;
begin
    if FPName <> '' then
        Result := FPName + '=' + FPValue
    else
        Result := Inherited GetDisplayName
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TRestParams }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TRestParams.Create(Owner: TPersistent);
begin
  FOwner := Owner;
  inherited Create(TRestParam);
  FPContent := PContUrlencoded;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestParams.GetItem(Index: Integer): TRestParam;
begin
  Result := TRestParam(inherited GetItem(Index));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestParams.SetItem(Index: Integer; Value: TRestParam);
begin
  inherited SetItem(Index, TCollectionItem(Value));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestParams.GetOwner: TPersistent;
begin
  Result := FOwner;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestParams.IndexOf(const aName: string): Integer;
var
    I: Integer;
begin
    Result := -1;
    if Count = 0 then Exit;
    for I := 0 to Count - 1 do begin
        if Items[I].PName = aName then begin
            Result := I;
            Exit;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestParams.AddItem(const aName, aValue: string; aRaw: Boolean = False);
var
    Index: Integer;
begin
    Index := IndexOf(aName);
    if Index < 0 then begin
        Index := Count;
        Add;
    end;
    Items[Index].PName := aName;
    Items[Index].PValue := aValue;
    Items[Index].PRaw := aRaw;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestParams.GetParameters: AnsiString;
var
    I: integer;
    PN, PV: String;
//    ParamJson: ISuperObject;

    function EscapeChars(const AStr: AnsiString): AnsiString;
    var
        I, outoff, inlen: integer;
        Ch: PAnsiChar;

        procedure AddEsc(NewCh: AnsiChar);
        begin
            Result[outoff] := '\';
            Inc(outoff);
            Result[outoff] := NewCh;
        end;

    begin
        Result := '';
        outoff := 1;
        inlen := Length(AStr);
        if inlen = 0 then Exit;
        SetLength(Result, inlen * 2);
        Ch := Pointer(AStr);
        for I := 1 to inlen do begin
            if Ch^ = '\'  then
                AddEsc('\')
            else if Ch^ = '/' then
                AddEsc('/')
            else if Ch^ = '"' then
                AddEsc('"')
            else if Ch^ = IcsCR then
                AddEsc('r')
            else if Ch^ = IcsLF then
                AddEsc('n')
            else if Ch^ = IcsBACKSPACE  then
                AddEsc('b')
            else if Ch^ = IcsTab  then
                AddEsc('t')
            else
                Result[outoff] := Ch^;
            Inc(Ch);
            Inc(outoff);
        end;
        SetLength(Result, outoff - 1);
    end;


begin
    Result := '';
    if FPContent = PContUrlencoded then begin
        if Count > 0 then begin
            for I := 0 to Count - 1 do begin
                PN := Trim(Items[I].PName);
                if PN <> '' then begin
                    PV := Trim(Items[I].PValue);
                    if Result <> '' then Result := Result + '&';
                    Result := Result + AnsiString(PN) + '=';
                    if Items[I].PRaw then
                        Result := Result + StringToUtf8(PV)
                    else
                        Result := Result + UrlEncodeToA(PV, CP_UTF8);
                end;
            end;
        end;
    end
    else if FPContent = PContJson then begin
      {  ParamJson := SO();   // empty ISuperObject
        if Count > 0 then begin
            for I := 0 to Count - 1 do begin
                if Trim(Items[I].PName) <> '' then
                    ParamJson.S[Trim(Items[I].PName)] := Trim(Items[I].PValue);
            end;
        end;
        Result := AnsiString(ParamJson.AsJson(false, true));  // reorders names during conversion
     }
        Result := '{';
        if Count > 0 then begin
            for I := 0 to Count - 1 do begin
                PN := Trim(Items[I].PName);
                if PN <> '' then begin
                    PV := Trim(Items[I].PValue);
                    if Length(Result) > 1 then Result := Result + ',';
                    Result := Result + '"' + EscapeChars(AnsiString(PN)) + '":"';
                    if Items[I].PRaw then
                     // Result := Result + EscapeChars(StringToUtf8(PV))+ '"'
                       Result := Result + StringToUtf8(PV) + '"'
                    else
//                        Result := Result + EscapeChars(UrlEncodeToA(PV, CP_UTF8)) + '"';
                        Result := Result + EscapeChars(StringToUtf8(PV)) + '"';
                end;
            end;
        end;
        Result := Result + '}'
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TSslHttpRest }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TSslHttpRest.Create(Aowner:TComponent);
begin
    inherited create(AOwner);
    FRequestVer := '1.1';
    FRestParams := TRestParams.Create(self);
    FPostStream := TMemoryStream.Create;
    FResponseStream := TMemoryStream.Create;
    FMaxBodySize := DefMaxBodySize;
 // winsock bug fix for fast connections
    CtrlSocket.ComponentOptions := [wsoNoReceiveLoop];
    OnDocBegin := onHttpDocBegin;
    OnCommand := onHttpCommand;
    OnHeaderData := onHttpHeaderData;
    OnSessionConnected := onHttpSessionConnected;
    OnLocationChange := onHttpLocationChange;
    OnRequestDone := onHttpRequestDone;
    onCookie := onHttpCookie;
    Options := Options + [httpoEnableContentCoding];
    FSslSessCache := true;
    FExternalSslSessionCache := nil;
    OnSslVerifyPeer := OnHttpSslVerifyPeer;
    OnSslCliGetSession := OnHttpSslCliGetSession;
    OnSslCliNewSession := OnHttpSslCliNewSession;
    OnSslHandshakeDone := OnHttpSslHandshakeDone;
    OnSslCliCertRequest := OnHttpSslCliCertRequest;
    RestCookies := TIcsCookies.Create(self);
    RestCookies.OnNewCookie := onCookiesNewCookie;
{$IFNDEF NO_DEBUG_LOG}
    RestLogger := TIcsLogger.Create (nil);
    RestLogger.OnIcsLogEvent := IcsLogEvent;
    RestLogger.LogOptions := [loDestEvent];
    IcsLogger := RestLogger;
{$ENDIF}
    RestSslCtx := TSslContext.Create(self) ;
    SslContext := RestSslCtx;
    RestSslCtx.SslVerifyPeer := false ;
{$IFNDEF NO_DEBUG_LOG}
    RestSslCtx.IcsLogger := RestLogger;
{$ENDIF}
    FSslCliCert := TX509Base.Create(self);
    FCertVerMethod := CertVerNone;
    FSslRootFile := 'RootCaCertsBundle.pem';  // blank will use internal bundle
    FSslCliSecurity := sslCliSecTls12;
    FDebugLevel := DebugSsl;
    FRespReq := False;
    FInitSsl := false;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TSslHttpRest.Destroy;
begin
    FreeAndNil(FRestParams);
    FreeAndNil(FPostStream);
    FreeAndNil(FResponseStream);
    FreeAndNil(FMsCertChainEngine);
    FreeAndNil(FExternalSslSessionCache);
    FreeAndNil(RestSslCtx);
    FreeAndNil(FSslCliCert);
{$IFNDEF NO_DEBUG_LOG}
    FreeAndNil(RestLogger) ;
{$ENDIF}
    FreeAndNil(RestCookies);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.InitSsl;
var
    rootfname: String;
begin
    if FInitSsl then Exit;
{$IFNDEF NO_DEBUG_LOG}
    if FDebugLevel >= DebugSslLow then
        RestLogger.LogOptions := RestLogger.LogOptions + [loSslInfo, loProtSpecInfo];
{$ENDIF}

    if not Assigned (FExternalSslSessionCache) then begin
        FExternalSslSessionCache := TSslAvlSessionCache.Create (self);
 //       fExternalSslSessionCache.AdjustTimeout := True;
 //       fExternalSslSessionCache.SessionTimeOut := 30;
 //       fExternalSslSessionCache.FlushInterval := 3000;
    end;
    RestSslCtx.SslOptions2 := RestSslCtx.SslOptions2 +
       [sslOpt2_NO_SESSION_RESUMPTION_ON_RENEGOTIATION, sslOpt2_NO_RENEGOTIATION];
    RestSslCtx.SslECDHMethod := sslECDHAuto;
    RestSslCtx.SslCliSecurity := FSslCliSecurity;

  // see if verifying server SSL certificate
    if (FCertVerMethod > CertVerNone) then begin
        RestSslCtx.SslVerifyPeer := true;
        RestSslCtx.SslVerifyPeerModes := [SslVerifyMode_PEER];
        RestSslCtx.SslSessionCacheModes := [sslSESS_CACHE_CLIENT];
        if fSslSessCache then begin
            RestSslCtx.SslSessionCacheModes := [sslSESS_CACHE_CLIENT,
                sslSESS_CACHE_NO_INTERNAL_LOOKUP, sslSESS_CACHE_NO_INTERNAL_STORE] ;
        end;
        if (FCertVerMethod >= CertVerBundle) then begin
            rootfname := fSslRootFile;
            if rootfname <> '' then begin
                if (Pos (':', rootfname) = 0) then
                    rootfname := ExtractFileDir (ParamStr (0)) + '\' + rootfname ;
                if NOT FileExists (rootfname) then  begin
                    LogEvent('Can Not Find SSL CA Bundle File - ' + rootfname);
                    RestSslCtx.SslCALines.Text := sslRootCACertsBundle;
                end
                else
                   RestSslCtx.SslCAFile := rootfname;
            end
            else
                RestSslCtx.SslCALines.Text := sslRootCACertsBundle;
        end;
    end ;
    try
        if NOT RestSslCtx.IsCtxInitialized then begin
            RestSslCtx.InitContext;
            if FDebugLevel >= DebugSslLow then
                LogEvent('SSL Version: ' + OpenSslVersion + ', Dir: ' + GLIBEAY_DLL_FileName);
        end;
        FInitSsl := True;
    except
        on E:Exception do
        begin
            LogEvent('Error Starting SSL: ' + E.Message);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.SetSslCliSecurity(Value: TSslCliSecurity);
begin
    if Value = FSslCliSecurity then Exit;
    FSslCliSecurity := Value;
    RestSslCtx.SslCliSecurity := FSslCliSecurity;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.ResetSsl;
begin
    FInitSsl := False;
    if FConnected then CloseAsync;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.SetRestParams(Value: TRestParams);
begin
    FRestParams.Assign(Value);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.SetSslCliCert(Value: TX509Base);
begin
    FSslCliCert.Assign(Value);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.LogEvent(const Msg : String);
begin
    if FDebugLevel = DebugNone then Exit;
    if Assigned(FonHttpRestProg) then
        FonHttpRestProg(Self, loProtSpecInfo, Msg) ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.IcsLogEvent(Sender: TObject; LogOption: TLogOption;
                                                      const Msg : String);
begin
    if Assigned(FonHttpRestProg) then
        FonHttpRestProg(Self, LogOption, Msg) ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpSessionConnected (Sender : TObject);
begin
    if FDebugLevel < DebugConn then Exit;
    LogEvent ('Connected to: ' + IcsFmtIpv6Addr(HostName)) ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpSessionClosed(Sender : TObject);
begin
    if FDebugLevel < DebugConn then Exit;
    LogEvent ('Connection closed') ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpCommand (Sender: TObject; var S: String) ;
begin
    if FDebugLevel < DebugHdr then Exit;
    LogEvent ('> ' + S) ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpHeaderData (Sender : TObject);
begin
    if FDebugLevel < DebugHdr then Exit;
    LogEvent ('< ' + LastResponse) ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpDocBegin(Sender : TObject);
begin
    if FRespReq and (FContentLength > FMaxBodySize) then begin
        LogEvent('Aborting connection, Body Size too Large: ' + IntToKbyte(FContentLength));
        Abort;
    end;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpLocationChange(Sender : TObject);
begin
  { cookies may have been sent during redirection, so update again now }
    FCookie := RestCookies.GetCookies(FLocation);

    if FDebugLevel >= DebugConn then
        LogEvent('= ' + FURL + ' Redirected to: ' + FLocation);
    if Assigned(FOnRestLocChange) then
        FOnRestLocChange(Sender);
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpCookie(Sender : TObject; const Data : String;
    var Accept : Boolean);
begin
    RestCookies.SetCookie(Data, FURL);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onCookiesNewCookie(Sender : TObject; ACookie : TCookie;
    var Save : Boolean);
var
    S : String;
begin
    if FDebugLevel < DebugParams then Exit;

 // tell user what cookie was saved, optional
    with ACookie do begin
        S := 'NewCookie: ' + CName + '=' + CValue + ', Domain=' + CDomain + ', Path=' + CPath;
        if CPersist then
            S := S + ', Expires=' + DateTimeToStr(CExpireDT)
        else
            S := S + ', Not Persisent';
        if CSecureOnly then
            S := S + ', SecureOnly';
        if CHttpOnly then
            S := S + ', HttpOnly';
        LogEvent(S);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.OnHttpSslVerifyPeer(Sender: TObject;
                                            var Ok: Integer; Cert : TX509Base);
begin
    OK := 1; // don't check certificate until handshaking over
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.OnHttpSslCliNewSession(Sender: TObject; SslSession: Pointer;
                                    WasReused: Boolean; var IncRefCount : Boolean) ;
var
    HttpCli: TSslHttpCli;
begin
    { SslCliNewSession/SslCliGetSession allow external, client-side session }
    { caching.                                                              }
    if not fSslSessCache then Exit;
    if FDebugLevel >= DebugSslLow then
        LogEvent ('Starting SSL Session');
    if (not WasReused) then begin
        HttpCli := (Sender as TSslHttpCli);
        fExternalSslSessionCache.CacheCliSession(SslSession,
                                   HttpCli.CtrlSocket.PeerAddr + HttpCli.CtrlSocket.PeerPort, IncRefCount);
        if FDebugLevel >= DebugSslLow then
             LogEvent ('Cache SSL Session: New');
    end
    else begin
        if FDebugLevel >= DebugSslLow then
            LogEvent ('Cache SSL Session: Reuse');
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.OnHttpSslCliGetSession(Sender: TObject; var SslSession: Pointer;
                                                            var FreeSession : Boolean);
var
    HttpCli: TSslHttpCli;
begin
    { SslCliNewSession/SslCliGetSession allow external, client-side session }
    { caching.                                                              }
    if not fSslSessCache then Exit;
    if FDebugLevel >= DebugSslLow then
        LogEvent ('Check for Old SSL Session');
    HttpCli := (Sender as TSslHttpCli);
    SslSession := fExternalSslSessionCache.GetCliSession(HttpCli.CtrlSocket.PeerAddr +
                                                                    HttpCli.CtrlSocket.PeerPort, FreeSession);
    if FDebugLevel < DebugSslLow then Exit;
     if Assigned (SslSession) then
        LogEvent ('Old SSL Session Found Cached')
    else
        LogEvent ('No Old SSL Session Cached');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.OnHttpSslHandshakeDone(Sender: TObject; ErrCode: Word;
                                    PeerCert: TX509Base; var Disconnect: Boolean);
var
    CertChain: TX509List;
    ChainVerifyResult: LongWord;
    info, VerifyInfo: String;
    Safe: Boolean;
    HttpCtl: TWSocket;
begin
    HttpCtl := (Sender as TSslHttpCli).CtrlSocket ;

  // nothing much to do if SSL failed or event said disconnect
    if (ErrCode <> 0) or Disconnect then begin
        FReasonPhrase := HttpCtl.SslServerName + ' SSL Handshake Failed: ' + HttpCtl.SslHandshakeRespMsg;
        LogEvent (FReasonPhrase) ;
        exit;
    end  ;
    if FDebugLevel >= DebugSsl then
        LogEvent (HttpCtl.SslServerName + ' ' + HttpCtl.SslHandshakeRespMsg) ;
    if HttpCtl.SslSessionReused OR (FCertVerMethod = CertVerNone) then  begin
        exit; // nothing to do, go ahead
    end ;

 // Property SslCertChain contains all certificates in current verify chain
    CertChain := HttpCtl.SslCertChain;

 // see if validating against Windows certificate store
    if FCertVerMethod = CertVerNone then begin
        // start engine
        if not Assigned (FMsCertChainEngine) then
            FMsCertChainEngine := TMsCertChainEngine.Create;

      // see if checking revoocation, CRL checks and OCSP checks in Vista+, very slow!!!!
        if fSslRevocation then
            FMsCertChainEngine.VerifyOptions := [mvoRevocationCheckChainExcludeRoot]
        else
            FMsCertChainEngine.VerifyOptions := [];

        // This option doesn't seem to work, at least when a DNS lookup fails
        FMsCertChainEngine.UrlRetrievalTimeoutMsec := 10000;

        { Pass the certificate and the chain certificates to the engine      }
        FMsCertChainEngine.VerifyCert (PeerCert, CertChain, ChainVerifyResult, True);

        Safe := (ChainVerifyResult = 0) or
                { We ignore the case if a revocation status is unknown.      }
                (ChainVerifyResult = CERT_TRUST_REVOCATION_STATUS_UNKNOWN) or
                (ChainVerifyResult = CERT_TRUST_IS_OFFLINE_REVOCATION) or
                (ChainVerifyResult = CERT_TRUST_REVOCATION_STATUS_UNKNOWN or
                                     CERT_TRUST_IS_OFFLINE_REVOCATION);

       { The MsChainVerifyErrorToStr function works on chain error codes     }
        VerifyInfo := MsChainVerifyErrorToStr (ChainVerifyResult);

    // MSChain ignores host name, so see if it failed using OpenSSL
        if PeerCert.VerifyResult = X509_V_ERR_HOSTNAME_MISMATCH then begin
            Safe := False;
            VerifyInfo := PeerCert.FirstVerifyErrMsg;
        end;
    end
    else if FCertVerMethod = CertVerBundle then begin
        VerifyInfo := PeerCert.FirstVerifyErrMsg;
        Safe := (PeerCert.VerifyResult = X509_V_OK);   { check whether SSL chain verify result was OK }
    end
    else begin
        exit ;  // unknown method
    end ;

  // tell user verification failed
    if NOT Safe then begin
        info := 'SSL Chain Verification Failed: ' + VerifyInfo + ', Domain: ';
        if PeerCert.SubAltNameDNS = '' then
            info := info + IcsUnwrapNames (PeerCert.SubjectCName)
        else
            info := info + IcsUnwrapNames (PeerCert.SubAltNameDNS) ;
        info := info + ', Expected: ' + HttpCtl.SslServerName ;
        if FDebugLevel >= DebugSsl then
            LogEvent (info);
        FReasonPhrase := info;  { V8.58 }
    end
    else begin
        if FDebugLevel >= DebugSsl then
           LogEvent (HttpCtl.SslServerName + ' SSL Chain Verification Succeeded') ;
    end;

// if certificate checking failed, see if the host is specifically listed as being allowed anyway
    if (NOT Safe) and (SslAcceptableHosts.IndexOf (HttpCtl.SslServerName) > -1) then begin
        Safe := true ;
        if FDebugLevel >= DebugSsl then
            LogEvent (HttpCtl.SslServerName + ' SSL Succeeded with Acceptable Host Name') ;
    end ;

  // tell user about all the certificates we found
    if (FDebugLevel >= DebugSsl) and fSslReportChain and (CertChain.Count > 0) then  begin
        info := HttpCtl.SslServerName + ' ' + IntToStr (CertChain.Count) +
                ' SSL Certificates in the verify chain:' + #13#10 +
                    CertChain.AllCertInfo (true, true) + #13#10 ; // Mar 2017 report all certs, backwards
        if FDebugLevel >= DebugSsl then
            LogEvent (info);
    end;

  // all failed
    if NOT Safe then begin
        Disconnect := TRUE;
        exit ;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.OnHttpSslCliCertRequest(Sender: TObject; var Cert: TX509Base);
begin
    if FSslCliCert.IsCertLoaded then begin
        Cert := FSslCliCert;
        if FDebugLevel >= DebugSsl then
            LogEvent('Client SSL Certificate Sent') ;
    end
    else
        LogEvent('No Client SSL Certificate to Send') ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslHttpRest.GetParams(HttpRequest: THttpRequest): AnsiString;
begin
    Result := '';
    if (FRestParams.Count > 0) then begin
        if HttpRequest in [httpGET, httpPut, httpHead, httpDelete] then begin
            if (FRestParams.PContent = PContJson) then  // must flatten Json for GET
                Result:= IcsBase64UrlEncodeA(FRestParams.GetParameters)
            else
                Result := FRestParams.GetParameters;
        end
        else if HttpRequest = httpPOST then begin
            Result := FRestParams.GetParameters;
            if (FRestParams.PContent = PContJson) then
                FContentPost := 'application/json'
            else
                FContentPost := 'application/x-www-form-urlencoded';
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslHttpRest.GetResponseJson: ISuperObject;
begin
    if NOT Assigned(FResponseJson) and (FResponseRaw <> '') then begin
        try
            FResponseJson := TSuperObject.ParseString(PWideChar(FResponseRaw), True);
        except
        end;
    end;
    if NOT Assigned (FResponseJson) then       { V8.55 }
        LogEvent('Failed to parse Json response');
    Result := FResponseJson;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSslHttpRest.GetResponseOctet: AnsiString;
begin
    Result := '';
    if FResponseSize = 0 then Exit;
    FResponseStream.Seek (0, soFromBeginning) ;
    SetLength (Result, FResponseSize);
    FResponseStream.Read(Result[1], FResponseSize);
    FResponseStream.Seek (0, soFromBeginning) ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.onHttpRequestDone(Sender : TObject; RqType : THttpRequest; ErrCode : Word);
var
    Info: String;
begin
    Info := FReasonPhrase;
    if FStatusCode > 0 then Info := IntToStr(FStatusCode) + ' ' + Info;
    if ErrCode <> 0 then begin   // ReasonPhrase has description of ErrCode
        LogEvent('Request failed: ' + Info) ;
        FRespReq := False;
    end
    else begin  { V8.58 }
        LogEvent('Request completed: ' + Info);
        try
            if FRespReq then begin  // only process response for REST request
                FRespReq := False;
                FResponseSize := FResponseStream.Size;

                if FResponseSize <> 0 then begin
                    FResponseStream.Seek (0, soFromBeginning) ;

                  // convert response to correct codepage, including entities
                    if (Pos ('text/', FContentType) = 1) or
                           (Pos ('json', FContentType) <> 0) or
                             (Pos ('xml', FContentType) <> 0) then begin
                        FResponseRaw := IcsHtmlToStr(FResponseStream, FContentType, true);
                        FResponseStream.Seek (0, soFromBeginning) ;
                        if DebugLevel >= DebugBody then
                            LogEvent('Response (length ' + IntToKbyte(Length(FResponseRaw)) +
                                                                  ')' + IcsCRLF +  FResponseRaw);
                    end
                    else if DebugLevel >= DebugBody then
                            LogEvent('Response Non-Textual (length ' + IntToKbyte(FResponseSize));
                end;
            end;
        except
            on E:Exception do
            begin
                LogEvent('Failed to process response: ' + E.Message);
            end;
        end;
    end;
    if Assigned (FOnRestRequestDone) then
        FOnRestRequestDone(Sender, RqType, ErrCode);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSslHttpRest.ClearResp;
begin
    FPostStream.Clear;
    FResponseStream.Clear;
    FResponseJson := Nil;
    FResponseRaw := '';
    FResponseSize := 0;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ make an HTTP request to RestURL.  If RestURL has no parameters (ie ?, except
  POST)) then RawParams are added if not blank, otherwise RestParams are added }

function TSslHttpRest.RestRequest(HttpRequest: THttpRequest; const RestURL: String;
                      AsyncReq: Boolean = False; const RawParams: String = ''): Integer;
var
    Info: String;
    Params: AnsiString;
//    I: Integer;
begin
    result := -1;
    FReasonPhrase := '';
    ClearResp;
    if (Pos('http', RestURL) <> 1) then begin
        FReasonPhrase := 'Need valid URL: ' + RestURL;
        LogEvent (FReasonPhrase) ;
        Exit;
    end;
    if (FState <> httpReady) then begin
        FReasonPhrase := 'Component is not ready, doing last request';
        LogEvent (FReasonPhrase) ;
        Exit;
    end;
    FRespReq := True;
    InitSsl;
    FSendStream := FPostStream;
    FRcvdStream := FResponseStream;
    FResponseNoException := True;  // stop exception for sync requests
    try
        FURL := RestURL;
        FCookie := RestCookies.GetCookies (RestURL);
        Params := StringToUtf8(RawParams);
        if (Params = '') then Params := GetParams(HttpRequest);
        if  (Params <> '') and (HttpRequest in
                 [httpGET, httpPUT, httpHEAD, httpDELETE, httpPATCH]) then begin
            if (Pos('?', FURL) = 0) then
                FURL := RestURL + '?' + String(Params);
        end
        else if HttpRequest = httpPOST then begin
            if (Params <> '') then begin
                if (Params[1] = '{') and (RawParams = '') then
                    FContentPost := 'application/json';
                FPostStream.Write(Params[1], Length(Params));
                FPostStream.Seek(0, soFromBeginning) ;
            end
        end;
        if HttpRequest = httpGET then Info := 'GET '
        else if HttpRequest = httpHEAD then Info := 'HEAD '
        else if HttpRequest = httpPOST then Info := 'POST '
        else if HttpRequest = httpPUT then Info := 'PUT '
        else if HttpRequest = httpDELETE then Info := 'DELETE '
        else if HttpRequest = httpPATCH then Info := 'PATCH ';
        Info := Info + RestURL;
        if (FDebugLevel >= DebugParams) and (Params <> '') then
            Info := Info + IcsCRLF + String(Params);
        LogEvent(Info);
        FStatusCode := 0;
        if AsyncReq then
            DoRequestASync(HttpRequest)
        else
            DoRequestSync(HttpRequest);
        Result := FStatusCode;  // only for sync requests
    except
        on E:Exception do begin    { 400/500 no longer come here }
            if FRespReq then  { may have reported in Done }
                LogEvent('Request failed: ' + E.Message);
            Result := FStatusCode;
            if Result = 200 then Result := 0; // not really successful
            FRespReq := False;
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{  TSimpleWebSrv }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TSimpleWebSrv.Create (Aowner: TComponent);
begin
    inherited Create(AOwner);
    FWebServer := TSslWSocketServer.Create(Self);
    FWebServer.SslEnable := false;
    FWebServer.MaxClients := 10;
    FWebServer.Banner := '';
    FWebServer.BannerTooBusy := '';
    FWebServer.ClientClass := TSimpleClientSocket;
    FWebServer.OnClientConnect := ServerClientConnect;
    FWebServer.OnClientDisconnect := ServerClientDisconnect;
    FWebServer.OnBgException := SocketBgException ;
    FWebServer.SocketErrs := wsErrFriendly ;
    FWebSrvIP := '127.0.0.1';
    FWebSrvPort := '8080';
    FWebSrvPortSsl := '0';
    FDebugLevel := DebugConn;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TSimpleWebSrv.Destroy;
begin
    FreeAndNil(FWebServer);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSimpleWebSrv.StartSrv: boolean ;
begin
    Result := False;
    try
        FWebServer.Addr := FWebSrvIP;
        FWebServer.Port := FWebSrvPort ;
        if FWebSrvPortSsl <> '0' then begin
    //    x
        end;
        FWebServer.ExclusiveAddr := true ;
        FWebServer.Listen ;      // start listening for incoming connections
        Result := IsRunning;
    except
        on E:Exception do begin
            LogEvent('Web Server failed to start: ' + E.Message);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSimpleWebSrv.StopSrv: boolean ;
var
    I: integer;
begin
    try
        if FWebServer.State <> wsClosed then FWebServer.Close ;
        if FWebServer.ClientCount > 0 then begin
            for I := 0 to Pred (FWebServer.ClientCount) do begin
                if FWebServer.Client [I].State = wsConnected then
                                          FWebServer.Client [I].Close ;
            end ;
        end ;
    except
        on E:Exception do begin
            LogEvent('Web Server failed to stop: ' + E.Message);
        end;
    end;
    Result := IsRunning;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleWebSrv.LogEvent(const Msg : String);
begin
    if FDebugLevel = DebugNone then Exit;
    if Assigned(FOnServerProg) then
        FOnServerProg(Self, loProtSpecErr, Msg) ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TSimpleWebSrv.IsRunning: Boolean;
begin
    Result := (FWebServer.State = wsListening);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleWebSrv.SocketBgException(Sender: TObject;
                          E: Exception; var CanClose: Boolean);
begin
    LogEvent ('Web Server Exception: ' + E.Message) ;
    CanClose := true ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleWebSrv.ServerClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word);
var
    Cli: TSimpleClientSocket;
begin
    if Error <> 0 then begin
        LogEvent('Server listen connect error: ' + WSocketErrorDesc(Error));
        Client.Close;
        exit;
    end;
    if FDebugLevel >= DebugConn then
        LogEvent('Client Connected from Address ' + IcsFmtIpv6Addr(Client.GetPeerAddr));
    Cli := Client as TSimpleClientSocket;
    Cli.WebSrv := Self;
    Cli.LineMode := false;
    Cli.OnDataAvailable := Cli.CliDataAvailable;
    Cli.OnBgException := SocketBgException;
    Cli.OnSimpWebSrvReq := Self.FOnSimpWebSrvReq;
    Cli.Banner := '' ;
    Cli.RecvBufMax := 8096;  // only expecting a request header
    SetLength(Cli.RecvBuffer, Cli.RecvBufMax + 1);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleWebSrv.ServerClientDisconnect(Sender: TObject;
                                 Client: TWSocketClient; Error: Word);
begin
    if FDebugLevel >= DebugConn then
        LogEvent('Client Disconnected') ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ send local web page }
procedure TSimpleClientSocket.CliSendPage(const Status, ContentType, ExtraHdr, BodyStr: String);
var
    HttpRespHdr: string;
begin
  { create response header }
    HttpRespHdr := 'HTTP/1.0 ' + Status + IcsCRLF +
       'Content-Length: ' + IntToStr(Length(BodyStr)) + IcsCRLF +
       'Connection: close' + IcsCRLF;
    if (ContentType <> '') and (BodyStr <> '') then
        HttpRespHdr := HttpRespHdr + 'Content-Type: ' + ContentType + IcsCRLF;
    if ExtraHdr <> '' then
        HttpRespHdr := HttpRespHdr + ExtraHdr + IcsCRLF;
    HttpRespHdr := HttpRespHdr + IcsCRLF;

  { send header and body }
    if WebSrv.DebugLevel >= DebugHdr then
        WebSrv.LogEvent('Web Server Response:' + IcsCRLF + HttpRespHdr + BodyStr);
    SendStr(HttpRespHdr + BodyStr);
    CloseDelayed;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ create and send response error page }
procedure TSimpleClientSocket.CliErrorResponse(const RespStatus, Msg: string);
var
    BodyStr: string;
begin
    BodyStr := '<HTML><HEAD><TITLE>' + RespStatus + '</TITLE></HEAD>' + IcsCRLF +
            '<BODY>' + IcsCRLF +
            '<H1>' + RespStatus + '</H1>' + Msg + '<P>' + IcsCRLF +
            '</BODY></HTML>' + IcsCRLF;
    CliSendPage(RespStatus, 'text/html', '', BodyStr);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ note based on version from OverbyteIcsProxy but cut down to bare minimum }
procedure TSimpleClientSocket.ParseReqHdr;
var
    Line, Arg: String;
    I, J, K, L, Lines: Integer;
begin
    RequestMethod := httpABORT;
    RequestContentLength := 0;
    RequestHost := '';
    RequestHostName := '';
    RequestHostPort := '';
    RequestPath := '/';
    RequestParams := '';
    RequestReferer := '';
    RequestUserAgent := '';

 { process one line in header at a time }
    if Length(HttpReqHdr) <= 4 then Exit;  // sanity check
    I := 1; // start of line
    Lines := 1;
    for J := 1 to Length(HttpReqHdr) - 2 do begin
        if (HttpReqHdr[J] = IcsCR) and (HttpReqHdr[J + 1] = IcsLF) then begin  // end of line
            if (J - I) <= 2 then continue;  // ignore blank line, usually at start
            Line := Copy(HttpReqHdr, I, J - I);
            K := Pos (':', Line) + 1;
            if Lines = 1 then begin
                if (Pos('GET ', Line) = 1) then RequestMethod := httpGet;
                if (Pos('POST ', Line) = 1) then RequestMethod := httpPost;
                if (Pos('HEAD ', Line) = 1) then RequestMethod := httpHead;
                if (Pos('PUT ', Line) = 1) then RequestMethod := httpPut;
                L := Pos(' ', Line);
                if (L > 0) then Line := Copy(Line, L + 1, 99999); // strip request
                L := Pos(' HTTP/1', Line);
                if (L > 0) then begin
                    RequestPath := Copy(Line, 1, L - 1);
                    L := Pos('?', RequestPath);
                    if (L > 0) then begin
                        RequestParams := Copy(RequestPath, L + 1, 99999);
                        RequestPath := Copy(RequestPath, 1, L - 1);
                    end;
                end;
            end
            else if (K > 3) then begin
                Arg := IcsTrim(Copy(Line, K, 999)); // convert any arguments we scan to lower case later
                if (Pos('Content-Length:', Line) = 1) then RequestContentLength := atoi64(Arg);
                if (Pos('Host:', Line) = 1) then begin
                    RequestHost := Arg;
                    L := Pos(':', RequestHost);
                    if L > 0 then begin
                        RequestHostName := Copy(RequestHost, 1, L - 1);
                        RequestHostPort := Copy(RequestHost, L + 1, 99);
                    end
                    else begin
                        RequestHostName := RequestHost;
                        RequestHostPort := WebSrv.FWebSrvPort;
                    end;
                end;
                if (Pos('Referer:', Line) = 1) then RequestReferer := IcsLowercase(Arg);
                if (Pos('User-Agent:', Line) = 1) then RequestUserAgent := Arg;
            end;
            Lines := Lines + 1;
            I := J + 2;  // start of next line
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleClientSocket.CliDataAvailable(Sender: TObject; Error: Word);
var
    RxRead, RxCount, LoopCounter, HdrLen: Integer;
    RespCode, Body: string;
begin
    try
        LoopCounter := 0;
        if RecvWaitTot < 0 then RecvWaitTot := 0; // sanity check
        while TRUE do begin
            inc (LoopCounter);
            if (LoopCounter > 100) then Break;    // sanity check
            RxCount := RecvBufMax - RecvWaitTot - 1;
            if RxCount <= 0 then Break;           // sanity check
            RxRead := Self.Receive (@RecvBuffer[RecvWaitTot], RxCount);
            if RxRead <= 0 then Break;            // nothing read
            RecvWaitTot := RecvWaitTot + RxRead;
        end;

      { search for blank line in receive buffer which means we have complete request header }
        HdrLen := IcsTBytesPos(IcsDoubleCRLF, RecvBuffer, 0, RecvWaitTot);
        if (HdrLen <= 0) then begin
            if (WebSrv.DebugLevel >= DebugBody) then
                WebSrv.LogEvent('Waiting for more source data');
            Exit;
        end ;
        HdrLen := HdrLen + 4; // add blank line length

      { keep headers in string so they are easier to process  }
      { ignore any body, don't care about POST requests }
        SetLength(HttpReqHdr, HdrLen);
        IcsMoveTBytesToString(RecvBuffer, 0, HttpReqHdr, 1, HdrLen);

       { see what was sent }
        ParseReqHdr;

       { ask user what we should do next }
        if (RequestMethod = httpGET) and Assigned(OnSimpWebSrvReq) then begin
            RespCode := '';
            OnSimpWebSrvReq(Self, RequestHost, RequestPath, RequestParams, RespCode, Body);
            if RespCode <> '' then
                CliSendPage(RespCode, 'text/html', '', Body)
            else
                CliErrorResponse('500 Server Error', 'The requested URL ' +
                   TextToHtmlText(RequestPath) + ' was not processed by the server.');
        end
        else
            CliErrorResponse('404 Not Found', 'The requested URL ' +
            TextToHtmlText(RequestPath) + ' was not found on this server.');
    except
         on E:Exception do
            WebSrv.LogEvent('Error Receive Data: ' + E.Message);
    end ;
end ;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ TRestOAuth }
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor TRestOAuth.Create (Aowner: TComponent);
begin
    inherited Create(AOwner);
    FWebServer := TSimpleWebSrv.Create(self);
    FWebServer.OnServerProg := RestProg;
    FWebServer.OnSimpWebSrvReq := WebSrvReq;
    HttpRest := TSslHttpRest.Create(self);
    HttpRest.OnHttpRestProg := RestProg;
    FWebSrvIP := '127.0.0.1';
    FWebSrvPort := '8080';
    FDebugLevel := DebugConn;
    FProtoType := OAuthv2;
    FAuthType := OAuthTypeWeb;
    FRefrMinsPrior := 120;
    FRefreshDT := 0;
    FScope := '';
    FLastWebTick := TriggerDisabled;
    FRefreshTimer := TIcsTimer.Create(HttpRest);
    FRefreshTimer.OnTimer := RefreshOnTimer;
    FRefreshTimer.Interval := TicksPerMinute;
    FRefreshTimer.Enabled := True;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor TRestOAuth.Destroy;
begin
    FRefreshTimer.Enabled := False;
    StopSrv;
    FreeAndNil(FRefreshTimer);
    FreeAndNil(HttpRest);
    FreeAndNil(FWebServer);
    inherited Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.RestProg(Sender: TObject; LogOption: TLogOption; const Msg: string);
begin
    if Assigned(FOnOAuthProg) then
        FOnOAuthProg(Self, LogOption, Msg) ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.LogEvent(const Msg : String);
begin
    if FDebugLevel = DebugNone then Exit;
    if Assigned(FOnOAuthProg) then
        FOnOAuthProg(Self, loProtSpecInfo, Msg) ;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.SetError(ErrCode: Integer; const Msg: String);
begin
    FLastErrCode := ErrCode;
    FLastError := Msg;
    LogEvent(Msg);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.SetRefreshDT;
begin
    FRefreshDT := 0;
    if FRefreshToken = '' then Exit;
    if (FExpireDT < 10) then Exit;
    if (FRefrMinsPrior < 10) then FRefrMinsPrior := 10;
    FRefreshDT := FExpireDT - ((FRefrMinsPrior * 60) / SecsPerDay);
    if FRefreshAuto then
        LogEvent('Token will Automatically Refresh at: ' + DateTimeToStr(FRefreshDT));
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.SetExpireDT(Value: TDateTime);
begin
    if Value <> FExpireDT then begin
        FExpireDT := Value;
        SetRefreshDT;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.SetRefreshAuto(Value: Boolean);
begin
    if Value <> FRefreshAuto then begin
        FRefreshAuto:= Value;
        SetRefreshDT;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.SetRefreshToken(Value: String);
begin
    if Value <> FRefreshToken then begin
        FRefreshToken := Value;
        SetRefreshDT;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.StartSrv: boolean ;
begin
    FWebServer.DebugLevel := Self.FDebugLevel;
    FWebServer.WebSrvIP := Self.FWebSrvIP;
    FWebServer.WebSrvPort := Self.FWebSrvPort;
    Result := FWebServer.StartSrv;
    if Result then
        LogEvent('Local Web Server Started on: ' + IcsFmtIpv6AddrPort(FWebSrvIP, FWebSrvPort))
    else
        LogEvent('Local Web Server Failed to Start');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.StopSrv: boolean ;
begin
    FLastWebTick := TriggerDisabled;
    Result := FWebServer.StopSrv;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.SrvIsRunning: Boolean;
begin
    Result := FWebServer.IsRunning;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TRestOAuth.RefreshOnTimer(Sender : TObject);
begin
    FRefreshTimer.Enabled := False;
    try
     // auto refresh token
        if FRefreshAuto and (FRefreshToken <> '') and (FRefreshDT <> 0) then begin
            if Now > FRefreshDT then begin
                FRefreshDT := 0;
                LogEvent('Starting Automatic Token Refresh');
                if NOT GrantRefresh then begin
                    LogEvent('Automatic Token Refresh Failed: ' + FLastError);
                end;
            end;
        end;

     // close web server
        if SrvIsRunning and (IcsElapsedSecs(FLastWebTick) > 120) then begin
            FLastWebTick := TriggerDisabled;
            LogEvent('Local Web Server Stopping on Idle Timeout');
            StopSrv;
        end;
    finally
        FRefreshTimer.Enabled := True;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ event called by simple web server when any page is requested }
procedure TRestOAuth.WebSrvReq(Sender: TObject; const Host, Path,
                                Params: string; var RespCode, Body: string);
var
    State, Code, Title, Msg, Error, Redirect: String;
//    Client: TSimpleClientSocket;

    procedure BuildBody;
    begin
        Body := '<HTML><HEAD><TITLE>' + Title + '</TITLE></HEAD>' + IcsCRLF +
            '<BODY>' + IcsCRLF +
            '<H1>' + Title + '</H1>' + Msg + '<P>' + IcsCRLF +
            '</BODY></HTML>' + IcsCRLF;
        LogEvent('Web Response: ' + RespCode);
    end;

begin
//    Client := Sender as TSimpleClientSocket;

 // ignore favicon requests completely
    if Path = '/favicon.ico' then begin
        RespCode := '404 Not Found';
        Title := RespCode;
        Msg := 'Error: File Not Found';
        BuildBody;
        Exit;
    end;

    FLastWebTick := IcsGetTickCountX;   // timeout to close server
    LogEvent('Web Server Request, Host: ' + Host + ', Path: ' + Path + ', Params: ' + Params);
    Redirect := 'http://' + Host + Path;
    if Redirect <> FRedirectUrl then
        LogEvent('Warning, Differing Redirect URL: ' + Redirect);

  // for an OAuth authentication redirect, we don't really care about the path
    IcsExtractURLEncodedValue (Params, 'state', State) ;
    IcsExtractURLEncodedValue (Params, 'code', Code) ;
    IcsExtractURLEncodedValue (Params, 'error', Error) ;

    if (Error <> '') then begin
        RespCode := '501 Internal Error';
        Title := 'OAuth Authorization Failed';
        Msg := 'Error: ' + Error;
        BuildBody;
        Exit;
    end;

    if (NOT (OAopAuthNoState in FOAOptions)) and
            (State = '') or (State <> FRedirState)  then begin
        RespCode := '501 Internal Error';
        Title := RespCode;
        Msg := 'Error: Unexpected State';
        BuildBody;
        Exit;
    end;

    if (Code = '') then begin
        RespCode := '501 Internal Error';
        Title := RespCode;
        Msg := 'Error: Can not find Authorization Code';
        BuildBody;
        Exit;
    end;

 // if not testing, save new code. try and get token
    RespCode := '200 OK';
    Title := 'Authorization Code Generated Successfully';
    Msg := '<p><b>App Authorization Code: ' + Code + '</b></p>' + IcsCRLF +
            '<b>' + FRedirectMsg + '</b></p>';
    if FRedirState <> TestState then begin
        FAuthCode := Code;
        if Assigned(FOnOAuthNewCode) then
            FOnOAuthNewCode(Self);
        if GrantAuthToken(Code) then begin
            Title := 'App Token Generated Successfully';
            Msg := '<p><b>App Token Generated Successfully</b></p>' + IcsCRLF +
            '<b>' + FRedirectMsg + '</b></p>';
        end
        else
            Title := 'Failed to Generate App Token';
    end;
    BuildBody;
  { web page is sent by event handler }
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.TestRedirect: boolean;
var
    StatCode: Integer;
begin
    Result := false;
    FLastErrCode := OAuthErrNoError;
    FLastError := '';
    if NOT SrvIsRunning then
        StartSrv;
    if NOT SrvIsRunning then begin
        SetError(OAuthErrWebSrv, 'Can Not Test Redirect, Web Server Will Not Start');
        Exit;
    end;
    if Pos ('http://', FRedirectUrl) <> 1 then begin
        SetError(OAuthErrParams, 'Can Not Test Redirect, Invalid Redirect URL');
        Exit;
    end;
    FRedirState := TestState;
    HttpRest.Reference := FRedirectUrl;
    HttpRest.DebugLevel := FDebugLevel;
    HttpRest.RestParams.Clear;
    HttpRest.RestParams.AddItem('state', FRedirState, False);
    HttpRest.RestParams.AddItem('code', '12345678901234567890', True);
    StatCode := HttpRest.RestRequest(HttpGET, FRedirectUrl, False, '');
    if StatCode <> 200 then
        SetError(OAuthErrWebSrv, 'Test Redirect Failed')
     else begin
        LogEvent('Test Redirect OK');
        Result := true;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.StartAuthorization: boolean;
var
    BrowserURL: String;
    MyParams: TRestParams;
begin
    Result := false;
    FLastErrCode := OAuthErrNoError;
    FLastError := '';
    if Pos ('http://', FRedirectUrl) <> 1 then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Invalid Redirect URL: ' + FRedirectUrl);
        Exit;
    end;
    if Pos ('https://', FAppUrl) <> 1 then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Invalid App URL: ' + FAppUrl);
        Exit;
    end;
    if (FClientId = '') or (FClientSecret = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Need Client ID and Secret');
        Exit;
    end;
    FRedirState := 'ICS-' + IntToStr(GetTickCount);
    MyParams := TRestParams.Create(self);
    try
        MyParams.PContent := PContUrlencoded;
        MyParams.AddItem('response_type', 'code', True);
        MyParams.AddItem('client_id', FClientId, True);
        if NOT (OAopAuthNoRedir in FOAOptions) then
            MyParams.AddItem('redirect_uri', FRedirectUrl, False);
        if NOT (OAopAuthNoState in FOAOptions) then
            MyParams.AddItem('state', FRedirState, False);
        if (NOT (OAopAuthNoScope in FOAOptions)) and (FScope <> '') then
            MyParams.AddItem('scope', FScope, False);
        BrowserURL := FAppUrl + '?' + String(MyParams.GetParameters);
    finally
        MyParams.Free;
    end;
    LogEvent('Authorization URL: ' + BrowserURL);

  { various schemes to get authorization code from browser }
  { V8.57 need local web server for all methods }
    if (FAuthType = OAuthTypeWeb) or (FAuthType = OAuthTypeMan) or
                                        (FAuthType = OAuthTypeEmbed) then begin
        if NOT SrvIsRunning then
            StartSrv;
        if NOT SrvIsRunning then begin
            SetError(OAuthErrWebSrv, 'Can Not Start Authorization, Web Server Will Not Start');
            Exit;
        end;
    end;
    if FAuthType = OAuthTypeWeb then begin
        if IcsShellExec(BrowserURL) then begin
            LogEvent('Launched Browser to Login to application, once completeted you should see "App Token Generated Successfully"');
            Result := True;
        end
        else begin
            SetError(OAuthErrBrowser, 'Failed to Launch Browser: ' + GetWindowsErr(GetLastError));
        end;
    end
    else if (FAuthType = OAuthTypeMan) or (FAuthType = OAuthTypeEmbed) then begin
        if Assigned (OnOAuthAuthUrl) then begin
            OnOAuthAuthUrl(Self, BrowserURL);
        end;
    end
    else
        SetError(OAuthErrParams, 'Can Not Start Authorization, Unknown Method');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.GetToken: boolean;
var
    StatCode, secs: Integer;
    Info: string;
begin
    Result := false;
    StatCode := HttpRest.RestRequest(HttpPOST, FTokenUrl, False, '');
    if (StatCode = 0) or (NOT Assigned(HttpRest.ResponseJson)) then  { V8.55 }
        SetError(OAuthErrBadGrant, 'Token Exchange Failed: ' + HttpRest.LastResponse)
     else begin
        FAccToken := HttpRest.ResponseJson.S['access_token'];
        if FAccToken <> '' then begin
            Result := true;
            FRefreshToken := HttpRest.ResponseJson.S['refresh_token'];
            secs := HttpRest.ResponseJson.I['expires_in'];
            FExpireDT := Now + (secs / SecsPerDay);
            FRefreshDT := 0;
            LogEvent('Got New Access Token: ' + FAccToken + ', Which Expires: ' +
                                                           DateTimeToStr(FExpireDT));
            if FRefreshToken = '' then
                LogEvent('No Refresh Available')
            else begin
               LogEvent('Which Can Be Refreshed With: ' + FRefreshToken);
               if FRefreshAuto and (FRefrMinsPrior > 30) and (secs > 300) then begin
                    if (secs > (FRefrMinsPrior * 60)) then
                        FRefreshDT := FExpireDT - ((FRefrMinsPrior * 60) / SecsPerDay)
                    else
                        FRefreshDT := FExpireDT - (300 / SecsPerDay); // five minutes
                    LogEvent('Token will Automatically Refresh at: ' + DateTimeToStr(FRefreshDT));
                end;
            end ;
            if Assigned(FOnOAuthNewToken) then
                FOnOAuthNewToken(Self);
        end
        else begin
            Info := HttpRest.ResponseJson.S['error'];
            if Info <> '' then
                Info := 'Token Exchange Failed: ' + Info + ' - ' +
                                  HttpRest.ResponseJson.S['error_description']
            else
                Info := 'Token Exchange Failed: REST error: ' + HttpRest.ReasonPhrase;
            SetError(OAuthErrBadGrant, Info);
            LogEvent(HttpRest.ResponseRaw);
        end;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.GrantAuthToken(const Code: String = ''): boolean;
begin
    if Code <> '' then FAuthCode := Code;
    Result := false;
    FLastErrCode := OAuthErrNoError;
    FLastError := '';
    if Pos ('http://', FRedirectUrl) <> 1 then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Invalid Redirect URL');
        Exit;
    end;
    if Pos ('https://', FTokenUrl) <> 1 then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Invalid Token URL');
        Exit;
    end;
    if (FAuthCode = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Missing Auth Code');
        Exit;
    end;
    if (FClientId = '') or (FClientSecret = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Need Client ID and Secret');
        Exit;
    end;
    HttpRest.RestParams.Clear;
    HttpRest.RestParams.PContent := PContUrlencoded;
    HttpRest.RestParams.AddItem('grant_type', 'authorization_code', true);
    HttpRest.RestParams.AddItem('code', FAuthCode, true);
    HttpRest.RestParams.AddItem('redirect_uri', FRedirectUrl, False);
    HttpRest.RestParams.AddItem('client_id', FClientId, True);
    HttpRest.RestParams.AddItem('client_secret', FClientSecret, true);
    Result := GetToken;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.GrantRefresh: boolean;
begin
    Result := false;
    if (FRefreshToken = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Missing Refresh Token');
        Exit;
    end;
    if (FClientId = '') or (FClientSecret = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Need Client ID and Secret');
        Exit;
    end;
    HttpRest.RestParams.Clear;
    HttpRest.RestParams.PContent := PContUrlencoded;
    HttpRest.RestParams.AddItem('grant_type', 'refresh_token', true);
    HttpRest.RestParams.AddItem('refresh_token', FRefreshToken, true);
    HttpRest.RestParams.AddItem('redirect_uri', FRedirectUrl, False);
    HttpRest.RestParams.AddItem('client_id', FClientId, True);
    HttpRest.RestParams.AddItem('client_secret', FClientSecret, true);
    Result := GetToken;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.GrantPasswordToken(const User, Pass: String): boolean;
begin
    Result := false;
    if (User = '') or (Pass = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Missing Username or Password');
        Exit;
    end;
    if (FClientId = '') or (FClientSecret = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Need Client ID and Secret');
        Exit;
    end;
    HttpRest.RestParams.Clear;
    HttpRest.RestParams.PContent := PContUrlencoded;
    HttpRest.RestParams.AddItem('grant_type', 'password', true);
    HttpRest.RestParams.AddItem('username', User, true);
    HttpRest.RestParams.AddItem('password', Pass, False);
    HttpRest.RestParams.AddItem('client_id', FClientId, True);
    HttpRest.RestParams.AddItem('client_secret', FClientSecret, true);
    if (NOT (OAopAuthNoScope in FOAOptions)) and (FScope <> '') then
        HttpRest.RestParams.AddItem('scope', FScope, False);
    Result := GetToken;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TRestOAuth.GrantAppToken: boolean;
begin
    Result := false;
    if (FClientId = '') or (FClientSecret = '') then begin
        SetError(OAuthErrParams, 'Can Not Start Authorization, Need Client ID and Secret');
        Exit;
    end;
    HttpRest.RestParams.Clear;
    HttpRest.RestParams.PContent := PContUrlencoded;
    HttpRest.RestParams.AddItem('grant_type', 'client_credentials', true);
    HttpRest.RestParams.AddItem('client_id', FClientId, True);
    HttpRest.RestParams.AddItem('client_secret', FClientSecret, true);
    if (NOT (OAopAuthNoScope in FOAOptions)) and (FScope <> '') then
        HttpRest.RestParams.AddItem('scope', FScope, False);
    Result := GetToken;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

{$ENDIF USE_SSL}

end.
