* Webrouter unit

packages/rtl/pas2js_rtl.lpk

@@ -32,7 +32,7 @@
     <Description Value="pas2js RTL - Run Time Library"/>
     <License Value="Modified LGPL2 as the FPC packages."/>
     <Version Major="1"/>
-    <Files Count="18">
+    <Files Count="19">
       <Item1>
         <HasRegisterProc Value="True"/>
       </Item1>
@@ -105,6 +105,10 @@
         <Filename Value="browserconsole.pas"/>
         <UnitName Value="browserconsole"/>
       </Item18>
+      <Item19>
+        <Filename Value="webrouter.pp"/>
+        <UnitName Value="webrouter"/>
+      </Item19>
     </Files>
     <UsageOptions>
       <CustomOptions Value="-dPas2js"/>

packages/rtl/pas2js_rtl.pas

@@ -8,8 +8,8 @@ unit pas2js_rtl;
 interface
 
 uses
-  Classes, JS, Math, NodeJS, ObjPas, RTLConsts, SysUtils, Types, TypInfo, Web, hotreloadclient, DateUtils, strutils, contnrs, 
-  browserconsole;
+  Classes, JS, Math, NodeJS, ObjPas, RTLConsts, SysUtils, Types, TypInfo, Web, 
+  hotreloadclient, DateUtils, strutils, contnrs, browserconsole, webrouter;
 
 implementation
 

packages/rtl/webrouter.pp

@@ -0,0 +1,1508 @@
+{
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 2017 by the Free Pascal development team
+
+    HTTPRoute: HTTP request router
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+}
+
+{
+  Note:
+  The MatchPattern routine was taken from Brook Framework's router unit, by Silvio Clecio.
+}
+
+{$mode objfpc}
+{$H+}
+
+unit webrouter;
+
+interface
+
+uses
+  Classes, SysUtils, web;
+
+Type
+  EHTTPRoute = Class(Exception);
+  TRawLocation = String;
+  TScrollPoint = record
+    X,Y : Double;
+  end;
+
+  // Forward definitions;
+
+  TRouter = Class;
+  TRoute = class;
+  THistory = Class;
+  TRouterClass = Class of TRouter;
+  TRouteEvent = Reference to Procedure (URl : String; aRoute : TRoute; Params: TStrings);
+
+  TTransitionResult = (trOK,trError,trAbort);
+  THistoryKind = (hkAuto,hkAbstract,hkHash,hkHTML5);
+
+  TTransitionNotifyEvent = Reference to Procedure (Sender : THistory; aLocation : String; aRoute : TRoute);
+  TAllowTransitionEvent = Reference to Procedure (Sender : THistory; aOld, aNew : TRoute; Params : TStrings; var Allow : Boolean);
+
+
+  { THistory }
+
+  THistory = Class(TObject)
+  Private
+    FOnAllow: TAllowTransitionEvent;
+    FRouter: TRouter;
+    FOnChange : TNotifyEvent;
+    FOnReady : TTransitionNotifyEvent;
+    FOnError : TTransitionNotifyEvent;
+    FCurrent : TRoute;
+    FBase : String;
+    function GetCurrent: TRoute;
+  Protected
+    procedure SetupListeners; virtual;
+    Function doPush (location: TRawLocation) : TTransitionResult; virtual; abstract;
+    Function doreplace (location: TRawLocation) : TTransitionResult; virtual; abstract;
+    function doGo(N: integer): TTransitionResult; virtual; abstract;
+    procedure ensureURL (push : boolean = false); virtual; abstract;
+  Public
+    Constructor Create(aRouter : TRouter);
+    Constructor Create(aRouter : TRouter; aBase : String); virtual;
+    Class Function NormalizeHash(aHash : String) : string;
+    Procedure UpdateRoute (aRoute : TRoute);
+    Destructor Destroy; override;
+    Function ExpectScroll : Boolean;
+    Function SupportsScroll : Boolean;
+    Class function getLocation (base: string): string;
+    Class function cleanPath(aPath : string): string;
+    // Navigation
+    function GetCurrentLocation: String; virtual; abstract;
+    Function Push (location: TRawLocation) : TTransitionResult;
+    Function Replace (location: TRawLocation) : TTransitionResult;
+    function Go(N: integer): TTransitionResult;
+    Function NavigateForward: TTransitionResult;
+    Function NavigateBack: TTransitionResult;
+    Function TransitionTo(aLocation: TRawLocation) : TTransitionResult;
+    function ConfirmTransition(aRoute: TRoute; Params: TStrings) : TTransitionResult;
+    Property Current : TRoute Read GetCurrent;
+    Property Router : TRouter Read FRouter;
+    Property OnReady : TTransitionNotifyEvent Read FOnReady Write FOnReady;
+    Property OnError : TTransitionNotifyEvent Read FOnError Write FOnError;
+    Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
+    Property OnAllowTransition : TAllowTransitionEvent Read FOnAllow Write FOnAllow;
+    property Base : String Read FBase;
+    function Kind : THistoryKind; virtual; abstract;
+  end;
+
+
+  { TAbstractHistory }
+
+  TAbstractHistory = Class(THistory)
+  Private
+    FIndex: Integer;
+    FStack: Array of TRawLocation;
+    procedure MaybeGrow(AIndex: Integer);
+  Protected
+    Function doPush (location: TRawLocation) : TTransitionResult; override;
+    Function doReplace (location: TRawLocation) : TTransitionResult; override;
+    function doGo(N: integer): TTransitionResult; override;
+  Public
+    constructor Create (router: TRouter; base: string = ''); override;
+    function getCurrentLocation: String; override;
+    Procedure ensureURL (Push: Boolean = False); override;
+    function Kind : THistoryKind; override;
+  end;
+
+  { THashHistory }
+
+  THashHistory = Class(THistory)
+  Protected
+    FlastHash : String;
+    procedure DoHashChange; virtual;
+    procedure SetupListeners; override;
+    Function doPush (location: TRawLocation) : TTransitionResult; override;
+    Function doreplace (location: TRawLocation) : TTransitionResult; override;
+    function doGo(N: integer): TTransitionResult; override;
+    procedure ensureURL (push : boolean = false); override;
+  Public
+    function getCurrentLocation: String; override;
+    Class Procedure pushHash (path : string);
+    Class Procedure replaceHash (path : string);
+    class function getUrl (APath : string) : string;
+    Class function getHash : string;
+    function Kind : THistoryKind; override;
+  end;
+
+  { THTMLHistory }
+
+  THTMLHistory = Class(THistory)
+  Protected
+    FlastLocation : String;
+    procedure DoStateChange; virtual;
+    procedure SetupListeners; override;
+    Function doPush (location: TRawLocation) : TTransitionResult; override;
+    Function doreplace (location: TRawLocation) : TTransitionResult; override;
+    function doGo(N: integer): TTransitionResult; override;
+    procedure ensureURL (push : boolean = false); override;
+  Public
+    function getCurrentLocation: String; override;
+    Class Procedure pushState (path : string; doReplace : boolean = false);
+    Class Procedure replaceState (path : string);
+    function getUrl (ALocation : string) : string;
+    function Kind : THistoryKind; override;
+  end;
+
+  { TRoute }
+
+  TRoute = Class(TCollectionItem)
+  private
+    FDefault: Boolean;
+    FEvent: TRouteEvent;
+    FURLPattern: String;
+    procedure SetURLPattern(AValue: String);
+  Public
+    Class function NormalizeURLPattern(AValue: String): String;
+    Function Matches(Const APattern : String) : Boolean;
+    Function MatchPattern(Const Path : String; L : TStrings) : Boolean;
+    Procedure HandleRequest(ARouter : TRouter; Const URL : String; L : TStrings); virtual; abstract;
+    Function FullPath : String;
+  Published
+    Property Default : Boolean Read FDefault Write FDefault;
+    Property URLPattern : String Read FURLPattern Write SetURLPattern;
+    Property Event : TRouteEvent Read FEvent Write FEvent;
+  end;
+  TRouteClass = Class of TRoute;
+
+
+  { TRouteList }
+
+  TRouteList = Class(TCollection)
+  private
+    function GetR(AIndex : Integer): TRoute;
+    procedure SetR(AIndex : Integer; AValue: TRoute);
+  Public
+    Property Routes[AIndex : Integer] : TRoute Read GetR Write SetR; default;
+  end;
+
+  TRouteObject = Class(TObject)
+    Procedure HandleRoute (Const URL : String; Params : TStrings); virtual; abstract;
+  end;
+  TRouteObjectClass = Class of TRouteObject;
+
+  { TRouter }
+
+  TBeforeRouteEvent = reference to procedure(Sender : TObject; Var ARouteURL : String);
+  TAfterRouteEvent = reference to procedure(Sender : TObject; const ARouteURL : String);
+  TScrollParams = Record
+    selector : string;
+    Position : TScrollPoint;
+  end;
+  TPageScrollEvent = reference to Function(Sender : TObject; aTo,aFrom : TRoute; aPosition : TScrollPoint) : TScrollParams;
+
+
+  TRouter = Class(TComponent)
+  Private
+    Class Procedure DoneService;
+    Class
+      Var FService : TRouter;
+          FServiceClass : TRouterClass;
+  private
+    FAfterRequest: TAfterRouteEvent;
+    FBeforeRequest: TBeforeRouteEvent;
+    FHistory: THistory;
+    FOnScroll: TPageScrollEvent;
+    FRoutes : TRouteList;
+    function GetHistory: THistory;
+    function GetHistoryKind: THistoryKind;
+    function GetR(AIndex : Integer): TRoute;
+    function GetRouteCount: Integer;
+  Protected
+    // Return an instance of given class with Pattern, Method, IsDefault filled in.
+    function CreateHTTPRoute(AClass: TRouteClass; const APattern: String; IsDefault: Boolean ): TRoute; virtual;
+    // Override this if you want to use another collection class.
+    Function CreateRouteList : TRouteList; virtual;
+    Procedure CheckDuplicate(APattern : String; isDefault : Boolean);
+    // Actually route request. Override this for customized behaviour.
+    function DoRouteRequest(ARoute : TRoute; Const AURL : String; AParams : TStrings) : TRoute; virtual;
+    function DoRouteRequest(AURL : String) : TRoute;
+  Public
+    Constructor Create(AOwner: TComponent); override;
+    Destructor Destroy; override;
+    Procedure InitHistory(aKind : THistoryKind; aBase : String = '');
+    // Delete given route by index.
+    Procedure DeleteRoute(AIndex : Integer);
+    // Delete given route by index.
+    Procedure DeleteRouteByID(AID : Integer);
+    // Delete given route by index. The route object will be freed.
+    Procedure DeleteRoute(ARoute : TRoute);
+    // Sanitize route path. Strips of query parameters and makes sure it ends in /
+    class function SanitizeRoute(const Path: String): String;
+    // Global instance.
+    Class Function Service : TRouter;
+    // Class for global instance when it is created;
+    Class Function ServiceClass : TRouterClass;
+    // This will destroy the service
+    Class Procedure SetServiceClass(AClass : TRouterClass);
+    // Register event based route
+    Function RegisterRoute(Const APattern : String; AEvent: TRouteEvent; IsDefault : Boolean = False) : TRoute;overload;
+    // Object class based route. The router is responsible for the lifetime of the object instance
+    Function RegisterRoute(Const APattern : String; const AObjectClass: TRouteObjectClass; IsDefault : Boolean = False) : TRoute; overload;
+    // Find route. Matches Path on the various patterns. If a pattern is found, then the method is tested.
+    // Returns the route that matches the pattern and method.
+    function FindHTTPRoute(const Path: String; Params: TStrings): TRoute;
+    function GetRoute(const Path: String; Params: TStrings): TRoute;
+    // Do actual routing. Exceptions raised will not be caught.
+    // This bypasses the history mechanism.
+    Function RouteRequest(Const ARouteURL : String) : TRoute;
+    // Extract request path from URL. By default, returns the URL
+    function GetRequestPath(const URL: String): String; virtual;
+    // Navigation. These are easy-access methods for history.
+    function GetCurrentLocation: String;
+    // These pass by the history mechanism
+    Function Push (location: TRawLocation) : TTransitionResult;
+    Function Replace (location: TRawLocation) : TTransitionResult;
+    function Go(N: integer): TTransitionResult;
+    Function NavigateForward : TTransitionResult;
+    Function NavigateBack :TTransitionResult;
+    // Indexed access to the registered routes.
+    Property Routes [AIndex : Integer]  : TRoute Read GetR; Default;
+    // Number of registered routes.
+    Property RouteCount : Integer Read GetRouteCount;
+    // Events executed before and after request. In case of exception, after is not executed.
+    Property BeforeRequest : TBeforeRouteEvent Read FBeforeRequest Write FBeforeRequest;
+    Property AfterRequest : TAfterRouteEvent Read FAfterRequest Write FAfterRequest;
+    // OnScroll
+    Property OnScroll : TPageScrollEvent Read FOnScroll Write FOnScroll;
+    // Currently used history mechanism
+    Property History : THistory Read GetHistory;
+    // Kind of current history. Shortcut for History.Kind, returns hkauto if History is not assigned
+    Property HistoryKind : THistoryKind Read GetHistoryKind;
+  end;
+
+  TWebScroll = Class
+    Class Procedure scrollToPosition (AScroll : TScrollParams);
+    Class function getScrollPosition : TScrollPoint;
+    Class Procedure SaveScrollPosition;
+    Class Procedure Setup;
+    Class Procedure handle (router: TRouter; ato: TRoute; afrom: TRoute; isPop: boolean) ;
+    Class Function GetStateKey : String;
+  end;
+
+  TBrowserState = Class
+  Private
+    Class var
+    TheKey : String;
+  Public
+    Class Function GenKey : String;
+    Class Function supportsPushState : Boolean;
+    Class function GetStateKey : string;
+    Class Procedure SetStateKey (akey: string);
+    Class Procedure PushState (aUrl : string; replace : boolean);
+    Class Procedure ReplaceState(aUrl: string);
+  end;
+
+// Shortcut for TRouter.Service;
+Function Router : TRouter;
+Function IncludeHTTPPathDelimiter (S : String) : String;
+
+implementation
+
+uses strutils, typinfo, js;
+
+Resourcestring
+  EDuplicateRoute = 'Duplicate route pattern: %s';
+  EDuplicateDefaultRoute = 'Duplicate default route registered with pattern: %s';
+
+function Router: TRouter;
+begin
+  Result:=TRouter.Service;
+end;
+
+function IncludeHTTPPathDelimiter(S: String): String;
+
+begin
+  If (Copy(S,Length(S),1)='/') then
+    Result:=S
+  else
+    Result:=S+'/';
+end;
+
+{ THTMLHistory }
+
+procedure THTMLHistory.DoStateChange;
+Var
+  NewLocation : String;
+  Old : TRoute;
+
+begin
+  NewLocation:=getLocation(FBase);
+  if (NewLocation=FLastLocation) then
+    exit;
+  old:=Current;
+  if TransitionTo(NewLocation)=trOK then
+    begin
+    TWebScroll.Handle(router, Current, old, true);
+    FLastLocation:=NewLocation;
+    end
+  else
+    replaceState(FLastLocation);
+end;
+
+procedure THTMLHistory.SetupListeners;
+begin
+  Window.addEventListener('popstate',@DoStateChange)
+end;
+
+function THTMLHistory.doPush(location: TRawLocation): TTransitionResult;
+
+begin
+  pushState(GetURL(Location));
+end;
+
+function THTMLHistory.doreplace(location: TRawLocation): TTransitionResult;
+
+begin
+  ReplaceState(GetURL(Location));
+end;
+
+function THTMLHistory.doGo(N: integer): TTransitionResult;
+begin
+  window.history.go(n);
+end;
+
+procedure THTMLHistory.ensureURL(push: boolean);
+
+var
+  URL,Actual,Expected : string;
+
+begin
+  Actual:=getCurrentLocation;
+  Expected:=FlastLocation;
+  if (Actual<>Expected) then
+    begin
+    url:=getUrl(Expected);
+    if Push then
+      pushState(url)
+    else
+      replaceState(url)
+    end;
+end;
+
+function THTMLHistory.getCurrentLocation: String;
+begin
+  Result:=window.locationString;
+end;
+
+class procedure THTMLHistory.pushState(path: string; doReplace: boolean);
+begin
+  TBrowserState.pushState(Path,doReplace);
+end;
+
+class procedure THTMLHistory.replaceState(path: string);
+begin
+  pushState(Path,True);
+end;
+
+function THTMLHistory.getUrl(ALocation : string): string;
+
+begin
+  Result:=IncludeHTTPPathDelimiter(FBase);
+  While (ALocation<>'') and (Copy(ALocation,1,1)='/') do
+    ALocation:=Copy(ALocation,2,Length(ALocation)-1);
+  Result:=FBase+Alocation;
+end;
+
+function THTMLHistory.Kind: THistoryKind;
+begin
+  Result:=hkHTML5;
+end;
+
+{ THistory }
+
+function THistory.GetCurrent: TRoute;
+begin
+  Result:=FCurrent;
+end;
+
+constructor THistory.Create(aRouter: TRouter);
+begin
+  Create(aRouter,'');
+end;
+
+constructor THistory.Create(aRouter: TRouter; aBase: String);
+begin
+  FRouter:=aRouter;
+  FBase:=aBase;
+end;
+
+class function THistory.NormalizeHash(aHash: String): string;
+
+begin
+  Result:=aHash;
+  if Copy(Result,1,1)<>'/' then
+    Result:='/'+Result;
+end;
+
+destructor THistory.Destroy;
+begin
+  inherited Destroy;
+end;
+
+function THistory.ExpectScroll: Boolean;
+
+begin
+  Result:=Assigned(Router) and Assigned(Router.OnScroll);
+end;
+
+function THistory.SupportsScroll: Boolean;
+begin
+  Result:=TBrowserState.supportsPushState and ExpectScroll;
+end;
+
+function THistory.TransitionTo(aLocation: TRawLocation): TTransitionResult;
+
+Var
+  H : TStrings;
+  Params : TStrings;
+  R : TRoute;
+  I : Integer;
+
+begin
+  Params:=TStringList.Create;
+  try
+    R:=Router.FindHTTPRoute(aLocation,Params);
+    Case ConfirmTransition(R,Params) of
+    trOK :
+      begin
+      R:=Router.DoRouteRequest(R,aLocation,Params);
+      UpdateRoute(R);
+      if Assigned(OnReady) then
+        OnReady(Self,aLocation,R);
+      end;
+    trError:
+      if Assigned(OnError) then
+        FOnError(Self,aLocation,R);
+    end;
+  Finally
+    Params.Free;
+  end;
+end;
+
+function THistory.ConfirmTransition(aRoute: TRoute; Params : TStrings): TTransitionResult;
+
+Var
+  Old : TRoute;
+  allow : Boolean;
+
+begin
+  Old:=Current;
+  Allow:=True;
+  if Assigned(FOnAllow) then
+    FOnAllow(Self,old,aRoute,Params,Allow);
+  if Not Allow then
+    begin
+    ensureURL();
+    Result:=trAbort;
+    end;
+  Result:=trOK;
+end;
+
+{ TRouteObjectHandler }
+
+Type
+  TRouteObjectHandler = Class(TRoute)
+  private
+    FObjectClass: TRouteObjectClass;
+  Public
+    Procedure HandleRequest(ARouter : TRouter; Const URL : String; Params  : TStrings); override;
+    Property RouteObjectClass : TRouteObjectClass Read FObjectClass Write FObjectClass;
+  end;
+
+  { TRouteEventHandler }
+
+  TRouteEventHandler = Class(TRoute)
+  Public
+    Procedure HandleRequest(ARouter : TRouter; Const URL : String; Params  : TStrings); override;
+    Property Event : TRouteEvent Read FEvent Write FEvent;
+  end;
+
+{ TRouteEventHandler }
+
+procedure TRouteEventHandler.HandleRequest(ARouter : TRouter; const URL: String; Params: TStrings);
+begin
+  If Assigned(Event) then
+    Event(URL,Self,Params);
+end;
+
+procedure TRouteObjectHandler.HandleRequest(ARouter : TRouter; Const URL : String; Params : TStrings);
+
+Var
+  O : TRouteObject;
+
+begin
+  O:=RouteObjectClass.Create;
+  try
+    O.HandleRoute(URL,Params);
+  finally
+    O.Free;
+  end;
+end;
+
+
+
+{ TRouter }
+
+function TRouter.GetR(AIndex : Integer): TRoute;
+begin
+  Result:=FRoutes[AIndex]
+end;
+
+function TRouter.GetHistory: THistory;
+begin
+  If (FHistory=Nil) then
+    InitHistory(hkAuto,'');
+  Result:=FHistory;
+end;
+
+function TRouter.GetHistoryKind: THistoryKind;
+begin
+  if Not assigned(History) then
+    Result:=hkAuto
+  else
+    Result:=History.Kind;
+end;
+
+class procedure TRouter.DoneService;
+begin
+  FreeAndNil(FService);
+end;
+
+function TRouter.GetRouteCount: Integer;
+begin
+  Result:=FRoutes.Count;
+end;
+
+function TRouter.CreateRouteList: TRouteList;
+begin
+  Result:=TRouteList.Create(TRoute);
+end;
+
+procedure TRouter.CheckDuplicate(APattern: String; isDefault: Boolean);
+Var
+  I,DI : Integer;
+  R : TRoute;
+
+begin
+  DI:=-1;
+  For I:=0 to FRoutes.Count-1 do
+    begin
+    R:=FRoutes[I];
+    if R.Default then
+      DI:=I;
+    if R.Matches(APattern) then
+      Raise EHTTPRoute.CreateFmt(EDuplicateRoute,[APattern]);
+    end;
+  if isDefault and (DI<>-1) then
+    Raise EHTTPRoute.CreateFmt(EDuplicateDefaultRoute,[APattern]);
+end;
+
+function TRouter.DoRouteRequest(ARoute: TRoute; const AURL: String;
+  AParams: TStrings): TRoute;
+begin
+  Result:=aRoute;
+  Result.HandleRequest(Self,aURL,AParams);
+end;
+
+function TRouter.DoRouteRequest(AURL: String): TRoute;
+
+Var
+  APath : String;
+  Params : TStrings;
+
+begin
+  APath:=AURL;
+  Params:=TStringList.Create;
+  try
+    Result:=GetRoute(APath,Params);
+    Result:=DoRouteRequest(Result,aPath,Params);
+  finally
+    Params.Free;
+  end;
+end;
+
+function TRouter.GetRequestPath(const URL: String): String;
+begin
+  Result:=SanitizeRoute(URL);
+end;
+
+function TRouter.GetCurrentLocation: String;
+begin
+
+end;
+
+function TRouter.Push(location: TRawLocation): TTransitionResult;
+begin
+  Result:=History.Push(location);
+end;
+
+function TRouter.Replace(location: TRawLocation): TTransitionResult;
+begin
+  Result:=History.Replace(location);
+end;
+
+function TRouter.Go(N: integer): TTransitionResult;
+begin
+  Result:=History.Go(N);
+end;
+
+function TRouter.NavigateForward: TTransitionResult;
+begin
+  Result:=Go(1);
+end;
+
+function TRouter.NavigateBack: TTransitionResult;
+begin
+  Result:=Go(-1);
+end;
+
+constructor TRouter.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  froutes:=CreateRouteList;
+end;
+
+destructor TRouter.Destroy;
+begin
+  FreeAndNil(FRoutes);
+  inherited Destroy;
+end;
+
+procedure TRouter.InitHistory(aKind: THistoryKind; aBase : String = '');
+
+begin
+  FreeAndNil(FHistory);
+  case aKind of
+    hkAbstract : FHistory:=TAbstractHistory.Create(Self,aBase);
+    hkhash : FHistory:=THashHistory.Create(Self,aBase);
+    hkHTML5 : FHistory:=THTMLHistory.Create(Self,aBase);
+    hkAuto :
+      if TBrowserState.supportsPushState then
+        FHistory:=THTMLHistory.Create(Self,aBase)
+      else
+        FHistory:=THashHistory.Create(Self,aBase);
+  end;
+  FHistory.SetupListeners;
+end;
+
+procedure TRouter.DeleteRoute(AIndex: Integer);
+begin
+  FRoutes.Delete(Aindex)
+end;
+
+procedure TRouter.DeleteRouteByID(AID: Integer);
+
+Var
+  R : TCollectionItem;
+
+begin
+  R:=FRoutes.FindItemID(AID);
+  R.Free;
+end;
+
+procedure TRouter.DeleteRoute(ARoute: TRoute);
+begin
+  ARoute.Free;
+end;
+
+class function TRouter.Service: TRouter;
+begin
+  if FService=Nil then
+    FService:=ServiceClass.Create(Nil);
+  Result:=FService;
+end;
+
+class function TRouter.ServiceClass: TRouterClass;
+begin
+  If FServiceClass=nil then
+    FServiceClass:=TRouter;
+  Result:=FServiceClass;
+end;
+
+class procedure TRouter.SetServiceClass(AClass: TRouterClass);
+begin
+  if Assigned(FService) then
+    FreeAndNil(FService);
+  FServiceClass:=AClass;
+end;
+
+function TRouter.RegisterRoute(const APattern: String; AEvent: TRouteEvent; IsDefault: Boolean): TRoute;
+begin
+  Result:=CreateHTTPRoute(TRouteEventHandler,APattern,IsDefault);
+  TRouteEventHandler(Result).Event:=AEvent;
+end;
+
+function TRouter.CreateHTTPRoute(AClass : TRouteClass; const APattern: String;IsDefault: Boolean) : TRoute;
+
+begin
+  CheckDuplicate(APattern,isDefault);
+  Result:=AClass.Create(FRoutes);
+  With Result do
+    begin
+    URLPattern:=APattern;
+    Default:=IsDefault;
+    end;
+end;
+
+function TRouter.RegisterRoute(const APattern: String; const AObjectClass: TRouteObjectClass; IsDefault: Boolean): TRoute;
+begin
+  Result:=CreateHTTPRoute(TRouteObjectHandler,APattern,IsDefault);
+  TRouteObjectHandler(Result).RouteObjectCLass:=AObjectClass;
+end;
+
+class function TRouter.SanitizeRoute(const Path: String): String;
+
+begin
+  Result:=Path;
+end;
+
+function TRouter.FindHTTPRoute(const Path: String; Params : TStrings): TRoute;
+
+Var
+  I : Integer;
+  APathInfo : String;
+
+begin
+  APathInfo:=SanitizeRoute(Path);
+  Result:=Nil;
+  I:=0;
+  While (Result=Nil) and (I<FRoutes.Count) do
+    begin
+    Result:=FRoutes[i];
+    If Not Result.MatchPattern(APathInfo,Params) then
+      Result:=Nil;
+    Inc(I);
+    end;
+end;
+
+function TRouter.GetRoute(const Path: String; Params : TStrings): TRoute;
+
+begin
+  Result:=FindHTTPRoute(Path,Params);
+  if Not Assigned(Result) then
+    Raise EHTTPRoute.Create('Not found');
+end;
+
+function TRouter.RouteRequest(const ARouteURL: String): TRoute;
+
+Var
+  AURL : String;
+
+begin
+  AURL:=ARouteURL;
+  If Assigned(FBeforeRequest) then
+    FBeforeRequest(Self,AURL);
+  Result:=DoRouteRequest(AURL);
+  If Assigned(FAfterRequest) then
+    FAfterRequest(Self,AURL);
+end;
+
+{ TRouteList }
+
+function TRouteList.GetR(AIndex : Integer): TRoute;
+begin
+  Result:=Items[AIndex] as TRoute;
+end;
+
+procedure TRouteList.SetR(AIndex : Integer; AValue: TRoute);
+begin
+  Items[AIndex]:=AValue;
+end;
+
+{ TRoute }
+
+Class Function TRoute.NormalizeURLPattern(AValue: String) : String;
+
+Var
+  V : String;
+
+begin
+  V:=IncludeHTTPPathDelimiter(AValue);
+  if (V<>'/') and (V[1]='/') then
+    Delete(V,1,1);
+  Result:=V;
+end;
+
+procedure TRoute.SetURLPattern(AValue: String);
+
+Var
+  V : String;
+
+begin
+  V:=NormalizeURLPattern(AValue);
+  if (FURLPattern=V) then Exit;
+  FURLPattern:=V;
+end;
+
+function TRoute.Matches(const APattern: String): Boolean;
+
+begin
+  Result:=(CompareText(URLPattern,NormalizeURLPattern(APattern))=0)
+end;
+
+Function TRoute.MatchPattern(Const Path : String; L : TStrings) : Boolean;
+
+  Function StartsWith(C : Char; S : String): Boolean; 
+  
+  begin
+    Result:=(Length(S)>0) and (S[1]=C);
+  end;
+  
+  Function EndsWith(C : Char; S : String): Boolean; 
+  
+  Var
+  L : Integer;
+  
+  begin
+    L:=Length(S);
+    Result:=(L>0) and (S[L]=C);
+  end;
+
+  procedure ExtractNextPathLevel(var ALeft: string;
+    var ALvl: string; var ARight: string; const ADelim: Char = '/');
+  var
+    P: Integer;
+  begin
+    Writeln('ExtractNextPathLevel >:',Aleft,' (',aLvl,') ',aRight);
+    if (ALvl<>ADelim) then
+      begin
+      ALeft:=ALeft+ALvl;
+      if StartsWith(ADelim,ARight) then
+        begin
+        ALeft:=ALeft+ADelim;
+        Delete(ARight,1,1);
+        end;
+      end;
+    P:=Pos(ADelim,ARight);
+    if P=0 then
+      P:=Length(ARight)+1;
+    ALvl:=Copy(ARight,1,P-1);
+    ARight:=Copy(ARight,P,MaxInt);
+    Writeln('ExtractNextPathLevel <:',Aleft,' (',aLvl,') ',aRight);
+  end;
+
+  procedure ExtractPrevPathLevel(var ALeft: string;
+    var ALvl: string; var ARight: string; const ADelim: Char = '/');
+  var
+    P,L: Integer;
+  begin
+    Writeln('ExtractPrevPathLevel >:',Aleft,' (',aLvl,') ',aRight);
+    if (ALvl<>ADelim) then
+      begin
+      ARight:=ALvl+ARight;
+      L:=Length(ALeft);
+      if EndsWith(ADelim,ALeft) then
+        begin
+        ARight:=ADelim+ARight;
+        Delete(ALeft,L,1);
+        end;
+      end;
+    P:=RPos(ADelim,ALeft);
+    ALvl:=Copy(ALeft,P+1,MaxInt);
+    ALeft:=Copy(ALeft,1,P);
+    Writeln('ExtractPrevPathLevel <:',Aleft,' (',aLvl,') ',aRight);
+  end;
+
+  Procedure AddParam(aName,AValue : String);
+
+  begin
+    if Assigned(L) then
+      L.Values[aName]:=aValue;
+  end;
+
+var
+  APathInfo : String;
+  APattern : String;
+  VLeftPat, VRightPat, VLeftVal, VRightVal, VVal, VPat, VName: string;
+
+begin
+  Result:= False;
+  if (URLPattern='') then
+     Exit; // Maybe empty pattern should match any path?
+  APathInfo:=Path;
+  APattern:=URLPattern;
+  Delete(APattern, Pos('?', APattern), MaxInt);
+  Delete(APathInfo, Pos('?', APathInfo), MaxInt);
+  if StartsWith('/',APattern) then
+    Delete(APattern,1,1);
+  if StartsWith('/',APathInfo) then
+    Delete(APathInfo,1,1);
+  VLeftPat := '';
+  VLeftVal := '';
+  VPat := '/'; // init value is '/', not ''
+  VVal := '/'; // init value is '/', not ''
+  VRightPat := APattern;
+  VRightVal := APathInfo;
+  Writeln('Check match on ',URLPattern);
+  repeat
+    // Extract next part
+    ExtractNextPathLevel(VLeftPat, VPat, VRightPat);
+    ExtractNextPathLevel(VLeftVal, VVal, VRightVal);
+    Writeln('Pat: ',VPat,' Val: ',VVal);
+    if StartsWith(':',VPat) then
+      AddParam(Copy(VPat,2,Maxint),VVal)
+    else
+      if StartsWith('*',VPat) then
+        begin
+        // *path
+        VName := Copy(VPat, 2, MaxInt);
+        VLeftPat := VRightPat;
+        VLeftVal := VVal + VRightVal;
+        VPat := '/'; // init value is '/', not ''
+        VVal := '/'; // init value is '/', not ''
+        VRightPat := '';
+        VRightVal := '';
+        // if AutoAddSlash ...
+        if EndsWith('/',VLeftPat) and not EndsWith('/',VLeftVal) then
+          Delete(VLeftPat, Length(VLeftPat), 1);
+        repeat
+          // Extract backwards
+          ExtractPrevPathLevel(VLeftPat, VPat, VRightPat);
+          ExtractPrevPathLevel(VLeftVal, VVal, VRightVal);
+          if StartsWith(':', VPat) then
+            begin
+            // *path/:field
+            AddParam(Copy(VPat,2,Maxint),VVal);
+            end
+          else
+            // *path/const
+            if not ((VPat='') and (VLeftPat='')) and (VPat<>VVal) then
+              Exit;
+          // Check if we already done
+          if (VLeftPat='') or (VLeftVal='') then
+            begin
+            if VLeftPat='' then
+              begin
+              if (VName<>'') then
+                AddParam(VName,VLeftVal+VVal);
+              Result:=True;
+              end;
+            Exit;
+          end;
+        until False;
+        end
+      else
+        // const
+        if (VPat <> VVal) then
+          Exit;
+    // Check if we already done
+    if (VRightPat='') or (VRightVal='') then
+      begin
+      if (VRightPat='') and (VRightVal='') then
+        Result:=True
+      else if (VRightPat='/') then
+        Result := True;
+      Exit;
+      end;
+  until False;
+end;
+
+function TRoute.FullPath: String;
+begin
+  Result:=URLPattern;
+end;
+
+class function THistory.getLocation(base: string): string;
+
+Var
+  path : string;
+
+begin
+  path:=window.location.pathname;
+  if (base<>'') and (Pos(base,path)=1) then
+    path:=Copy(Path,Length(Base)+1,Length(Path)-Length(Base));
+  Result:=Path;
+  if Result='' then
+    Result:='/';
+  Result:=Result+window.location.search+window.location.hash
+end;
+
+class function THistory.cleanPath(aPath: string): string;
+begin
+  Result:=StringReplace(aPath,'//','/',[rfReplaceAll]);
+end;
+
+function THistory.Push(location: TRawLocation): TTransitionResult;
+
+Var
+  Old : TRoute;
+
+begin
+  Old:=Current;
+  Result:=TransitionTo(location);
+  if Result=trOK then
+    begin
+    Result:=doPush(Location);
+    if Result=trOK then
+      TWebScroll.Handle(router, Current, Old, false)
+    end;
+end;
+
+function THistory.Replace(location: TRawLocation): TTransitionResult;
+
+Var
+  Old : TRoute;
+
+begin
+  Old:=Current;
+  Result:=TransitionTo(location);
+  if Result=trOK then
+    begin
+    Result:=doReplace(Location);
+    TWebScroll.Handle(Router,Current,Old,false);
+    end;
+
+end;
+
+function THistory.Go(N: integer): TTransitionResult;
+begin
+  Result:=doGo(N);
+end;
+
+function THistory.NavigateForward: TTransitionResult;
+begin
+  Result:=Go(1);
+end;
+
+function THistory.NavigateBack: TTransitionResult;
+begin
+  Result:=Go(-1);
+end;
+
+
+procedure THistory.SetupListeners;
+begin
+  // Do nothing
+end;
+
+
+function DoScroll(Event: TEventListenerEvent): boolean;
+
+begin
+  TWebScroll.SaveScrollPosition;
+  Result:=True;
+end;
+
+Class Function TWebScroll.GetStateKey : string;
+
+begin
+  Result:=TJSDate.New().toString;
+end;
+
+Class Procedure TWebScroll.Setup;
+
+begin
+//  web.window.;
+  window.history.replaceState(New(['key', GetStateKey]), '');
+  window.addEventListener('popstate',@DoScroll);
+end;
+
+Class Procedure TWebScroll.handle (router: TRouter; ato: TRoute; afrom: TRoute; isPop: boolean) ;
+
+Var
+  Position : TScrollPoint;
+  ScrollParams : TScrollParams;
+
+begin
+  if Not Assigned(Router.OnScroll) then
+    Exit;
+  position:=getScrollPosition();
+  ScrollParams:=Router.OnScroll(Router, aTo, aFrom, position);
+  scrollToPosition(ScrollParams);
+end;
+
+Var
+  positionStore : TJSObject;
+
+Class procedure TWebScroll.saveScrollPosition;
+
+Var
+  Key : string;
+begin
+  key:=getStateKey();
+  if Key<>'' then
+    positionStore.properties[key]:=New(['x',window.ScrollX,'y',window.ScrollY]);
+end;
+
+Class function TWebScroll.getScrollPosition : TScrollPoint;
+
+Var
+  Key : string;
+  O : JSValue;
+
+begin
+  key:=getStateKey();
+  Result.X:=0;
+  Result.Y:=0;
+  if (Key<>'') then
+    begin
+    O:=positionStore[key];
+    if isObject(O) then
+      begin
+      Result.X:=Double(TJSOBject(O).Properties['x']);
+      Result.Y:=Double(TJSOBject(O).Properties['y']);
+      end;
+  end;
+end;
+
+function getElementPosition (el: TJSElement; offset: TScrollPoint): TScrollPoint ;
+
+Var
+  DocEl : TJSElement;
+  docRect,elRect : TJSDOMRect;
+
+begin
+  docEl:=document.documentElement;
+  docRect := docEl.getBoundingClientRect();
+  elRect := el.getBoundingClientRect();
+  Result.x:= elRect.left - docRect.left - offset.x;
+  Result.Y:= elRect.top - docRect.top - offset.y;
+end;
+
+Class Procedure TWebScroll.ScrollToPosition(AScroll : TScrollParams);
+
+
+Var
+  el : TJSElement;
+  P : TScrollPoint;
+
+begin
+  if (AScroll.Selector<>'') then
+    begin
+    el:=document.querySelector(AScroll.Selector);
+    if Assigned(el) then
+      P:=getElementPosition(el,AScroll.Position)
+    else
+      P:=AScroll.Position;
+    end
+  else
+    P:=AScroll.Position;
+  Window.scrollTo(Round(P.x),Round(P.y));
+end;
+
+
+Class function TBrowserState.genKey (): string ;
+begin
+  Result:=IntToStr(TJSDate.now);
+end;
+
+Class function TBrowserState.getStateKey : string;
+begin
+  if (TheKey='') then
+    TheKey:=genKey;
+  Result:=Thekey;
+end;
+
+Class Procedure TBrowserState.SetStateKey (akey: string);
+
+begin
+  Thekey:=akey;
+end;
+
+Class Procedure TBrowserState.pushState (aurl: string; replace: boolean);
+
+Var
+  O : TJSObject;
+
+begin
+  TWebScroll.SaveScrollPosition;
+  try
+    if (Not replace) then
+      SetStateKey(GenKey);
+    O:=New(['key', GetStateKey()]);
+    if replace then
+      window.history.replaceState(o, '', aUrl)
+    else
+      window.history.pushState(o, '', aUrl);
+  except
+    if Replace then
+      window.location.replace(aUrl)
+    else
+      window.location.Assign(aUrl);
+  end;
+end;
+
+Class Procedure TBrowserState.replaceState(aUrl: string);
+
+begin
+  pushState(aUrl, true)
+end;
+
+Class Function TBrowserState.supportsPushState : Boolean;
+
+Var
+  UA : String;
+
+  Function isB(B : String) : Boolean;
+
+  begin
+    Result:=Pos(B,UA)<>0;
+  end;
+
+begin
+  if Result and isDefined(Window) and isDefined(Window.Navigator) then
+    begin
+    ua:=Window.Navigator.userAgent;
+    Result:=Not (
+                 IsB('Android 2.')
+                 or IsB('Android 4.0')
+                 or IsB('Mobile Safari')
+                 or IsB('Chrome')
+                 or isB('Windows Phone')
+                 );
+    If Result then
+      Result:=isDefined(Window.history) and isDefined(Window.history);
+    end;
+end;
+
+{ ---------------------------------------------------------------------
+  THashHistory
+  ---------------------------------------------------------------------}
+
+procedure THashHistory.DoHashChange;
+
+Var
+  NewHash : String;
+  Old : TRoute;
+
+begin
+  NewHash:=NormalizeHash(GetHash);
+  if (NewHash=FLastHash) then
+    exit;
+  old:=Current;
+  if TransitionTo(NewHash)=trOK then
+    begin
+    TWebScroll.Handle(router, Current, old, true);
+    FLastHash:=NewHash;
+    end
+  else
+    replaceHash(FLastHash);
+end;
+
+procedure THashHistory.SetupListeners;
+
+begin
+  if SupportsScroll then
+    TWebScroll.Setup;
+  if TBrowserState.SupportsPushState then
+    Window.addEventListener('popstate',@DoHashChange)
+  else
+    Window.addEventListener('hashchange',@DoHashChange);
+end;
+
+function THashHistory.doPush (location: TRawLocation) : TTransitionResult;
+
+Var
+  L : String;
+
+begin
+  L:=NormalizeHash(location);
+  FLastHash:=L;
+  pushHash(L);
+end;
+
+function THashHistory.doreplace(location: TRawLocation): TTransitionResult;
+
+Var
+  L : String;
+
+begin
+  L:=NormalizeHash(location);
+  FLastHash:=L;
+  replaceHash(L);
+end;
+
+function THashHistory.doGo(N: integer): TTransitionResult;
+begin
+  Window.history.go(n);
+  result:=trOK;
+end;
+
+procedure THashHistory.ensureURL (push : boolean = false);
+
+var
+  aHash,CURL: string;
+
+begin
+  CURL:=NormalizeHash(FLastHash);
+  aHash:=getHash;
+   if (aHash<>CURL) then
+     if Push then
+       pushHash(CURL)
+     else
+       replaceHash(CURL)
+end;
+
+function THashHistory.getCurrentLocation: String;
+
+begin
+  Result:=getHash()
+end;
+
+
+class function THashHistory.getHash: string;
+
+Var
+  HRef : String;
+  Idx : Integer;
+
+begin
+  // We can't use window.location.hash here because it's not
+  // consistent across browsers - Firefox will pre-decode it!
+  HRef:=window.location.href;
+  Idx:=Pos('#',HRef);
+  if (Idx=0) then
+    Result:=''
+  else
+    Result:=Copy(HRef,Idx+1,Length(HRef)-Idx);
+end;
+
+function THashHistory.Kind : THistoryKind;
+begin
+  Result:=hkHash;
+end;
+
+class function THashHistory.getUrl (APath : string) : string;
+
+Var
+  Base,HRef : String;
+  Idx : Integer;
+
+begin
+  HRef:=window.location.href;
+  Idx:=Pos('#',HRef);
+  if Idx=0 then
+    Result:=HRef
+  else
+    Result:=Copy(HRef,1,Idx-1);
+  Result:=Result+'#'+aPath;
+end;
+
+class procedure THashHistory.pushHash(path: string);
+
+begin
+  if (TBrowserState.supportsPushState) then
+    TBrowserState.pushState(getUrl(path),false)
+  else
+    window.location.hash:=path
+end;
+
+class procedure THashHistory.replaceHash(path: string);
+
+Var
+  H : String;
+
+begin
+  H:=GetHash;
+  if (H=Path) then exit;
+  if (TBrowserState.supportsPushState) then
+    TBrowserState.replaceState(getUrl(path))
+  else
+    window.location.replace(getUrl(path))
+end;
+
+
+
+{ ---------------------------------------------------------------------
+  TAbstractHistory
+  ---------------------------------------------------------------------}
+
+constructor TAbstractHistory.Create (router: TRouter; base: string = '');
+
+begin
+  Inherited;
+  SetLength(FStack,0);
+  FIndex:=-1;
+end;
+
+procedure TAbstractHistory.MaybeGrow(AIndex: Integer);
+
+begin
+  if AIndex+1>Length(FStack) then
+    Setlength(FStack,AIndex+1);
+end;
+
+function TAbstractHistory.doPush(location: TRawLocation): TTransitionResult;
+
+begin
+  Inc(FIndex);
+  MaybeGrow(FIndex);
+  FStack[FIndex]:=Location;
+end;
+
+function TAbstractHistory.doReplace(location: TRawLocation): TTransitionResult;
+
+begin
+  FStack[FIndex]:=Location;
+end;
+
+function TAbstractHistory.doGo(N: integer): TTransitionResult;
+
+Var
+  I : Integer;
+  Route : TRoute;
+
+begin
+  I:=FIndex+N;
+  if (I<0) or (I>=Length(FStack)) then
+    Result:=trAbort
+  else
+    begin
+//    Route:=FStack[i];
+//    Result:=confirmTransition(Route);
+    if (Result=trOK) then
+      begin
+      FIndex:=0;
+      updateRoute(Route);
+      end;
+    end;
+end;
+
+procedure THistory.UpdateRoute(aRoute: TRoute);
+
+begin
+  FCurrent:=aRoute;
+  if Assigned(FOnChange) then
+    FOnChange(aRoute);
+end;
+
+function TAbstractHistory.getCurrentLocation: String;
+
+Var
+  I : Integer;
+  Route : string;
+
+begin
+  I:=Length(FStack)-1;
+  if (I>=0) then
+    Route:=FStack[I]
+  else
+    Result:='/';
+end;
+
+procedure TAbstractHistory.ensureURL(Push: Boolean);
+
+begin
+  // Noop
+end;
+
+function TAbstractHistory.Kind: THistoryKind;
+begin
+  Result:=hkAbstract;
+end;
+
+begin
+  positionStore:=new([]);
+end.
+